pax_global_header00006660000000000000000000000064151766606460014533gustar00rootroot0000000000000052 comment=df59b68361b1efbd697b17c40f7fae4a35991c44 coq-gappalib-coq-1.10.0-df59b68361b1efbd697b17c40f7fae4a35991c44/000077500000000000000000000000001517666064600224675ustar00rootroot00000000000000coq-gappalib-coq-1.10.0-df59b68361b1efbd697b17c40f7fae4a35991c44/AUTHORS000066400000000000000000000000631517666064600235360ustar00rootroot00000000000000Guillaume Melquiond coq-gappalib-coq-1.10.0-df59b68361b1efbd697b17c40f7fae4a35991c44/COPYING000066400000000000000000000167431517666064600235350ustar00rootroot00000000000000 GNU LESSER GENERAL PUBLIC LICENSE Version 3, 29 June 2007 Copyright (C) 2007 Free Software Foundation, Inc. Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. This version of the GNU Lesser General Public License incorporates the terms and conditions of version 3 of the GNU General Public License, supplemented by the additional permissions listed below. 0. Additional Definitions. As used herein, "this License" refers to version 3 of the GNU Lesser General Public License, and the "GNU GPL" refers to version 3 of the GNU General Public License. "The Library" refers to a covered work governed by this License, other than an Application or a Combined Work as defined below. An "Application" is any work that makes use of an interface provided by the Library, but which is not otherwise based on the Library. Defining a subclass of a class defined by the Library is deemed a mode of using an interface provided by the Library. A "Combined Work" is a work produced by combining or linking an Application with the Library. The particular version of the Library with which the Combined Work was made is also called the "Linked Version". The "Minimal Corresponding Source" for a Combined Work means the Corresponding Source for the Combined Work, excluding any source code for portions of the Combined Work that, considered in isolation, are based on the Application, and not on the Linked Version. The "Corresponding Application Code" for a Combined Work means the object code and/or source code for the Application, including any data and utility programs needed for reproducing the Combined Work from the Application, but excluding the System Libraries of the Combined Work. 1. Exception to Section 3 of the GNU GPL. You may convey a covered work under sections 3 and 4 of this License without being bound by section 3 of the GNU GPL. 2. Conveying Modified Versions. If you modify a copy of the Library, and, in your modifications, a facility refers to a function or data to be supplied by an Application that uses the facility (other than as an argument passed when the facility is invoked), then you may convey a copy of the modified version: a) under this License, provided that you make a good faith effort to ensure that, in the event an Application does not supply the function or data, the facility still operates, and performs whatever part of its purpose remains meaningful, or b) under the GNU GPL, with none of the additional permissions of this License applicable to that copy. 3. Object Code Incorporating Material from Library Header Files. The object code form of an Application may incorporate material from a header file that is part of the Library. You may convey such object code under terms of your choice, provided that, if the incorporated material is not limited to numerical parameters, data structure layouts and accessors, or small macros, inline functions and templates (ten or fewer lines in length), you do both of the following: a) Give prominent notice with each copy of the object code that the Library is used in it and that the Library and its use are covered by this License. b) Accompany the object code with a copy of the GNU GPL and this license document. 4. Combined Works. You may convey a Combined Work under terms of your choice that, taken together, effectively do not restrict modification of the portions of the Library contained in the Combined Work and reverse engineering for debugging such modifications, if you also do each of the following: a) Give prominent notice with each copy of the Combined Work that the Library is used in it and that the Library and its use are covered by this License. b) Accompany the Combined Work with a copy of the GNU GPL and this license document. c) For a Combined Work that displays copyright notices during execution, include the copyright notice for the Library among these notices, as well as a reference directing the user to the copies of the GNU GPL and this license document. d) Do one of the following: 0) Convey the Minimal Corresponding Source under the terms of this License, and the Corresponding Application Code in a form suitable for, and under terms that permit, the user to recombine or relink the Application with a modified version of the Linked Version to produce a modified Combined Work, in the manner specified by section 6 of the GNU GPL for conveying Corresponding Source. 1) Use a suitable shared library mechanism for linking with the Library. A suitable mechanism is one that (a) uses at run time a copy of the Library already present on the user's computer system, and (b) will operate properly with a modified version of the Library that is interface-compatible with the Linked Version. e) Provide Installation Information, but only if you would otherwise be required to provide such information under section 6 of the GNU GPL, and only to the extent that such information is necessary to install and execute a modified version of the Combined Work produced by recombining or relinking the Application with a modified version of the Linked Version. (If you use option 4d0, the Installation Information must accompany the Minimal Corresponding Source and Corresponding Application Code. If you use option 4d1, you must provide the Installation Information in the manner specified by section 6 of the GNU GPL for conveying Corresponding Source.) 5. Combined Libraries. You may place library facilities that are a work based on the Library side by side in a single library together with other library facilities that are not Applications and are not covered by this License, and convey such a combined library under terms of your choice, if you do both of the following: a) Accompany the combined library with a copy of the same work based on the Library, uncombined with any other library facilities, conveyed under the terms of this License. b) Give prominent notice with the combined library that part of it is a work based on the Library, and explaining where to find the accompanying uncombined form of the same work. 6. Revised Versions of the GNU Lesser General Public License. The Free Software Foundation may publish revised and/or new versions of the GNU Lesser General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Library as you received it specifies that a certain numbered version of the GNU Lesser General Public License "or any later version" applies to it, you have the option of following the terms and conditions either of that published version or of any later version published by the Free Software Foundation. If the Library as you received it does not specify a version number of the GNU Lesser General Public License, you may choose any version of the GNU Lesser General Public License ever published by the Free Software Foundation. If the Library as you received it specifies that a proxy can decide whether future versions of the GNU Lesser General Public License shall apply, that proxy's public statement of acceptance of any version is permanent authorization for you to choose that version for the Library. coq-gappalib-coq-1.10.0-df59b68361b1efbd697b17c40f7fae4a35991c44/INSTALL.md000066400000000000000000000026061517666064600241230ustar00rootroot00000000000000Prerequisites ------------- The Coq proof assistant (>= 8.16) and the Flocq library (>= 4.1, https://flocq.gitlabpages.inria.fr/) needs to be installed. In order to use the `gappa` tactic, Gappa also needs to be installed. 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 -j2 && ./remake install The `COQC` environment variable 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 same OCaml environment used for compiling Coq should be used for compiling the tactic. It is found by calling `$COQC -config`. The `OCAMLFIND` environment variable can be used to override this choice. The library files are compiled at the logical location `Gappa`. The `COQUSERCONTRIB` environment variable can be used to override the physical location where the `Gappa` directory containing these files will be installed by `./remake install`. By default, the target directory is `` `$COQC -where`/user-contrib ``. coq-gappalib-coq-1.10.0-df59b68361b1efbd697b17c40f7fae4a35991c44/NEWS.md000066400000000000000000000142511517666064600235700ustar00rootroot00000000000000Version 1.10.0 ------------- - added support for Gappa 1.8 Version 1.9.0 ------------- - added partial support for Gappa 1.8 Version 1.8.0 ------------- - added support for Gappa 1.7 - ensured compatibility from Coq 8.16 to Rocq 9.2 Version 1.7.1 ------------- - ensured compatibility from Coq 8.16 to Rocq 9.0 Version 1.7.0 ------------- - added support for Gappa 1.6 - added support for `LIN` properties as `|x| <= b*|y|` in the gappa tactic Version 1.6.0 ------------- - added support for Gappa 1.5 - removed support for Coq < 8.16 Version 1.5.5 ------------- - ensured compatibility from Coq 8.8 to 8.19 Version 1.5.4 ------------- - ensured compatibility from Coq 8.8 to 8.18 Version 1.5.3 ------------- - ensured compatibility from Coq 8.8 to 8.17 Version 1.5.2 ------------- - ensured compatibility from Coq 8.8 to 8.16 Version 1.5.1 ------------- - ensured compatibility from Coq 8.8 to 8.15 Version 1.5.0 ------------- - added support for Gappa 1.4 - ensured compatibility from Coq 8.8 to 8.14 - proved `fixed_error_up`, `_zr`, and `_na`, and `fixed_round_na` - proved `abs_a` Version 1.4.6 ------------- - switched to ocamlfind Version 1.4.5 ------------- - ensured compatibility from Coq 8.8 to 8.13 Version 1.4.4 ------------- - ensured compatibility from Coq 8.8 to 8.12 Version 1.4.3 ------------- - ensured compatibility from Coq 8.8 to 8.11 - fixed normalization issues with floating-point literals - removed dependency on camlp5 Version 1.4.2 ------------- - ensured compatibility from Coq 8.8 to 8.10 Version 1.4.1 ------------- - ensured compatibility from Coq 8.7 to 8.9 Version 1.4.0 ------------- - moved to Flocq 3.0 (incompatible with Coq < 8.7) Version 1.3.4 ------------- - fixed some integer variables being recognized as constant with Coq 8.7 - ensured compatibility from Coq 8.4 to 8.8 Version 1.3.3 ------------- - fixed compilation with Coq 8.7 Version 1.3.2 ------------- - fixed compilation with Coq 8.6 - proved `div_firs` Version 1.3.1 ------------- - ensured compatibility from Coq 8.4 to 8.6 - fixed `floatx_relative` statement Version 1.3.0 ------------- - added support for Gappa 1.3 (incompatible with prior versions) - improved support for half-bounded intervals during tree simplification - proved `neg_fix` and `abs_fix` - fixed `opp_mibs` statement - added support for Flocq's `FLX` formats - improved support for Coq 8.5 Version 1.2.1 ------------- - fixed compilation with Coq 8.5 and/or camlp4 Version 1.2.0 ------------- - moved to Flocq 2.5 Version 1.1.0 ------------- - moved to Flocq 2.4 - added support for Gappa 1.2 Version 1.0.0 ------------- - added support for Gappa 1.0 - fixed invalid identifiers being sent to Gappa - fixed broken generalization of terms - added support for negation, disjunction, and implication - allowed half-bounded intervals - proved tree simplification Version 0.21.1 -------------- - fixed build for the tarball and the tactic Version 0.21.0 ------------- - added support for Gappa 0.18 - added handling of formats to the tactic Version 0.20.0 -------------- - moved to Coq 8.4 Version 0.19.0 -------------- - switched build system to `remake` - added support for Gappa 0.17 - proved `opp_fibq`, `square`, `bnd_of_bnd_rel`, `bnd_of_rel_bnd` Version 0.18.0 -------------- - improved error messages for the tactic - added handling of `bpow` function to the tactic - added support for Gappa 0.16 - proved `eql_of_cst`, `fixed_fix_of_fix`, `float_relative_inv_n?`, `float_absolute_inv_n?`, `add_rr`, `sub_rr`, `bnd_div_of_rel_bnd_div` - removed the file containing proxy theorems Version 0.17.0 -------------- - moved to Flocq 2.0 Version 0.16.0 -------------- - added support for Gappa 0.15 - proved `fix_float_of_fix`, `fixed_error_ne`, `neg_a` - removed conversion of equality to null enclosure from the tactic Version 0.15.0 -------------- - moved to Coq 8.3 Version 0.14.1 -------------- - fixed an incompatibility with Flocq 1.2 Version 0.14 ------------ - added dependency on the Flocq library - removed support for the legacy `gappa` tactic Version 0.13 ------------ - added support for `REL` properties as `|r-e| <= b*|e|` in the gappa tactic Version 0.12 ------------ - imported the OCaml code of the `gappa` tactic in the library (support requires Coq 8.2, OCaml 3.11, and Gappa 0.12) - fixed incompatibility between the tactic and glob dumping - improved tactic with respect to redundant or contradictory hypotheses Version 0.11 ------------ - added support for Gappa 0.11 - improved build system Version 0.10 ------------ - fixed an incompatibility with Coq 8.2 Version 0.9 ----------- - prevented `gappa_prepare` from computing on non-reducible bounds - improved `gappa_prepare` to deal with equality goal Version 0.8 ----------- - added tactic support for calling Gappa from Coq - proved `*_subset`, `nzr_of_nzr_rel*`, `div_xals`, `div_fi*`, `addf_*`, `add_fi?q`, `sub_fi?q`, `rel_of_equal` - moved `abs_*`, `*_of_singleton_bnd` theorems to `ABS` predicate - moved `mul_fi?q`, `div_filq` to `REL` predicate Version 0.7 ----------- - changed coercions to produce user-friendly constants Version 0.6 ----------- - proved `rewrite_*` for constraints on user rewriting rules - proved `subset_*` for half-bounded goals - proved `intersect_rr`, `absurd_intersect_rr`, and `div_rr` for relative errors - proved `addf_*` rewriting helpers for relative error of addition - moved `compose` to relative errors - adapted to Coq 8.1pl1 Version 0.5 ----------- - improved `sqrt` - proved `rel_of_fix_float_ne`, `nzr_of_abs`, `nzr_of_bnd`, `bnd_of_nzr_rel`, `rel_of_nzr_bnd`, `error_of_rel`, `mul_rr` - adapted to Coq 8.1 Version 0.4 ----------- - fixed `mul_mibs` - proved `float_absolute_ne`, `float_absolute_ne_wide`, `float_relative_ne` - adapted to Coq 8.1gamma Version 0.3 ----------- - proved `flt_of_float`, `float_of_fix_flt`, `float_enforce`, `flt_of_singleton_bnd`, `fix_of_flt_bnd`, `flt_of_fix_bnd` Version 0.2 ----------- - added error propagation through opposite, division, and square root - added support for Gappa 0.7.1 - added rounding formalism for `fixed` and `float` - specialized formalism for `fixed` - used a precious variable for `COQC` Version 0.1 ----------- - added support for Gappa 0.7.0 coq-gappalib-coq-1.10.0-df59b68361b1efbd697b17c40f7fae4a35991c44/README.md000066400000000000000000000014131517666064600237450ustar00rootroot00000000000000This support library provides vernacular files so that the certificates Gappa generates can be imported by the Coq proof assistant. It also provides a `gappa` tactic that calls Gappa on the current Coq goal. Gappa (Génération Automatique de Preuves de Propriétés Arithmétiques -- automatic proof generation of arithmetic properties) is a tool intended to help verifying and formally proving properties on numerical programs dealing with floating-point or fixed-point arithmetic. The online documentation is available at: https://gappa.gitlabpages.inria.fr/gappa/index.html Gappa support library for the Coq proof assistant is free software; you can redistribute it and/or modify it under the terms of GNU Lesser General Public License (see the [COPYING](COPYING) file). coq-gappalib-coq-1.10.0-df59b68361b1efbd697b17c40f7fae4a35991c44/Remakefile.in000066400000000000000000000063551517666064600250740ustar00rootroot00000000000000FILES = \ Gappa_common.v \ Gappa_decimal.v \ Gappa_definitions.v \ Gappa_dyadic.v \ Gappa_fixed.v \ Gappa_float.v \ Gappa_library.v \ Gappa_obfuscate.v \ Gappa_pred_abs.v \ Gappa_pred_bnd.v \ Gappa_pred_fixflt.v \ Gappa_pred_lin.v \ Gappa_pred_nzr.v \ Gappa_pred_rel.v \ Gappa_real.v \ Gappa_rewriting.v \ Gappa_round_aux.v \ Gappa_round_def.v \ Gappa_round.v \ Gappa_tactic.v \ Gappa_tree.v \ Gappa_user.v OBJS = $(addprefix src/,$(addsuffix o,$(FILES))) .PHONY: all check clean dist install all: $(OBJS) clean: src/clean testsuite/clean check: testsuite/check Remakefile: Remakefile.in config.status ./config.status Remakefile configure config.status: configure.in autoconf ./config.status --recheck tools/vdep.ml: tools/vdep.mll @OCAMLLEX@ -o $@ $< tools/vdep.exe: tools/vdep.ml @OCAMLFIND@ ocamlc -o $@ $< %.vo: %.v | tools/vdep.exe tools/vdep.exe -R src Gappa $< | @REMAKE@ -r $@ @COQC@ @COQEXTRAFLAGS@ -q -R src Gappa -I src $< COQPKGS = clib engine kernel interp lib library parsing pretyping printing proofs tactics toplevel vernac plugins.ltac PACKAGES = $(addprefix -package coq-core., $(COQPKGS)) -package zarith src/gappatac.ml: src/gappatac.c Remakefile @CPP@ -DCOQVERSION=@COQVERSION@ $< -o $@ src/gappatac.cmo: src/gappatac.ml @OCAMLFIND@ ocamlc -rectypes -thread $(PACKAGES) -c $< -o $@ src/gappatac.cma: src/gappatac.cmo @OCAMLFIND@ ocamlc -a $< -o $@ src/gappatac.cmxs: src/gappatac.ml @OCAMLFIND@ ocamlopt -rectypes -thread $(PACKAGES) -shared $< -o $@ MLTARGETS = $(addprefix src/, @TACTIC_TARGETS@) src/Gappa_tactic.vo: src/Gappa_tactic.v $(MLTARGETS) | tools/vdep.exe tools/vdep.exe -R src Gappa $< | @REMAKE@ -r $@ @COQC@ @COQEXTRAFLAGS@ @TACTIC_PARAM@ -q -R src Gappa -I src $< src/clean: rm -f $(OBJS) cd src rm -f gappatac.ml gappatac.cmi gappatac.cmo gappatac.cmx gappatac.cmxs gappatac.o *.glob *.vos *.vok rm -rf .coq-native testsuite/check: src/Gappa_tactic.vo set +e cd testsuite logfile="failures-`date '+%Y-%m-%d'`.log" cat /dev/null > log.tmp cat /dev/null > "$logfile" for f in *.v; do cp "$f" check_tmp.v @COQC@ -R ../src Gappa -I ../src 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 check_tmp.v check_tmp.vo check_tmp.glob output.tmp 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 install: dir="${DESTDIR}@COQUSERCONTRIB@/Gappa" mkdir -p $dir cp $(OBJS) $dir ( cd src && find . -type d -name ".coq-native" -exec cp -RT "{}" "$dir/{}" \; ) dir="${DESTDIR}@COQGAPPALIB@/" mkdir -p $dir cp $(MLTARGETS) $dir cat src/META.coq-gappa | 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 coq-gappalib-coq-1.10.0-df59b68361b1efbd697b17c40f7fae4a35991c44/_CoqProject000066400000000000000000000000241517666064600246160ustar00rootroot00000000000000-R src Gappa -I src coq-gappalib-coq-1.10.0-df59b68361b1efbd697b17c40f7fae4a35991c44/configure.in000066400000000000000000000113651517666064600250060ustar00rootroot00000000000000AC_INIT([Coq support library for Gappa], [1.10.0], [Guillaume Melquiond ], [gappalib-coq]) m4_divert_push(99) if test "$ac_init_help" = "long"; then ac_init_help=short fi m4_divert_pop(99) AC_DEFUN([AX_VERSION_GE], [AS_VERSION_COMPARE([$1],[$2],[$4],[$3],[$3])]) 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_SUBST(COQVERSION) AC_ARG_VAR(COQC, [Coq compiler command [coqc]]) AC_MSG_CHECKING([for coqc >= 8.16]) if test ! "$COQC"; then COQC=`which ${COQBIN}coqc`; fi COQVERSION=[`$COQC -v | sed -n -e 's/^.*version \([0-9][0-9.]*\).*$/\1/p' | awk -F. '{ printf("%d%02d%02d\n", $1,$2,$3); }'`] AX_VERSION_GE([$COQVERSION], [81600], [ AC_MSG_RESULT([$COQC]) ], [ AC_MSG_RESULT([no]) AC_MSG_ERROR([ *** Unable to find Coq (https://coq.inria.fr/)]) ]) 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_ARG_VAR(OCAMLLEX, [OCaml lexer generator [ocamllex]]) AC_MSG_CHECKING([for ocamllex]) if test ! "$OCAMLLEX"; then OCAMLLEX=`which ocamllex`; fi AC_MSG_RESULT([$OCAMLLEX]) AC_MSG_CHECKING([for Flocq >= 4.1]) AS_IF( [ echo "From Flocq Require Import Version." \ "From Coq Require Import BinNat." \ "Goal (40100 <= Flocq_version)%N. easy. Qed." > conftest.v $COQC conftest.v > conftest.err ], [ AC_MSG_RESULT([yes]) ], [ AC_MSG_RESULT([no]) AC_MSG_ERROR([ *** Unable to find library Flocq >= 4.1 (https://flocq.gitlabpages.inria.fr/)])]) rm -f conftest.v conftest.vo conftest.err AC_SUBST(COQLIB) COQLIB=`$COQC -where | tr -d '\r' | tr '\\\\' '/'` AC_ARG_VAR(COQUSERCONTRIB, [installation directory [`$COQC -where`/user-contrib]]) if test -z "$COQUSERCONTRIB"; then COQUSERCONTRIB="$COQLIB/user-contrib" fi AC_SUBST(COQGAPPALIB) COQGAPPALIB=`$OCAMLFIND printconf destdir`/coq-gappa AC_ARG_ENABLE([tactic], AS_HELP_STRING([--disable-tactic], [do not compile a "gappa" 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 "gappa" 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 "gappa" 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 coq-core.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 coq-core.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 rm -f conftest.ml conftest.cm* 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 tools/remake.cpp -lws2_32 if test $? != 0; then AC_MSG_FAILURE([failed]); fi REMAKE=./remake.exe ;; *) $CXX -Wall -O2 -o remake tools/remake.cpp if test $? != 0; then AC_MSG_FAILURE([failed]); fi REMAKE=./remake ;; esac 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 gappatac.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 gappatac.cmo" if test "$native_tactic" = no; then TACTIC_PARAM="-byte" fi fi if test -z "$tactic_mode"; then tactic_mode=" none"; fi echo echo "=== Summary ===" echo "Vernacular directory $COQUSERCONTRIB" echo "Plugin directory $COQGAPPALIB" echo "Plugin compilation $tactic_mode" echo AC_CONFIG_FILES(Remakefile) AC_OUTPUT coq-gappalib-coq-1.10.0-df59b68361b1efbd697b17c40f7fae4a35991c44/src/000077500000000000000000000000001517666064600232565ustar00rootroot00000000000000coq-gappalib-coq-1.10.0-df59b68361b1efbd697b17c40f7fae4a35991c44/src/Gappa_common.v000066400000000000000000000006301517666064600260440ustar00rootroot00000000000000From Coq Require Export Bool ZArith Reals. From Flocq Require Export Zaux Raux. Require Export Gappa_real Gappa_definitions Gappa_dyadic. Lemma Zlt_bool_correct_t : forall m n : Z, Zlt_bool m n = true -> (m < n)%Z. Proof. intros m n H. generalize (Zlt_cases m n). rewrite H. trivial. Qed. Lemma Rdiv_0_r : forall x, (x / 0)%R = 0%R. Proof. intros x. unfold Rdiv. rewrite Rinv_0. apply Rmult_0_r. Qed. coq-gappalib-coq-1.10.0-df59b68361b1efbd697b17c40f7fae4a35991c44/src/Gappa_decimal.v000066400000000000000000000053171517666064600261610ustar00rootroot00000000000000From Flocq Require Import Defs. Require Import Gappa_common. Definition Dcompare (x : float2) (y : float10) := let m := Fnum10 y in let e := Fexp10 y in match e with | Zpos p => Fcomp2 x (Float2 (m * Zpower_pos 5 p) e) | Zneg p => Fcomp2 (Float2 (Fnum x * Zpower_pos 5 p) (Fexp x)) (Float2 m e) | Z0 => Fcomp2 x (Float2 m 0) end. Lemma pow_exp : forall x y : R, forall e : nat, (x^e * y^e = (x*y)^e)%R. Proof. intros x y e. induction e. apply Rmult_1_l. repeat rewrite <- tech_pow_Rmult. rewrite <- IHe. ring. Qed. Lemma Zpower_pos_pos: forall x e : positive, (0 < Zpower_pos (Zpos x) e)%Z. Proof. intros x e. rewrite Zpower_pos_nat. induction (nat_of_P e). exact (refl_equal Lt). change (Zpower_nat (Zpos x) (S n)) with ((Zpos x) * Zpower_nat (Zpos x) n)%Z. apply Zmult_lt_0_compat with (2 := IHn). exact (refl_equal Lt). Qed. Lemma Dcompare_correct : forall x : float2, forall y : float10, Dcompare x y = Rcompare x y. Proof. assert (forall e, Zpower_pos 5 e * Zpower_pos 2 e = Zpower_pos 10 e)%Z. intros e. rewrite 3!Zpower_pos_nat. induction (nat_of_P e). apply refl_equal. change ((5 * Zpower_nat 5 n) * (2 * Zpower_nat 2 n) = 10 * Zpower_nat 10 n)%Z. rewrite <- IHn. ring. (* *) intros x (ym, ye). unfold Dcompare, float10R. simpl. destruct ye as [|ye|ye] ; rewrite Fcomp2_correct. apply refl_equal. (* . *) apply f_equal. unfold float2R, F2R. simpl. rewrite mult_IZR, Rmult_assoc, <- mult_IZR. now apply (f_equal (fun v => IZR ym * IZR v)%R). (* . *) unfold float2R at 1, F2R at 1. simpl. replace (IZR (Fnum x * Zpower_pos 5 ye) * bpow radix2 (Fexp x))%R with (x * IZR (Zpower_pos 5 ye))%R. rewrite <- (Rcompare_mult_r (IZR (Zpower_pos 2 ye))). rewrite Rmult_assoc, <- mult_IZR, H. rewrite <- (Rcompare_mult_r (IZR (Zpower_pos 10 ye)) x). apply f_equal. unfold float2R, F2R. simpl. rewrite 2!Rmult_assoc, 2!Rinv_l. apply refl_equal. apply Rgt_not_eq. exact (bpow_gt_0 radix10 (Zpos ye)). apply Rgt_not_eq. exact (bpow_gt_0 radix2 (Zpos ye)). exact (bpow_gt_0 radix10 (Zpos ye)). exact (bpow_gt_0 radix2 (Zpos ye)). unfold float2R, F2R. simpl. rewrite mult_IZR. ring. Qed. Definition Dle_fd (x : float2) (y : float10) := match (Dcompare x y) with | Gt => false | _ => true end. Lemma Dle_fd_correct : forall x : float2, forall y : float10, Dle_fd x y = true -> (x <= y)%R. Proof. intros x y H. apply Rcompare_not_Gt_inv. revert H. unfold Dle_fd. rewrite Dcompare_correct. now case Rcompare. Qed. Definition Dle_df (x : float10) (y : float2) := match (Dcompare y x) with | Lt => false | _ => true end. Lemma Dle_df_correct : forall x : float10, forall y : float2, Dle_df x y = true -> (x <= y)%R. Proof. intros x y H. apply Rcompare_not_Lt_inv. revert H. unfold Dle_df. rewrite Dcompare_correct. now case Rcompare. Qed. coq-gappalib-coq-1.10.0-df59b68361b1efbd697b17c40f7fae4a35991c44/src/Gappa_definitions.v000066400000000000000000000021471517666064600270740ustar00rootroot00000000000000From Coq Require Import Reals ZArith. From Flocq Require Import Zaux Raux Defs. Notation radix2 := Zaux.radix2. Record float2 : Set := Float2 { Fnum : Z ; Fexp : Z }. Coercion float2R (x : float2) := F2R (Float radix2 (Fnum x) (Fexp x)). Definition radix10 := Build_radix 10 (refl_equal true). Record float10 : Set := Float10 { Fnum10 : Z ; Fexp10 : Z }. Coercion float10R (x : float10) := F2R (Float radix10 (Fnum10 x) (Fexp10 x)). Record FF: Set := makepairF { lower : float2 ; upper : float2 }. Definition BND (x : R) (xi : FF) := (lower xi <= x <= upper xi)%R. Definition ABS (x : R) (xi : FF) := (0 <= lower xi)%R /\ (lower xi <= Rabs x <= upper xi)%R. Definition REL (x1 x2 : R) (xi : FF) := exists x : R, (lower xi <= x <= upper xi)%R /\ (x1 = x2 * (1 + x))%R. Definition LIN (x1 x2 : R) (xi : FF) := exists x : R, (lower xi <= x <= upper xi)%R /\ (x1 = x2 * x)%R. Definition FIX (x : R) (n : Z) := exists f : float2, float2R f = x /\ (n <= Fexp f)%Z. Definition FLT (x : R) (n : positive) := exists f : float2, float2R f = x /\ (Z.abs (Fnum f) < Zpower_pos 2 n)%Z. Definition NZR (x : R) := (x <> 0)%R. coq-gappalib-coq-1.10.0-df59b68361b1efbd697b17c40f7fae4a35991c44/src/Gappa_dyadic.v000066400000000000000000000150551517666064600260200ustar00rootroot00000000000000From Coq Require Import ZArith Reals Lia. From Flocq Require Import Raux Defs Float_prop Operations. Require Import Gappa_definitions. Lemma float2_zero : forall e : Z, Float2 0 e = 0%R :>R. Proof. intro e. apply F2R_0. Qed. Definition Fopp2 (x : float2) := Float2 (- Fnum x) (Fexp x). Lemma Fopp2_correct : forall x : float2, Fopp2 x = (- x)%R :>R. Proof. intros x. unfold float2R, Fopp2. simpl. apply F2R_Zopp. Qed. Definition Fabs2 (x : float2) := Float2 (Z.abs (Fnum x)) (Fexp x). Lemma Fabs2_correct : forall x : float2, Fabs2 x = Rabs x :>R. Proof. intros x. unfold float2R, Fabs2. simpl. apply F2R_Zabs. Qed. Definition Fmult2 (x y : float2) := Float2 (Fnum x * Fnum y) (Fexp x + Fexp y). Definition Fmult2_correct : forall x y : float2, Fmult2 x y = (x * y)%R :>R. Proof. intros (mx, ex) (my, ey). exact (F2R_mult (Float radix2 mx ex) (Float radix2 my ey)). Qed. Definition shl (m : Z) (d : positive) := match m with | Z0 => Z0 | Zpos p => Zpos (shift_pos d p) | Zneg p => Zneg (shift_pos d p) end. Lemma float2_shl_correct : forall m e : Z, forall d : positive, Float2 (shl m d) (e - Zpos d) = Float2 m e :>R. Proof. intros m e d. replace (shl m d) with (m * Zpower_pos 2 d)%Z. unfold float2R. rewrite (F2R_change_exp _ (e - Zpos d) _ e). simpl. now replace (e - (e - Zpos d))%Z with (Zpos d) by ring. generalize (Zgt_pos_0 d). lia. rewrite Zmult_comm. destruct m as [|m|m] ; simpl. apply Zmult_0_r. now rewrite shift_pos_correct. change (Zneg (shift_pos d m)) with (- Zpos (shift_pos d m))%Z. rewrite shift_pos_correct. now rewrite Zopp_mult_distr_r. Qed. Definition Fshift2 (x y : float2) := match (Fexp x - Fexp y)%Z with | Zpos p => (shl (Fnum x) p, Fnum y, Fexp y) | Zneg p => (Fnum x, shl (Fnum y) p, Fexp x) | Z0 => (Fnum x, Fnum y, Fexp x) end. Lemma Fshift2_correct : forall x y : float2, match Fshift2 x y with | (mx, my, e) => Float2 mx e = x :>R /\ Float2 my e = y :>R end. Proof. intros (mx, ex) (my, ey). unfold Fshift2. simpl. assert (ex = ex - ey + ey)%Z by ring. pattern ex at - 1 ; rewrite H. destruct (ex - ey)%Z as [|d|d] ; repeat split. rewrite <- (float2_shl_correct mx _ d). now ring_simplify (Zpos d + ey - Zpos d)%Z. rewrite Zplus_comm. apply float2_shl_correct. Qed. Definition Fplus2 (x y : float2) := match Fshift2 x y with | (mx, my, e) => Float2 (mx + my) e end. Lemma Fplus2_correct : forall x y : float2, Fplus2 x y = (x + y)%R :>R. Proof. intros x y. unfold Fplus2. generalize (Fshift2_correct x y). destruct (Fshift2 x y) as ((mx, my), e). intros (Hx, Hy). rewrite <- Hx, <- Hy. unfold float2R, F2R. simpl. rewrite plus_IZR. apply Rmult_plus_distr_r. Qed. Definition Fminus2 (x y : float2) := match Fshift2 x y with | (mx, my, e) => Float2 (mx - my) e end. Lemma Fminus2_correct : forall x y : float2, Fminus2 x y = (x - y)%R :>R. Proof. intros x y. unfold Fminus2. generalize (Fshift2_correct x y). destruct (Fshift2 x y) as ((mx, my), e). intros (Hx, Hy). rewrite <- Hx, <- Hy. unfold float2R, F2R. simpl. rewrite minus_IZR. apply Rmult_minus_distr_r. Qed. Definition Fcomp2 (x y : float2) := match Fshift2 x y with | (mx, my, _) => (mx ?= my)%Z end. Lemma Fcomp2_correct : forall x y : float2, Fcomp2 x y = Rcompare x y. Proof. intros x y. unfold Fcomp2. generalize (Fshift2_correct x y). destruct (Fshift2 x y) as ((mx, my), e). intros (Hx, Hy). rewrite <- Hx, <- Hy. unfold float2R, F2R. simpl. rewrite Rcompare_mult_r. now rewrite Rcompare_IZR. apply bpow_gt_0. Qed. Definition Feq2 (x y : float2) := match Fcomp2 x y with | Eq => true | _ => false end. Lemma Feq2_correct : forall x y : float2, Feq2 x y = true -> x = y :>R. Proof. intros x y Hb. apply Rcompare_Eq_inv. rewrite <- Fcomp2_correct. revert Hb. unfold Feq2. now case Fcomp2. Qed. Definition Flt2 (x y : float2) := match Fcomp2 x y with | Lt => true | _ => false end. Lemma Flt2_correct : forall x y : float2, Flt2 x y = true -> (x < y)%R. Proof. intros x y Hb. apply Rcompare_Lt_inv. rewrite <- Fcomp2_correct. revert Hb. unfold Flt2. now case Fcomp2. Qed. Definition Fle2 (x y : float2) := match Fcomp2 x y with | Gt => false | _ => true end. Lemma Fle2_correct : forall x y : float2, Fle2 x y = true -> (x <= y)%R. Proof. intros x y Hb. apply Rcompare_not_Gt_inv. rewrite <- Fcomp2_correct. intros H. unfold Fle2 in Hb. now rewrite H in Hb. Qed. Inductive Fle2_prop (x y : float2) : bool -> Prop := | Fle2_true : (x <= y)%R -> Fle2_prop x y true | Fle2_false : (y < x)%R -> Fle2_prop x y false. Lemma Fle2_spec : forall x y, Fle2_prop x y (Fle2 x y). Proof. intros x y. case_eq (Fle2 x y) ; intros H. apply Fle2_true. apply Fle2_correct. exact H. generalize H. clear H. unfold Fle2. case_eq (Fcomp2 x y) ; try (intros ; discriminate). intros H _. apply Fle2_false. apply Rcompare_Gt_inv. now rewrite <- Fcomp2_correct. Qed. Definition Fis0 (x : float2) := match (Fnum x) with Z0 => true | _ => false end. Lemma Fis0_correct : forall x : float2, Fis0 x = true -> x = 0%R :>R. intros x. unfold Fis0. induction x. induction Fnum ; intro H0 ; try discriminate. apply float2_zero. Qed. Definition Fpos (x : float2) := match (Fnum x) with Zpos _ => true | _ => false end. Lemma Fpos_correct : forall x : float2, Fpos x = true -> (0 < x)%R. Proof. intros (m, e) H. unfold float2R. apply F2R_gt_0. simpl. revert H. unfold Fpos. simpl. now case m. Qed. Definition Fneg (x : float2) := match (Fnum x) with Zneg _ => true | _ => false end. Lemma Fneg_correct : forall x : float2, Fneg x = true -> (x < 0)%R. Proof. intros (m, e) H. unfold float2R. apply F2R_lt_0. simpl. revert H. unfold Fpos. simpl. now case m. Qed. Definition Fpos0 (x : float2) := match (Fnum x) with Zneg _ => false | _ => true end. Lemma Fpos0_correct : forall x : float2, Fpos0 x = true -> (0 <= x)%R. Proof. intros (m, e) H. unfold float2R. apply F2R_ge_0. simpl. revert H. unfold Fpos. simpl. now case m. Qed. Definition Fneg0 (x : float2) := match (Fnum x) with Zpos _ => false | _ => true end. Lemma Fneg0_correct : forall x : float2, Fneg0 x = true -> (x <= 0)%R. Proof. intros (m, e) H. unfold float2R. apply F2R_le_0. simpl. revert H. unfold Fpos. simpl. now case m. Qed. Definition Flt2_m1 f := Flt2 (Float2 (-1) 0) f. Lemma Flt2_m1_correct : forall f, Flt2_m1 f = true -> (-1 < f)%R. Proof. intros f Hb. generalize (Flt2_correct _ _ Hb). unfold float2R, F2R. simpl. now rewrite Rmult_1_r. Qed. Definition Fle2_m1 f := Fle2 (Float2 (-1) 0) f. Lemma Fle2_m1_correct : forall f, Fle2_m1 f = true -> (-1 <= f)%R. Proof. intros f Hb. generalize (Fle2_correct _ _ Hb). unfold float2R, F2R. simpl. now rewrite Rmult_1_r. Qed. coq-gappalib-coq-1.10.0-df59b68361b1efbd697b17c40f7fae4a35991c44/src/Gappa_fixed.v000066400000000000000000000161541517666064600256630ustar00rootroot00000000000000From Coq Require Import Bool ZArith Reals. From Flocq Require Import Core. Require Import Gappa_definitions. Require Import Gappa_dyadic. Require Import Gappa_pred_bnd. Require Import Gappa_round_def. Require Import Gappa_round_aux. Require Import Gappa_round. Global Notation rounding_fixed rdir e := (Generic_fmt.round radix2 (FIX_exp e) rdir) (only parsing). Theorem fix_of_fixed : forall rdir, forall x : R, forall k1 k2 : Z, Zle_bool k2 k1 = true -> FIX (rounding_fixed rdir k1 x) k2. Proof. intros rdir x k1 k2 H. generalize (Zle_bool_imp_le _ _ H). clear H. intro H. unfold FIX. eexists (Float2 _ _) ; repeat split. exact H. Qed. Theorem fixed_of_fix : forall rdir {Hrnd : Valid_rnd rdir} x e1 e2, FIX x e1 -> Zle_bool e2 e1 = true -> rounding_fixed rdir e2 x = x. Proof. intros rdir Hrnd x e1 e2 ((m,e),(Hx1,Hx2)) H1. generalize (Zle_bool_imp_le _ _ H1). clear H1. intro H1. apply round_generic with (1 := Hrnd). rewrite <- Hx1. apply generic_format_F2R. intros _. now apply Z.le_trans with e1. Qed. Theorem fix_fixed_of_fix : forall rdir {Hrnd : Valid_rnd rdir} d xn zn x, FIX x xn -> Zle_bool zn xn = true -> FIX (rounding_fixed rdir d x) zn. Proof with auto with typeclass_instances. intros rdir Hrnd d xn zn x H Hb. generalize (Zle_bool_imp_le _ _ Hb). clear Hb. intro H1. apply FIX_iff_generic. apply generic_round_generic... apply FIX_iff_generic. now apply fix_le with xn. Qed. Local Instance Zpos_gt_0 : forall k, Prec_gt_0 (Zpos k). Proof. easy. Qed. Theorem flt_fixed_of_flt : forall rdir {Hrnd : Valid_rnd rdir} d xn zn x, FLT x xn -> Zle_bool (Zpos xn) (Zpos zn) = true -> FLT (rounding_fixed rdir d x) zn. Proof with auto with typeclass_instances. intros rdir Hrnd d xn zn x H Hb. generalize (Zle_bool_imp_le _ _ Hb). clear Hb. intro H1. apply FLT_iff_generic. apply generic_round_generic... apply FLT_iff_generic. now apply flt_le with xn. Qed. Definition bnd_of_bnd_fix_helper (xi zi : FF) (e : Z) := Fle2 (lower zi) (round roundUP (FIX_exp e) (lower xi)) && Fle2 (round roundDN (FIX_exp e) (upper xi)) (upper zi). Theorem bnd_of_bnd_fix : forall x xn xi zi, BND x xi -> FIX x xn -> bnd_of_bnd_fix_helper xi zi xn = true -> BND x zi. Proof with auto with typeclass_instances. intros x xn xi zi Hxb ((m,e),(Hx1,Hx2)) Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). generalize (Fle2_correct _ _ H1). rewrite (rndG_conversion roundUP_cs). clear H1. intro H1. generalize (Fle2_correct _ _ H2). rewrite (rndG_conversion roundDN_cs). clear H2. intro H2. rewrite <- Hx1. rewrite <- Hx1 in Hxb. split. apply Rle_trans with (1 := H1). unfold float2R at 2. simpl. rewrite <- (round_generic radix2 (FIX_exp xn) Zceil (F2R (Float radix2 m e))). apply round_le... apply Hxb. now apply generic_format_F2R. apply Rle_trans with (2 := H2). unfold float2R at 1. simpl. rewrite <- (round_generic radix2 (FIX_exp xn) Zfloor (F2R (Float radix2 m e))). apply round_le... apply Hxb. now apply generic_format_F2R. Qed. Local Existing Instance valid_rnd_Gf. Definition round_helper (rnd : float2 -> float2) (xi zi : FF) := Fle2 (lower zi) (rnd (lower xi)) && Fle2 (rnd (upper xi)) (upper zi). Theorem fixed_round : forall rdir e x xi zi, BND x xi -> round_helper (round (rndG_g rdir) (FIX_exp e)) xi zi = true -> BND (rounding_fixed (rndG_f rdir) e x) zi. Proof with auto with typeclass_instances. intros rdir e x xi zi Hx Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). generalize (Fle2_correct _ _ H1). rewrite rndG_conversion. clear H1. intro H1. generalize (Fle2_correct _ _ H2). rewrite rndG_conversion. clear H2. intro H2. split. apply Rle_trans with (1 := H1). apply round_le... apply Hx. apply Rle_trans with (2 := H2). apply round_le... apply Hx. Qed. Definition fixed_round_dn := fixed_round roundDN_cs. Definition fixed_round_up := fixed_round roundUP_cs. Definition fixed_round_zr := fixed_round roundZR_cs. Definition fixed_round_ne := fixed_round roundNE_cs. Definition fixed_round_na := fixed_round roundNA_cs. Definition fixed_error_dn_helper (e : Z) (zi : FF) := Fle2 (lower zi) (Float2 (-1) e) && Fpos0 (upper zi). Theorem fixed_error_dn : forall e x zi, fixed_error_dn_helper e zi = true -> BND (rounding_fixed rndDN e x - x) zi. Proof with auto with typeclass_instances. intros e x zi Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). generalize (Fle2_correct _ _ H1). clear H1. intro H1. generalize (Fpos0_correct _ H2). clear H2. intro H2. split. (* *) apply Rle_trans with (1 := H1). destruct (Rabs_le_inv _ _ (error_le_ulp radix2 (FIX_exp e) Zfloor x)) as (H, _). rewrite ulp_FIX in H. unfold float2R. rewrite (F2R_Zopp _ 1%Z). now rewrite F2R_bpow. (* *) apply Rle_trans with (2 := H2). apply Rle_minus. apply round_DN_pt... Qed. Definition fixed_error_up_helper (e : Z) (zi : FF) := Fneg0 (lower zi) && Fle2 (Float2 1 e) (upper zi). Theorem fixed_error_up : forall e x zi, fixed_error_up_helper e zi = true -> BND (rounding_fixed rndUP e x - x) zi. Proof with auto with typeclass_instances. intros e x zi Hb. generalize (andb_prop _ _ Hb). clear Hb. intros [H1 H2]. generalize (Fneg0_correct _ H1). clear H1. intro H1. generalize (Fle2_correct _ _ H2). clear H2. intro H2. split. - apply Rle_trans with (1 := H1). apply Rle_0_minus. apply round_UP_pt... - apply Rle_trans with (2 := H2). destruct (Rabs_le_inv _ _ (error_le_ulp radix2 (FIX_exp e) Zceil x)) as [_ H]. rewrite ulp_FIX in H. unfold float2R. now rewrite F2R_bpow. Qed. Definition fixed_error_zr_helper (e : Z) (zi : FF) := Fle2 (lower zi) (Float2 (-1) e) && Fle2 (Float2 1 e) (upper zi). Theorem fixed_error_zr : forall e x zi, fixed_error_zr_helper e zi = true -> BND (rounding_fixed rndZR e x - x) zi. Proof with auto with typeclass_instances. intros e x zi Hb. generalize (andb_prop _ _ Hb). clear Hb. intros [H1 H2]. generalize (Fle2_correct _ _ H1). clear H1. intro H1. generalize (Fle2_correct _ _ H2). clear H2. intro H2. assert (H := Rabs_le_inv _ _ (error_le_ulp radix2 (FIX_exp e) Ztrunc x)). rewrite ulp_FIX in H. destruct H as [H3 H4]. split. - apply Rle_trans with (1 := H1). unfold float2R. rewrite (F2R_Zopp _ 1%Z). now rewrite F2R_bpow. - apply Rle_trans with (2 := H2). unfold float2R. now rewrite F2R_bpow. Qed. Definition fixed_error_n_helper (e : Z) (zi : FF) := Fle2 (lower zi) (Float2 (-1) (e - 1)) && Fle2 (Float2 1 (e - 1)) (upper zi). Theorem fixed_error_n : forall c e x zi, fixed_error_n_helper e zi = true -> BND (rounding_fixed (Znearest c) e x - x) zi. Proof. intros c e x zi Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). generalize (Fle2_correct _ _ H1). clear H1. intro H1. generalize (Fle2_correct _ _ H2). clear H2. intro H2. assert (H := error_le_half_ulp radix2 (FIX_exp e) c x). replace (/2 * ulp radix2 (FIX_exp e) x)%R with (float2R (Float2 1 (e - 1))) in H. (* *) destruct (Rabs_le_inv _ _ H) as (H3,H4). split. apply Rle_trans with (1 := H1). unfold float2R. now rewrite (F2R_Zopp _ 1%Z). now apply Rle_trans with (2 := H2). (* *) rewrite ulp_FIX. unfold float2R, Zminus. rewrite F2R_bpow, Zplus_comm. apply bpow_plus. Qed. Definition fixed_error_ne := fixed_error_n (fun x => negb (Z.even x)). Definition fixed_error_na := fixed_error_n (fun x => Z.leb 0 x). coq-gappalib-coq-1.10.0-df59b68361b1efbd697b17c40f7fae4a35991c44/src/Gappa_float.v000066400000000000000000001775411517666064600257010ustar00rootroot00000000000000From Coq Require Import Bool ZArith Reals Lia Lra. From Flocq Require Import Core Digits Round Relative. Require Import Gappa_definitions. Require Import Gappa_dyadic. Require Import Gappa_pred_bnd. Require Import Gappa_round_def. Require Import Gappa_round_aux. Require Import Gappa_round. Global Notation rounding_float rdir p d := (Generic_fmt.round radix2 (FLT_exp d (Zpos p)) rdir) (only parsing). Global Notation rounding_floatx rdir p := (Generic_fmt.round radix2 (FLX_exp (Zpos p)) rdir) (only parsing). Definition Fmag (xi : FF) := let l := Fopp2 (lower xi) in let u := upper xi in if Fle2 l u then u else l. Lemma Fmag_correct : forall x xi, BND x xi -> (Rabs x <= float2R (Fmag xi))%R. Proof. intros x xi [Hx1 Hx2]. apply Rabs_le. unfold Fmag. case Fle2_spec ; intros H. - refine (conj _ Hx2). apply Rle_trans with (2 := Hx1). rewrite <- (Ropp_involutive (lower xi)). apply Ropp_le_contravar. now rewrite <- Fopp2_correct. - split. now rewrite Fopp2_correct, Ropp_involutive. now apply Rlt_le, Rle_lt_trans with (upper xi). Qed. Definition float_ulp (p : positive) (d m e : Z) := match m with | Zpos n => FLT_exp d (Zpos p) (e + Zpos (digits n))%Z | Zneg n => FLT_exp d (Zpos p) (e + Zpos (digits n))%Z | Z0 => d end. Lemma float_ulp_correct : forall p d m e, bpow radix2 (float_ulp p d m e) = ulp radix2 (FLT_exp d (Zpos p)) (F2R (Float radix2 m e)). Proof. intros p d m e. destruct (Z.eq_dec m 0) as [->|Zm]. { now rewrite F2R_0, ulp_FLT_0. } rewrite ulp_neq_0 by now apply F2R_neq_0. apply f_equal. unfold float_ulp, cexp. rewrite mag_F2R by easy. rewrite <- Zdigits_mag by easy. rewrite Zplus_comm. destruct m as [|m|m]. easy. now rewrite digits2_digits. now rewrite digits2_digits. Qed. Definition floatx_ulp (p : positive) (m e : Z) := match m with | Zpos n => FLX_exp (Zpos p) (e + Zpos (digits n))%Z | Zneg n => FLX_exp (Zpos p) (e + Zpos (digits n))%Z | Z0 => Z0 end. Lemma float_absolute_ne_sym : forall p d x, (Rabs (rounding_float rndNE p d x - x) = Rabs (rounding_float rndNE p d (Rabs x) - Rabs x))%R. Proof. intros p d x. destruct (Rle_or_lt 0 x) as [H|H]. rewrite (Rabs_right _ (Rle_ge _ _ H)). exact (refl_equal _). rewrite (Rabs_left _ H). rewrite round_NE_opp. unfold Rminus. rewrite <- Ropp_plus_distr. now rewrite Rabs_Ropp. Qed. Lemma float_absolute_zr_sym : forall p d x, Rabs (rounding_float rndZR p d x - x) = (Rabs x - rounding_float rndDN p d (Rabs x))%R. Proof. intros p d x. destruct (Rle_or_lt 0 x) as [H|H]. - rewrite (Rabs_pos_eq x H). rewrite round_ZR_DN by easy. assert (H': (Generic_fmt.round radix2 (FLT_exp d (Z.pos p)) Zfloor x <= x)%R). 2: rewrite Rabs_left1 ; lra. apply round_DN_pt. now apply FLT_exp_valid. - rewrite (Rabs_left x H). rewrite round_ZR_UP by now apply Rlt_le. rewrite round_DN_opp. assert (H': (x <= Generic_fmt.round radix2 (FLT_exp d (Z.pos p)) Zceil x)%R). 2: rewrite Rabs_pos_eq ; lra. apply round_UP_pt. now apply FLT_exp_valid. Qed. Lemma floatx_absolute_ne_sym : forall p x, (Rabs (rounding_floatx rndNE p x - x) = Rabs (rounding_floatx rndNE p (Rabs x) - Rabs x))%R. Proof. intros p x. destruct (Rle_or_lt 0 x) as [H|H]. rewrite (Rabs_right _ (Rle_ge _ _ H)). exact (refl_equal _). rewrite (Rabs_left _ H). rewrite round_NE_opp. unfold Rminus. rewrite <- Ropp_plus_distr. now rewrite Rabs_Ropp. Qed. Local Instance zpos_gt_0 : forall p, Prec_gt_0 (Zpos p). Proof. easy. Qed. Lemma float_absolute_n_whole : forall c p d k x, (Rabs x < bpow radix2 k)%R -> (Rabs (rounding_float (Znearest c) p d x - x) <= bpow radix2 (FLT_exp d (Zpos p) k - 1))%R. Proof with auto with typeclass_instances. intros c p d k x Hx. destruct (Req_dec x 0) as [Hx0|Hx0]. rewrite Hx0, round_0, Rminus_0_r, Rabs_R0... apply bpow_ge_0. apply Rle_trans with (/2 * ulp radix2 (FLT_exp d (Zpos p)) x)%R. apply error_le_half_ulp... rewrite ulp_neq_0 by easy. rewrite <- (bpow_plus radix2 (-1)). apply bpow_le. unfold Zminus. rewrite (Zplus_comm _ (-1)). apply Zplus_le_compat_l. unfold cexp. apply monotone_exp... now apply mag_le_bpow. Qed. Lemma float_absolute_whole : forall m, Valid_rnd m -> forall p d k x, (Rabs x < bpow radix2 k)%R -> (Rabs (rounding_float m p d x - x) <= bpow radix2 (FLT_exp d (Zpos p) k))%R. Proof with auto with typeclass_instances. intros m Hm p d k x Hx. destruct (Req_dec x 0) as [Hx0|Hx0]. rewrite Hx0, round_0, Rminus_0_r, Rabs_R0... apply bpow_ge_0. apply Rle_trans with (ulp radix2 (FLT_exp d (Zpos p)) x). apply error_le_ulp... rewrite ulp_neq_0 by easy. apply bpow_le. unfold cexp. apply monotone_exp... now apply mag_le_bpow. Qed. Lemma floatx_absolute_n_whole : forall c p k x, (Rabs x < bpow radix2 k)%R -> (Rabs (rounding_floatx (Znearest c) p x - x) <= bpow radix2 (FLX_exp (Zpos p) k - 1))%R. Proof with auto with typeclass_instances. intros c p k x Hx. destruct (Req_dec x 0) as [Hx0|Hx0]. rewrite Hx0, round_0, Rminus_0_r, Rabs_R0... apply bpow_ge_0. apply Rle_trans with (/2 * ulp radix2 (FLX_exp (Zpos p)) x)%R. apply error_le_half_ulp... rewrite ulp_neq_0; trivial. rewrite <- (bpow_plus radix2 (-1)). apply bpow_le. unfold Zminus. rewrite (Zplus_comm _ (-1)). apply Zplus_le_compat_l. unfold cexp. apply monotone_exp... now apply mag_le_bpow. Qed. Lemma float_absolute_inv_n_whole : forall c p d k x, (Rabs (rounding_float (Znearest c) p d x) < bpow radix2 k)%R -> (Rabs (rounding_float (Znearest c) p d x - x) <= bpow radix2 (FLT_exp d (Zpos p) k - 1))%R. Proof with auto with typeclass_instances. intros c p d k x Hx. destruct (Req_dec x 0) as [Hx0|Hx0]. rewrite Hx0, round_0, Rminus_0_r, Rabs_R0... apply bpow_ge_0. apply Rle_trans with (/2 * ulp radix2 (FLT_exp d (Zpos p)) x)%R. apply error_le_half_ulp... rewrite ulp_neq_0; trivial. rewrite <- (bpow_plus radix2 (-1)). apply bpow_le. unfold Zminus. rewrite (Zplus_comm _ (-1)). apply Zplus_le_compat_l. unfold cexp. destruct (Zle_or_lt (mag radix2 x) k) as [Hk1|Hk1]. apply monotone_exp... destruct (Zle_or_lt (mag radix2 x) d) as [Hk2|Hk2]. unfold FLT_exp. clear -Hk1 Hk2 ; zify ; lia. elim Rlt_not_le with (1 := Hx) ; clear Hx. apply Rle_trans with (bpow radix2 (Z.max k d)). apply bpow_le. apply Z.le_max_l. apply abs_round_ge_generic... apply generic_format_bpow. unfold FLT_exp. clear ; zify ; lia. destruct (mag radix2 x) as (ex,Ex) ; simpl in *. apply Rle_trans with (2 := proj1 (Ex Hx0)). apply bpow_le. clear -Hk1 Hk2 ; zify ; lia. Qed. Lemma floatx_absolute_inv_n_whole : forall c p k x, (Rabs (rounding_floatx (Znearest c) p x) < bpow radix2 k)%R -> (Rabs (rounding_floatx (Znearest c) p x - x) <= bpow radix2 (FLX_exp (Zpos p) k - 1))%R. Proof with auto with typeclass_instances. intros c p k x Hx. destruct (Req_dec x 0) as [Hx0|Hx0]. rewrite Hx0, round_0, Rminus_0_r, Rabs_R0... apply bpow_ge_0. apply Rle_trans with (/2 * ulp radix2 (FLX_exp (Zpos p)) x)%R. apply error_le_half_ulp... rewrite ulp_neq_0; trivial. rewrite <- (bpow_plus radix2 (-1)). apply bpow_le. unfold Zminus. rewrite (Zplus_comm _ (-1)). apply Zplus_le_compat_l. unfold cexp. apply monotone_exp... destruct (Zle_or_lt (mag radix2 x) k) as [Hk1|Hk1]. exact Hk1. elim Rlt_not_le with (1 := Hx) ; clear Hx. apply abs_round_ge_generic... apply generic_format_bpow. unfold FLX_exp. clear ; zify ; lia. destruct (mag radix2 x) as (ex,Ex) ; simpl in *. apply Rle_trans with (2 := proj1 (Ex Hx0)). apply bpow_le. clear -Hk1 ; lia. Qed. Lemma Zmax_inf_l : forall m n : Z, (n <= m)%Z -> Z.max m n = m. intros m n H. generalize (Z.le_ge _ _ H). unfold Z.max, Z.ge. case (m ?= n)%Z ; intros ; try exact (refl_equal _). elim H0. exact (refl_equal _). Qed. Lemma float_relative_n_whole : forall c p d x, (bpow radix2 (d + Zpos p - 1) <= Rabs x)%R -> (Rabs ((rounding_float (Znearest c) p d x - x) / x) <= bpow radix2 (-Zpos p))%R. Proof. intros c p d x Hx. assert (Hx0: x <> 0%R). { intros Hx0. apply Rle_not_lt with (1 := Hx). rewrite Hx0, Rabs_R0. apply bpow_gt_0. } destruct (relative_error_N_FLT_ex radix2 d (Zpos p) (refl_equal _) c x Hx) as (eps, (Hr1, Hr2)). rewrite Hr2. replace ((x * (1 + eps) - x) / x)%R with eps by now field. revert Hr1. rewrite <- (bpow_plus radix2 (-1)%Z). now rewrite (Zplus_comm (- Zpos p)), Zplus_assoc. Qed. Lemma float_relative_inv_n_whole : forall c p d x, (bpow radix2 (d + Zpos p - 1) < Rabs (rounding_float (Znearest c) p d x))%R -> (Rabs ((rounding_float (Znearest c) p d x - x) / x) <= bpow radix2 (-Zpos p))%R. Proof with auto with typeclass_instances. intros c p d x Hx. apply float_relative_n_whole. apply Rnot_lt_le. contradict Hx. apply Rle_not_lt. apply abs_round_le_generic... apply generic_format_bpow. unfold FLT_exp. ring_simplify (d + Zpos p - 1 + 1 - Zpos p)%Z. rewrite Zmax_idempotent. clear ; zify ; lia. now apply Rlt_le. Qed. Lemma float_relative_whole : forall m, Valid_rnd m -> forall p d x, (bpow radix2 (d + Zpos p - 1) <= Rabs x)%R -> (Rabs ((rounding_float m p d x - x) / x) <= bpow radix2 (-Zpos p + 1))%R. Proof. intros m Hm p d x Hx. assert (Hx0: x <> 0%R). { intros Hx0. apply Rle_not_lt with (1 := Hx). rewrite Hx0, Rabs_R0. apply bpow_gt_0. } destruct (relative_error_FLT_ex radix2 d (Zpos p) (refl_equal _) m x Hx) as [eps [Hr1 Hr2]]. rewrite Hr2. replace ((x * (1 + eps) - x) / x)%R with eps by now field. now apply Rlt_le. Qed. Lemma float_relative_zr_whole : forall p d x, (x <> 0)%R -> (((rounding_float rndZR p d x - x) / x) <= 0)%R. Proof with eauto with typeclass_instances. intros p d x Zx. destruct (Rle_or_lt 0 x) as [Hx|Hx]. - apply Rmult_le_reg_r with x. lra. apply Rplus_le_reg_r with x. replace (0 * x + x)%R with x by ring. replace (_ / x * x + x)%R with (Generic_fmt.round radix2 (FLT_exp d (Z.pos p)) Ztrunc x) by now field. rewrite round_ZR_DN by easy. apply round_DN_pt... - apply Rmult_le_reg_r with (-x)%R. lra. apply Rplus_le_reg_r with (-x)%R. replace (0 * -x + -x)%R with (-x)%R by ring. replace (_ / x * -x + -x)%R with (- Generic_fmt.round radix2 (FLT_exp d (Z.pos p)) Ztrunc x)%R by now field. apply Ropp_le_contravar. rewrite round_ZR_UP by now apply Rlt_le. apply round_UP_pt... Qed. Theorem fix_of_float : forall rdir x p k1 k2, Zle_bool k2 k1 = true -> FIX (rounding_float rdir p k1 x) k2. Proof. intros rdir x p k1 k2 H. generalize (Zle_bool_imp_le _ _ H). clear H. intro H. unfold FIX. eexists (Float2 _ _) ; repeat split. simpl. unfold cexp. apply Z.le_trans with (1 := H). apply Z.le_max_r. Qed. Theorem flt_of_float : forall rdir {Hrnd : Valid_rnd rdir} x p1 p2 k, Zle_bool (Zpos p1) (Zpos p2) = true -> FLT (rounding_float rdir p1 k x) p2. Proof with auto with typeclass_instances. intros rdir Hrnd x p1 p2 k H. generalize (Zle_bool_imp_le _ _ H). clear H. intro H. unfold FLT. destruct (FLT_format_generic radix2 k (Zpos p1) (Generic_fmt.round radix2 (FLT_exp k (Zpos p1)) rdir x)) as ((m, e), H1, H2, _). apply generic_format_round... rewrite H1. eexists (Float2 _ _) ; repeat split. apply Z.lt_le_trans with (1 := H2). change (Zpower_pos 2 p2) with (Zpower radix2 (Zpos p2)). now apply Zpower_le. Qed. Theorem flt_of_floatx : forall rdir {Hrnd : Valid_rnd rdir} x p1 p2, Zle_bool (Zpos p1) (Zpos p2) = true -> FLT (rounding_floatx rdir p1 x) p2. Proof with auto with typeclass_instances. intros rdir Hrnd x p1 p2 H. generalize (Zle_bool_imp_le _ _ H). clear H. intro H. unfold FLT. destruct (FLX_format_generic radix2 (Zpos p1) (Generic_fmt.round radix2 (FLX_exp (Zpos p1)) rdir x)) as ((m, e), H1, H2). apply generic_format_round... rewrite H1. eexists (Float2 _ _) ; repeat split. apply Z.lt_le_trans with (1 := H2). change (Zpower_pos 2 p2) with (Zpower radix2 (Zpos p2)). now apply Zpower_le. Qed. Theorem float_of_fix_flt : forall rdir {Hrnd : Valid_rnd rdir}, forall x : R, forall d1 d2 : Z, forall p1 p2 : positive, FIX x d1 -> FLT x p1 -> Zle_bool d2 d1 && Zle_bool (Zpos p1) (Zpos p2) = true -> rounding_float rdir p2 d2 x = x. Proof with auto with typeclass_instances. intros rdir Hrnd x d1 d2 p1 p2 (f1,(Hx1,Hx2)) (f2,(Hx3,Hx4)) Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). generalize (Zle_bool_imp_le _ _ H1). clear H1. intro H1. generalize (Zle_bool_imp_le _ _ H2). clear H2. intro H2. apply round_generic... destruct f1 as (m1, e1). destruct f2 as (m2, e2). destruct (Z.eq_dec m2 0) as [Hm|Hm]. rewrite <- Hx3. unfold float2R. rewrite Hm, F2R_0. apply generic_format_0. assert (mag radix2 (F2R (Float radix2 m2 e2)) <= Zpos p2 + e2)%Z. rewrite mag_F2R with (1 := Hm). apply Zplus_le_compat_r. apply Z.le_trans with (2 := H2). apply bpow_lt_bpow with radix2. destruct (mag radix2 (IZR m2)) as (n2, Hn). simpl. specialize (Hn (IZR_neq _ _ Hm)). apply Rle_lt_trans with (1 := proj1 Hn). rewrite <- abs_IZR. now apply IZR_lt. destruct (Zle_or_lt e1 e2) as [He|He]. (* *) rewrite <- Hx3. apply generic_format_F2R. intros _ ; simpl. apply Z.max_lub. clear -H ; lia. apply Z.le_trans with (1 := H1). now apply Z.le_trans with e1. (* *) rewrite <- Hx1. apply generic_format_F2R. intros _ ; simpl. apply Z.max_lub. unfold float2R in Hx1. simpl in Hx1. rewrite Hx1, <- Hx3. unfold float2R. simpl. lia. now apply Z.le_trans with d1. Qed. Theorem floatx_of_flt : forall rdir {Hrnd : Valid_rnd rdir}, forall x : R, forall p1 p2 : positive, FLT x p1 -> Zle_bool (Zpos p1) (Zpos p2) = true -> rounding_floatx rdir p2 x = x. Proof with auto with typeclass_instances. intros rdir Hrnd x p1 p2 [[m e] [Hx1 Hx2]] Hb. generalize (Zle_bool_imp_le _ _ Hb). clear Hb. intro H1. apply round_generic... rewrite <- Hx1. apply generic_format_F2R. unfold cexp. intros Hm ; simpl. rewrite mag_F2R with (1 := Hm). simpl. unfold FLX_exp. cut (mag radix2 (IZR m) <= Zpos p1)%Z. clear -H1 ; lia. apply bpow_lt_bpow with radix2. destruct (mag radix2 (IZR m)) as [n Hn]. simpl. specialize (Hn (IZR_neq _ _ Hm)). apply Rle_lt_trans with (1 := proj1 Hn). rewrite <- abs_IZR. now apply IZR_lt. Qed. Local Existing Instance valid_rnd_Gf. Definition round_helper (rnd : float2 -> float2) (xi zi : FF) := Fle2 (lower zi) (rnd (lower xi)) && Fle2 (rnd (upper xi)) (upper zi). Theorem float_round : forall rdir p d x xi zi, BND x xi -> round_helper (round (rndG_g rdir) (FLT_exp d (Zpos p))) xi zi = true -> BND (rounding_float (rndG_f rdir) p d x) zi. Proof with auto with typeclass_instances. intros rdir p d x xi zi Hx Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). generalize (Fle2_correct _ _ H1). rewrite rndG_conversion. clear H1. intro H1. generalize (Fle2_correct _ _ H2). rewrite rndG_conversion. clear H2. intro H2. split. apply Rle_trans with (1 := H1). apply round_le... apply Hx. apply Rle_trans with (2 := H2). apply round_le... apply Hx. Qed. Definition float_round_dn := float_round roundDN_cs. Definition float_round_up := float_round roundUP_cs. Definition float_round_zr := float_round roundZR_cs. Definition float_round_ne := float_round roundNE_cs. Definition float_round_na := float_round roundNA_cs. Theorem floatx_round : forall rdir p x xi zi, BND x xi -> round_helper (round (rndG_g rdir) (FLX_exp (Zpos p))) xi zi = true -> BND (rounding_floatx (rndG_f rdir) p x) zi. Proof with auto with typeclass_instances. intros rdir p x xi zi Hx Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). generalize (Fle2_correct _ _ H1). rewrite rndG_conversion. clear H1. intro H1. generalize (Fle2_correct _ _ H2). rewrite rndG_conversion. clear H2. intro H2. split. apply Rle_trans with (1 := H1). apply round_le... apply Hx. apply Rle_trans with (2 := H2). apply round_le... apply Hx. Qed. Definition floatx_round_dn := floatx_round roundDN_cs. Definition floatx_round_up := floatx_round roundUP_cs. Definition floatx_round_zr := floatx_round roundZR_cs. Definition floatx_round_ne := floatx_round roundNE_cs. Definition floatx_round_na := floatx_round roundNA_cs. Definition enforce_helper (fexp : Z -> Z) (xi zi : FF) := Fle2 (lower zi) (round roundUP fexp (lower xi)) && Fle2 (round roundDN fexp (upper xi)) (upper zi). Theorem float_enforce : forall rdir {Hrnd : Valid_rnd rdir} p d x xi zi, BND (rounding_float rdir p d x) xi -> enforce_helper (FLT_exp d (Zpos p)) xi zi = true -> BND (rounding_float rdir p d x) zi. Proof with auto with typeclass_instances. intros rdir Hrnd p d x xi zi Hx Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). generalize (Fle2_correct _ _ H1). rewrite (rndG_conversion roundUP_cs). clear H1. intro H1. generalize (Fle2_correct _ _ H2). rewrite (rndG_conversion roundDN_cs). clear H2. intro H2. revert Hx. intros (Hx1, Hx2). split. apply Rle_trans with (1 := H1). rewrite <- (round_generic _ _ rndUP _ (generic_format_round radix2 (FLT_exp d (Zpos p)) rdir x)). apply round_le... apply Rle_trans with (2 := H2). rewrite <- (round_generic _ _ rndDN _ (generic_format_round radix2 (FLT_exp d (Zpos p)) rdir x)). apply round_le... Qed. Theorem floatx_enforce : forall rdir {Hrnd : Valid_rnd rdir} p x xi zi, BND (rounding_floatx rdir p x) xi -> enforce_helper (FLX_exp (Zpos p)) xi zi = true -> BND (rounding_floatx rdir p x) zi. Proof with auto with typeclass_instances. intros rdir Hrnd p x xi zi Hx Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). generalize (Fle2_correct _ _ H1). rewrite (rndG_conversion roundUP_cs). clear H1. intro H1. generalize (Fle2_correct _ _ H2). rewrite (rndG_conversion roundDN_cs). clear H2. intro H2. revert Hx. intros (Hx1, Hx2). split. apply Rle_trans with (1 := H1). rewrite <- (round_generic _ _ rndUP _ (generic_format_round radix2 (FLX_exp (Zpos p)) rdir x)). apply round_le... apply Rle_trans with (2 := H2). rewrite <- (round_generic _ _ rndDN _ (generic_format_round radix2 (FLX_exp (Zpos p)) rdir x)). apply round_le... Qed. Definition float_absolute_n_helper (p : positive) (d : Z) (xi : FF) (zi : FF) := let u := upper xi in let e := (float_ulp p d (Fnum u) (Fexp u) - 1)%Z in Fle2 (lower zi) (Float2 (-1) e) && Fle2 (Float2 1 e) (upper zi). Theorem float_absolute_n : forall c p d x xi zi, ABS x xi -> float_absolute_n_helper p d xi zi = true -> BND (rounding_float (Znearest c) p d x - x) zi. Proof with auto with typeclass_instances. intros c p d x xi zi Hx Hb. assert (H: (Rabs (rounding_float (Znearest c) p d x - x) <= bpow radix2 (float_ulp p d (Fnum (upper xi)) (Fexp (upper xi)) - 1))%R). (* *) destruct (Req_dec x 0) as [Hx0|Hx0]. rewrite Hx0, round_0, Rminus_0_r, Rabs_R0... apply bpow_ge_0. replace (bpow radix2 (float_ulp p d (Fnum (upper xi)) (Fexp (upper xi)) - 1)) with (/2 * ulp radix2 (FLT_exp d (Zpos p)) (upper xi))%R. (* . *) apply Rle_trans with (/2 * ulp radix2 (FLT_exp d (Zpos p)) x)%R. apply error_le_half_ulp... apply Rmult_le_compat_l. apply Rlt_le. apply Rinv_0_lt_compat. now apply IZR_lt. rewrite <- ulp_abs. apply ulp_le_pos... apply Rabs_pos. apply Hx. (* . *) unfold Z.sub. rewrite bpow_plus, Rmult_comm. apply Rmult_eq_compat_r. apply eq_sym, float_ulp_correct. (* *) generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). generalize (Fle2_correct _ _ H1). clear H1. intro H1. generalize (Fle2_correct _ _ H2). clear H2. intro H2. split. apply Rle_trans with (1 := H1). unfold float2R. rewrite (F2R_Zopp _ 1%Z). rewrite F2R_bpow. apply Ropp_le_cancel. rewrite Ropp_involutive. apply (Rle_trans _ _ _ (Rabs_idem _)). now rewrite Rabs_Ropp. apply Rle_trans with (2 := H2). unfold float2R. rewrite F2R_bpow. now apply (Rle_trans _ _ _ (Rabs_idem _)). Qed. Definition float_absolute_ne := float_absolute_n (fun x => negb (Z.even x)). Definition float_absolute_na := float_absolute_n (Zle_bool 0). Definition float_absolute_zr_helper (p : positive) (d : Z) (xi : FF) (zi : FF) := (if Fneg0 (upper xi) then Fneg0 (lower zi) else let u := upper xi in let e := float_ulp p d (Fnum u) (Fexp u) in Fle2 (lower zi) (Float2 (-1) e)) && (if Fpos0 (lower xi) then Fpos0 (upper zi) else let l := lower xi in let e := float_ulp p d (Fnum l) (Fexp l) in Fle2 (Float2 1 e) (upper zi)). Theorem float_absolute_zr : forall p d x xi zi, BND x xi -> float_absolute_zr_helper p d xi zi = true -> BND (rounding_float rndZR p d x - x) zi. Proof with auto with typeclass_instances. intros p d x xi zi Hx Hb. generalize (andb_prop _ _ Hb). clear Hb. intros [H1 H2]. assert (Hz: (lower zi <= 0 <= upper zi)%R). { split. - destruct (Fneg0 (upper xi)). now apply Fneg0_correct. apply Rle_trans with (1 := Fle2_correct _ _ H1). now apply F2R_le_0. - destruct (Fpos0 (lower xi)). now apply Fpos0_correct. apply Rle_trans with (2 := Fle2_correct _ _ H2). now apply F2R_ge_0. } destruct (Rle_or_lt 0 x) as [[Sx|Sx]|Sx]. - rewrite round_ZR_DN by now apply Rlt_le. split. 2: { apply Rle_trans with (2 := proj2 Hz). apply Rle_minus. apply round_DN_pt... } destruct (Fneg0 (upper xi)) eqn:Hxu. { elim Rlt_not_le with (1 := Sx). apply Rle_trans with (1 := proj2 Hx). now apply Fneg0_correct. } apply Rle_trans with (1 := Fle2_correct _ _ H1). unfold float2R. rewrite (F2R_Zopp _ 1), F2R_bpow. simpl. rewrite float_ulp_correct. apply Ropp_le_cancel. rewrite Ropp_involutive. apply (Rle_trans _ _ _ (Rabs_idem _)). rewrite Rabs_Ropp. apply Rle_trans with (ulp radix2 (FLT_exp d (Z.pos p)) x). apply error_le_ulp... apply ulp_le... rewrite (Rabs_pos_eq x) by now apply Rlt_le. apply Rle_trans with (1 := proj2 Hx). apply Rabs_idem. - rewrite <- Sx, round_0... now rewrite Rminus_0_r. - rewrite round_ZR_UP by now apply Rlt_le. split. { apply Rle_trans with (1 := proj1 Hz). apply Rle_0_minus. apply round_UP_pt... } destruct (Fpos0 (lower xi)) eqn:Hxl. { elim Rlt_not_le with (1 := Sx). apply Rle_trans with (2 := proj1 Hx). now apply Fpos0_correct. } apply Rle_trans with (2 := Fle2_correct _ _ H2). unfold float2R. rewrite F2R_bpow. simpl. rewrite float_ulp_correct. apply (Rle_trans _ _ _ (Rabs_idem _)). apply Rle_trans with (ulp radix2 (FLT_exp d (Z.pos p)) x). apply error_le_ulp... apply ulp_le... rewrite (Rabs_left x) by easy. rewrite Rabs_left1. apply Ropp_le_contravar. apply Hx. apply Rle_trans with (1 := proj1 Hx). now apply Rlt_le. Qed. Definition float_absolute_up_helper (p : positive) (d : Z) (xi : FF) (zi : FF) := let u := Fmag xi in let e := float_ulp p d (Fnum u) (Fexp u) in Fneg0 (lower zi) && Fle2 (Float2 1 e) (upper zi). Theorem float_absolute_up : forall p d x xi zi, BND x xi -> float_absolute_up_helper p d xi zi = true -> BND (rounding_float rndUP p d x - x) zi. Proof with auto with typeclass_instances. intros p d x xi zi Hx Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). generalize (Fneg0_correct _ H1). clear H1. intro H1. generalize (Fle2_correct _ _ H2). unfold float2R at 1. simpl. rewrite F2R_bpow. clear H2. intro H2. apply Fmag_correct in Hx. split. { apply Rle_trans with (1 := H1). apply Rle_0_minus. apply round_UP_pt... } apply Rle_trans with (2 := H2). rewrite float_ulp_correct. apply Rle_trans with (ulp radix2 (FLT_exp d (Z.pos p)) x). - rewrite <- (Rabs_pos_eq (Generic_fmt.round _ _ _ x - x)). apply error_le_ulp... apply Rle_0_minus. apply round_UP_pt... - apply ulp_le... rewrite (Rabs_pos_eq (F2R _)). apply Hx. apply Rle_trans with (2 := Hx). apply Rabs_pos. Qed. Definition float_absolute_dn_helper (p : positive) (d : Z) (xi : FF) (zi : FF) := let u := Fmag xi in let e := float_ulp p d (Fnum u) (Fexp u) in Fle2 (lower zi) (Float2 (-1) e) && Fpos0 (upper zi). Theorem float_absolute_dn : forall p d x xi zi, BND x xi -> float_absolute_dn_helper p d xi zi = true -> BND (rounding_float rndDN p d x - x) zi. Proof with auto with typeclass_instances. intros p d x xi zi Hx Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). generalize (Fle2_correct _ _ H1). unfold float2R at 2. simpl. rewrite (F2R_Zopp _ 1), F2R_bpow. clear H1. intro H1. generalize (Fpos0_correct _ H2). clear H2. intro H2. apply Fmag_correct in Hx. assert (H: (Generic_fmt.round radix2 (FLT_exp d (Z.pos p)) Zfloor x - x <= 0)%R). { cut (Generic_fmt.round radix2 (FLT_exp d (Z.pos p)) Zfloor x <= x)%R. lra. apply round_DN_pt... } split. 2: now apply Rle_trans with (2 := H2). apply Rle_trans with (1 := H1). rewrite float_ulp_correct. apply Ropp_le_cancel. rewrite Ropp_involutive. apply Rle_trans with (ulp radix2 (FLT_exp d (Z.pos p)) x). - rewrite <- Rabs_left1 by easy. apply error_le_ulp... - apply ulp_le... rewrite (Rabs_pos_eq (F2R _)). apply Hx. apply Rle_trans with (2 := Hx). apply Rabs_pos. Qed. Definition floatx_absolute_n_helper (p : positive) (xi : FF) (zi : FF) := let u := upper xi in let e := (floatx_ulp p (Fnum u) (Fexp u) - 1)%Z in Fle2 (lower zi) (Float2 (-1) e) && Fle2 (Float2 1 e) (upper zi). Theorem floatx_absolute_n : forall c p x xi zi, ABS x xi -> floatx_absolute_n_helper p xi zi = true -> BND (rounding_floatx (Znearest c) p x - x) zi. Proof with auto with typeclass_instances. intros c p x xi zi Hx Hb. assert (H: (Rabs (rounding_floatx (Znearest c) p x - x) <= bpow radix2 (floatx_ulp p (Fnum (upper xi)) (Fexp (upper xi)) - 1))%R). (* *) destruct (Req_dec x 0) as [Hx0|Hx0]. rewrite Hx0, round_0, Rminus_0_r, Rabs_R0... apply bpow_ge_0. replace (bpow radix2 (floatx_ulp p (Fnum (upper xi)) (Fexp (upper xi)) - 1)) with (/2 * ulp radix2 (FLX_exp (Zpos p)) (upper xi))%R. (* . *) apply Rle_trans with (/2 * ulp radix2 (FLX_exp (Zpos p)) x)%R. apply error_le_half_ulp... apply Rmult_le_compat_l. apply Rlt_le. apply Rinv_0_lt_compat. now apply IZR_lt. rewrite <- ulp_abs. apply ulp_le_pos... apply Rabs_pos. apply Hx. (* . *) assert (Hm0: (Fnum (upper xi)) <> Z0). assert (Hx1 := Rabs_no_R0 _ Hx0). contradict Hx1. apply Rle_antisym. replace 0%R with (float2R (upper xi)). apply Hx. clear -Hx1. destruct (upper xi). simpl in Hx1. rewrite Hx1. apply float2_zero. apply Rabs_pos. rewrite ulp_neq_0. 2: now apply F2R_neq_0. rewrite <- (bpow_plus radix2 (-1)). unfold Zminus. rewrite (Zplus_comm _ (-1)). apply (f_equal (fun e => bpow radix2 (-1 + e))). clear -Hm0. destruct (upper xi) as (m, e). unfold cexp, float2R. rewrite mag_F2R with (1 := Hm0). rewrite <- Zdigits_mag with (1 := Hm0). simpl. rewrite <- Zdigits_abs. rewrite Zplus_comm. destruct m as [|m|m] ; unfold Z.abs. now elim Hm0. now rewrite <- digits2_digits. now rewrite <- digits2_digits. (* *) generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). generalize (Fle2_correct _ _ H1). clear H1. intro H1. generalize (Fle2_correct _ _ H2). clear H2. intro H2. split. apply Rle_trans with (1 := H1). unfold float2R. rewrite (F2R_Zopp _ 1%Z). rewrite F2R_bpow. apply Ropp_le_cancel. rewrite Ropp_involutive. apply (Rle_trans _ _ _ (Rabs_idem _)). now rewrite Rabs_Ropp. apply Rle_trans with (2 := H2). unfold float2R. rewrite F2R_bpow. now apply (Rle_trans _ _ _ (Rabs_idem _)). Qed. Definition floatx_absolute_ne := floatx_absolute_n (fun x => negb (Z.even x)). Definition floatx_absolute_na := floatx_absolute_n (Zle_bool 0). Theorem float_absolute_inv_n : forall c p d x xi zi, ABS (rounding_float (Znearest c) p d x) xi -> float_absolute_n_helper p d xi zi = true -> BND (rounding_float (Znearest c) p d x - x) zi. Proof with auto with typeclass_instances. intros c p d x xi zi Hx Hb. assert (H: (Rabs (rounding_float (Znearest c) p d x - x) <= bpow radix2 (float_ulp p d (Fnum (upper xi)) (Fexp (upper xi)) - 1))%R). (* *) replace (float_ulp p d (Fnum (upper xi)) (Fexp (upper xi))) with (FLT_exp d (Zpos p) (if Z.eq_dec (Fnum (upper xi)) Z0 then d else (Fexp (upper xi) + Zpos (digits (pos_of_Z (Z.abs (Fnum (upper xi))))))%Z)). apply float_absolute_inv_n_whole. apply Rle_lt_trans with (1 := proj2 (proj2 Hx)). unfold float2R. case Z.eq_dec ; intros Zx. rewrite Zx, F2R_0. apply bpow_gt_0. rewrite digits2_digits. rewrite Zpos_pos_of_Z. rewrite Zdigits_abs, Zplus_comm. rewrite <- mag_F2R_Zdigits with (1 := Zx). destruct mag as (ex,Ex) ; simpl. apply Rle_lt_trans with (1 := RRle_abs _). apply Ex. contradict Zx. apply eq_0_F2R with (1 := Zx). clear -Zx ; zify ; lia. unfold float_ulp. case Z.eq_dec ; intros Zx. rewrite Zx. unfold FLT_exp. clear ; zify ; lia. revert Zx. case Fnum ; simpl ; [|easy|easy]. intros H. now elim H. (* *) generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). generalize (Fle2_correct _ _ H1). clear H1. intro H1. generalize (Fle2_correct _ _ H2). clear H2. intro H2. split. apply Rle_trans with (1 := H1). unfold float2R. rewrite (F2R_Zopp _ 1%Z). rewrite F2R_bpow. apply Ropp_le_cancel. rewrite Ropp_involutive. apply (Rle_trans _ _ _ (Rabs_idem _)). now rewrite Rabs_Ropp. apply Rle_trans with (2 := H2). unfold float2R. rewrite F2R_bpow. now apply (Rle_trans _ _ _ (Rabs_idem _)). Qed. Definition float_absolute_inv_ne := float_absolute_inv_n (fun x => negb (Z.even x)). Definition float_absolute_inv_na := float_absolute_inv_n (Zle_bool 0). Theorem float_absolute_inv_up : forall p d x xi zi, BND (rounding_float rndUP p d x) xi -> float_absolute_up_helper p d xi zi = true -> BND (rounding_float rndUP p d x - x) zi. Proof with auto with typeclass_instances. intros p d x xi zi Hx Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). generalize (Fneg0_correct _ H1). clear H1. intro H1. generalize (Fle2_correct _ _ H2). unfold float2R at 1. simpl. rewrite F2R_bpow. clear H2. intro H2. apply Fmag_correct in Hx. split. { apply Rle_trans with (1 := H1). apply Rle_0_minus. apply round_UP_pt... } apply Rle_trans with (2 := H2). rewrite float_ulp_correct. apply Rle_trans with (ulp radix2 (FLT_exp d (Z.pos p)) (Generic_fmt.round radix2 (FLT_exp d (Z.pos p)) Zceil x)). - rewrite <- (Rabs_pos_eq (Generic_fmt.round _ _ _ x - x)). apply error_le_ulp_round... apply Rle_0_minus. apply round_UP_pt... - apply ulp_le... rewrite (Rabs_pos_eq (F2R _)). apply Hx. apply Rle_trans with (2 := Hx). apply Rabs_pos. Qed. Theorem float_absolute_inv_dn : forall p d x xi zi, BND (rounding_float rndDN p d x) xi -> float_absolute_dn_helper p d xi zi = true -> BND (rounding_float rndDN p d x - x) zi. Proof with auto with typeclass_instances. intros p d x xi zi Hx Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). generalize (Fle2_correct _ _ H1). unfold float2R at 2. simpl. rewrite (F2R_Zopp _ 1), F2R_bpow. clear H1. intro H1. generalize (Fpos0_correct _ H2). clear H2. intro H2. apply Fmag_correct in Hx. assert (H: (Generic_fmt.round radix2 (FLT_exp d (Z.pos p)) Zfloor x - x <= 0)%R). { cut (Generic_fmt.round radix2 (FLT_exp d (Z.pos p)) Zfloor x <= x)%R. lra. apply round_DN_pt... } split. 2: now apply Rle_trans with (2 := H2). apply Rle_trans with (1 := H1). rewrite float_ulp_correct. apply Ropp_le_cancel. rewrite Ropp_involutive. apply Rle_trans with (ulp radix2 (FLT_exp d (Z.pos p)) (Generic_fmt.round radix2 (FLT_exp d (Z.pos p)) Zfloor x)). - rewrite <- Rabs_left1 by easy. apply error_le_ulp_round... - apply ulp_le... rewrite (Rabs_pos_eq (F2R _)). apply Hx. apply Rle_trans with (2 := Hx). apply Rabs_pos. Qed. Definition float_absolute_wide_ne_helper (p : positive) (d : Z) (xi : FF) (zi : FF) := let u := upper xi in let e := (float_ulp p d (Fnum u) (Fexp u) - 2)%Z in Zle_bool d (Fexp u - Zpos p) && Fle2 u (Float2 (Zpos (xI (shift_pos p xH))) e) && Fle2 (lower zi) (Float2 (-1) e) && Fle2 (Float2 1 e) (upper zi). Theorem float_absolute_wide_ne : forall p d x xi zi, ABS x xi -> float_absolute_wide_ne_helper p d xi zi = true -> BND (rounding_float rndNE p d x - x) zi. Proof with auto with typeclass_instances. intros p d x xi zi Hx Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H4). generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3). generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). generalize (Zle_bool_imp_le _ _ H1). clear H1. intro H1. generalize (Fle2_correct _ _ H2). unfold float2R. simpl. clear H2. intro H2. generalize (Fle2_correct _ _ H3). unfold float2R. simpl. rewrite (F2R_Zopp _ 1%Z), F2R_bpow. clear H3. intro H3. generalize (Fle2_correct _ _ H4). unfold float2R. simpl. rewrite F2R_bpow. clear H4. intro H4. set (e := (float_ulp p d (Fnum (upper xi)) (Fexp (upper xi)) - 2)%Z) in H2, H3, H4. cut (Rabs (rounding_float rndNE p d x - x) <= bpow radix2 e)%R. { split. apply Rle_trans with (1 := H3). apply Ropp_le_cancel. rewrite Ropp_involutive. apply Rle_trans with (2 := H). rewrite <- Rabs_Ropp. apply Rabs_idem. apply Rle_trans with (2 := H4). apply Rle_trans with (2 := H). apply Rabs_idem. } destruct Hx as [_ [_ Hx]]. clear H3 H4 zi. destruct (upper xi) as [xum xue]. cbn in e, H2. destruct xum as [|xum|xum]. 3: { elim Rlt_not_le with (2 := Hx). apply Rlt_le_trans with (Float2 0 xue). now apply F2R_lt. unfold float2R. rewrite F2R_0. apply Rabs_pos. } { assert (x = 0%R) as ->. rewrite float2_zero in Hx. apply Rabs_le_inv in Hx. apply Rle_antisym with (1 := proj2 Hx). now rewrite <- Ropp_0. rewrite round_0... rewrite Rminus_0_r. rewrite Rabs_R0. apply bpow_ge_0. } simpl in e, H1. assert (H9: (e = xue + Zpos (digits xum) - Zpos p - 2)%Z). { unfold e, FLT_exp. rewrite Zmax_inf_l. easy. generalize (Zgt_pos_0 (digits xum)). lia. } destruct (Rle_or_lt (bpow radix2 (xue + Zpos (digits xum) - 1)) (Rabs x)) as [Hx'|Hx']. 2: { replace e with (FLT_exp d (Zpos p) (xue + Zpos (digits xum) - 1) - 1)%Z. now apply float_absolute_n_whole. rewrite H9. unfold FLT_exp. assert (H3 := Zgt_pos_0 (digits xum)). assert (H4 := Zgt_pos_0 p). repeat rewrite Zmax_inf_l ; lia. } rewrite float_absolute_ne_sym. apply Rle_trans with (Rabs (bpow radix2 (xue + Z.pos (digits xum) - 1) - Rabs x))%R. apply round_N_pt. now apply FLT_exp_valid. apply generic_format_bpow. unfold FLT_exp. clear -H1 ; lia. rewrite Rabs_minus_sym, Rabs_pos_eq by now apply Rle_0_minus. apply (Rle_trans _ _ _ Hx) in H2. cut (F2R (Float radix2 (Zpos (xI (shift_pos p 1))) e) = bpow radix2 e + bpow radix2 (xue + Z.pos (digits xum) - 1))%R. clear -H2 ; lra. replace (xue + Zpos (digits xum) - 1)%Z with (Zpos p + 1 + e)%Z by (rewrite H9 ; ring). rewrite bpow_plus. unfold F2R. cbn -[Zplus]. rewrite <- (Rmult_1_l (bpow radix2 e)) at 2. rewrite <- Rmult_plus_distr_r. apply Rmult_eq_compat_r. rewrite <- IZR_Zpower by easy. rewrite <- plus_IZR. apply f_equal. rewrite Zpower_exp by easy. rewrite Zplus_comm. cbn. rewrite <- (Zmult_1_r (Z.pow_pos 2 p)). rewrite <- shift_pos_correct. now rewrite Zmult_comm. Qed. Definition float_absolute_wide_zr_helper (p : positive) (d : Z) (xi : FF) (zi : FF) := let u := upper xi in let e := (float_ulp p d (Fnum u) (Fexp u) - 1)%Z in Zle_bool d (Fexp u - Zpos p) && Fle2 u (Float2 (Zpos (shift_pos p xH + 1)) e) && Fle2 (lower zi) (Float2 (-1) e) && Fle2 (Float2 1 e) (upper zi). Theorem float_absolute_wide_zr : forall p d x xi zi, ABS x xi -> (* should have been BND, so not quite good *) float_absolute_wide_zr_helper p d xi zi = true -> BND (rounding_float rndZR p d x - x) zi. Proof with auto with typeclass_instances. intros p d x xi zi Hx Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H4). generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3). generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). generalize (Zle_bool_imp_le _ _ H1). clear H1. intro H1. generalize (Fle2_correct _ _ H2). unfold float2R. simpl. clear H2. intro H2. generalize (Fle2_correct _ _ H3). unfold float2R. simpl. rewrite (F2R_Zopp _ 1%Z), F2R_bpow. clear H3. intro H3. generalize (Fle2_correct _ _ H4). unfold float2R. simpl. rewrite F2R_bpow. clear H4. intro H4. set (e := (float_ulp p d (Fnum (upper xi)) (Fexp (upper xi)) - 1)%Z) in H2, H3, H4. cut (Rabs (rounding_float rndZR p d x - x) <= bpow radix2 e)%R. { split. apply Rle_trans with (1 := H3). apply Ropp_le_cancel. rewrite Ropp_involutive. apply Rle_trans with (2 := H). rewrite <- Rabs_Ropp. apply Rabs_idem. apply Rle_trans with (2 := H4). apply Rle_trans with (2 := H). apply Rabs_idem. } destruct Hx as [_ [_ Hx]]. clear H3 H4 zi. destruct (upper xi) as [xum xue]. cbn in e, H2. destruct xum as [|xum|xum]. 3: { elim Rlt_not_le with (2 := Hx). apply Rlt_le_trans with (Float2 0 xue). now apply F2R_lt. unfold float2R. rewrite F2R_0. apply Rabs_pos. } { assert (x = 0%R) as ->. rewrite float2_zero in Hx. apply Rabs_le_inv in Hx. apply Rle_antisym with (1 := proj2 Hx). now rewrite <- Ropp_0. rewrite round_0... rewrite Rminus_0_r. rewrite Rabs_R0. apply bpow_ge_0. } simpl in e, H1. assert (H9: (e = xue + Zpos (digits xum) - Zpos p - 1)%Z). { unfold e, FLT_exp. rewrite Zmax_inf_l. easy. generalize (Zgt_pos_0 (digits xum)). lia. } destruct (Rle_or_lt (bpow radix2 (xue + Zpos (digits xum) - 1)) (Rabs x)) as [Hx'|Hx']. 2: { replace e with (FLT_exp d (Zpos p) (xue + Zpos (digits xum) - 1))%Z. apply float_absolute_whole... rewrite H9. unfold FLT_exp. assert (H3 := Zgt_pos_0 (digits xum)). assert (H4 := Zgt_pos_0 p). repeat rewrite Zmax_inf_l ; lia. } apply (Rle_trans _ _ _ Hx) in H2. rewrite float_absolute_zr_sym. assert (H5: (bpow radix2 (xue + Z.pos (digits xum) - 1) <= Generic_fmt.round radix2 (FLT_exp d (Z.pos p)) Zfloor (Rabs x))%R). { apply round_DN_pt... apply generic_format_bpow. unfold FLT_exp. clear -H1 ; lia. } cut (F2R (Float radix2 (Zpos (shift_pos p 1 + 1)) e) = bpow radix2 e + bpow radix2 (xue + Z.pos (digits xum) - 1))%R. clear -H2 H5 ; lra. replace (xue + Zpos (digits xum) - 1)%Z with (Zpos p + e)%Z by (rewrite H9 ; ring). rewrite bpow_plus. unfold F2R. cbn -[Zplus]. rewrite <- (Rmult_1_l (bpow radix2 e)) at 2. rewrite <- Rmult_plus_distr_r. apply Rmult_eq_compat_r. rewrite <- plus_IZR. apply f_equal. rewrite <- (Zmult_1_r (Z.pow_pos 2 p)). rewrite <- shift_pos_correct. apply eq_sym, Zplus_comm. Qed. Lemma floatx_error_wide_n : forall c p x M, let e := (floatx_ulp p (Fnum M) (Fexp M) - 2)%Z in (Rabs x <= M <= float2R (Float2 (Zpos (xI (shift_pos p xH))) e))%R -> (Rabs (Generic_fmt.round radix2 (FLX_exp (Zpos p)) (Znearest c) x - x) <= bpow radix2 e)%R. Proof with auto with typeclass_instances. intros c p x M e [Hx He]. destruct M as [xum xue]. cbn in e. destruct xum as [|xum|xum]. 3: { elim Rlt_not_le with (2 := Hx). apply Rlt_le_trans with (Float2 0 xue). now apply F2R_lt. unfold float2R. rewrite F2R_0. apply Rabs_pos. } { assert (x = 0%R) as ->. rewrite float2_zero in Hx. apply Rabs_le_inv in Hx. apply Rle_antisym with (1 := proj2 Hx). now rewrite <- Ropp_0. rewrite round_0... rewrite Rminus_0_r. rewrite Rabs_R0. apply bpow_ge_0. } simpl in e. destruct (Rle_or_lt (bpow radix2 (xue + Zpos (digits xum) - 1)) (Rabs x)) as [Hx'|Hx']. 2: { replace e with (FLX_exp (Zpos p) (xue + Zpos (digits xum) - 1) - 1)%Z by (unfold e, FLX_exp ; ring). now apply floatx_absolute_n_whole. } apply Rle_trans with (Rabs (bpow radix2 (xue + Z.pos (digits xum) - 1) - Rabs x))%R. { set (xe := (_ - 1)%Z). clearbody xe. clear. revert c x. cut (forall c' x', (0 <= x')%R -> (Rabs (Generic_fmt.round radix2 (FLX_exp (Z.pos p)) (Znearest c') x' - x') <= Rabs (bpow radix2 xe - x'))%R). { intros H c x. destruct (Rle_or_lt 0 x) as [Hx|Hx]. - rewrite (Rabs_pos_eq _ Hx). now apply H. - rewrite <- (Ropp_involutive x). rewrite round_N_opp, Rabs_Ropp. rewrite (Rabs_pos_eq (- x)) by lra. unfold Rminus. rewrite <- Ropp_plus_distr, Rabs_Ropp. apply H. lra. } intros c x Hx. apply round_N_pt. now apply FLX_exp_valid. apply generic_format_bpow. unfold FLX_exp. lia. } rewrite Rabs_minus_sym, Rabs_pos_eq by now apply Rle_0_minus. apply (Rle_trans _ _ _ Hx) in He. cut (float2R (Float2 (Zpos (xI (shift_pos p 1))) e) = bpow radix2 e + bpow radix2 (xue + Z.pos (digits xum) - 1))%R. clear -He ; lra. replace (xue + Zpos (digits xum) - 1)%Z with (Zpos p + 1 + e)%Z by (unfold e, FLX_exp ; ring). rewrite bpow_plus. unfold float2R, F2R. cbn -[Zplus]. rewrite <- (Rmult_1_l (bpow radix2 e)) at 2. rewrite <- Rmult_plus_distr_r. apply Rmult_eq_compat_r. rewrite <- IZR_Zpower by easy. rewrite <- plus_IZR. apply f_equal. rewrite Zpower_exp by easy. rewrite Zplus_comm. cbn. rewrite <- (Zmult_1_r (Z.pow_pos 2 p)). rewrite <- shift_pos_correct. now rewrite Zmult_comm. Qed. Definition floatx_absolute_wide_ne_helper (p : positive) (xi : FF) (zi : FF) := let u := upper xi in let e := (floatx_ulp p (Fnum u) (Fexp u) - 2)%Z in Fle2 u (Float2 (Zpos (xI (shift_pos p xH))) e) && Fle2 (lower zi) (Float2 (-1) e) && Fle2 (Float2 1 e) (upper zi). Theorem floatx_absolute_wide_n : forall c p x xi zi, ABS x xi -> floatx_absolute_wide_ne_helper p xi zi = true -> BND (rounding_floatx (Znearest c) p x - x) zi. Proof with auto with typeclass_instances. intros c p x xi zi Hx Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H4). generalize (andb_prop _ _ Hb). clear Hb. intros (H2,H3). generalize (Fle2_correct _ _ H2). clear H2. intro H2. generalize (Fle2_correct _ _ H3). unfold float2R at 2. simpl. rewrite (F2R_Zopp _ 1%Z), F2R_bpow. clear H3. intro H3. generalize (Fle2_correct _ _ H4). unfold float2R at 1. simpl. rewrite F2R_bpow. clear H4. intro H4. simple refine (let H := floatx_error_wide_n c p x (upper xi) (conj _ H2) in _). 2: clearbody H. apply Hx. clear H2. set (e := (floatx_ulp p (Fnum (upper xi)) (Fexp (upper xi)) - 2)%Z) in H, H3, H4. split. - apply Rle_trans with (1 := H3). apply Ropp_le_cancel. rewrite Ropp_involutive. apply Rle_trans with (2 := H). rewrite <- Rabs_Ropp. apply Rabs_idem. - apply Rle_trans with (2 := H4). apply Rle_trans with (2 := H). apply Rabs_idem. Qed. Definition floatx_absolute_wide_ne := floatx_absolute_wide_n (fun x => negb (Z.even x)). Definition floatx_absolute_wide_na := floatx_absolute_wide_n (Zle_bool 0). Definition float_relative_n_helper (p : positive) (d : Z) (xi zi : FF) := Fle2 (Float2 1 (d + Zpos p - 1)) (lower xi) && Fle2 (lower zi) (Float2 (-1) (Zneg p)) && Fle2 (Float2 1 (Zneg p)) (upper zi). Theorem float_relative_n : forall c p d x xi zi, ABS x xi -> float_relative_n_helper p d xi zi = true -> REL (rounding_float (Znearest c) p d x) x zi. Proof. intros c p d x xi zi Hx Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3). generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). generalize (Fle2_correct _ _ H1). unfold float2R. simpl. rewrite F2R_bpow. clear H1. intro H1. generalize (Fle2_correct _ _ H2). unfold float2R. simpl. rewrite (F2R_Zopp _ 1%Z), F2R_bpow. clear H2. intro H2. generalize (Fle2_correct _ _ H3). unfold float2R. simpl. rewrite F2R_bpow. clear H3. intro H3. exists ((rounding_float (Znearest c) p d x - x) / x)%R. split. assert (Rabs ((rounding_float (Znearest c) p d x - x) / x) <= bpow radix2 (- Zpos p))%R. apply float_relative_n_whole. apply Rle_trans with (1 := H1). apply Hx. split. apply Rle_trans with (1 := H2). apply Ropp_le_cancel. rewrite Ropp_involutive. apply Rle_trans with (2 := H). rewrite <- Rabs_Ropp. apply Rabs_idem. apply Rle_trans with (2 := H3). apply Rle_trans with (2 := H). apply Rabs_idem. field. intros H. apply Rle_not_lt with (1 := H1). apply Rle_lt_trans with (1 := proj1 (proj2 Hx)). rewrite H, Rabs_R0. apply bpow_gt_0. Qed. Definition float_relative_ne := float_relative_n (fun x => negb (Z.even x)). Definition float_relative_na := float_relative_n (Zle_bool 0). Definition float_relative_helper (p : positive) (d : Z) (xi zi : FF) := Fle2 (Float2 1 (d + Zpos p - 1)) (lower xi) && Fle2 (lower zi) (Float2 (-1) (Zneg p + 1)) && Fle2 (Float2 1 (Zneg p + 1)) (upper zi). Theorem float_relative : forall m, Valid_rnd m -> forall p d x xi zi, ABS x xi -> float_relative_helper p d xi zi = true -> REL (rounding_float m p d x) x zi. Proof. intros m Hm p d x xi zi Hx Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3). generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). generalize (Fle2_correct _ _ H1). unfold float2R at 1. simpl. rewrite F2R_bpow. clear H1. intro H1. generalize (Fle2_correct _ _ H2). unfold float2R at 2. simpl. rewrite (F2R_Zopp _ 1%Z), F2R_bpow. clear H2. intro H2. generalize (Fle2_correct _ _ H3). unfold float2R at 1. simpl. rewrite F2R_bpow. clear H3. intro H3. exists ((rounding_float m p d x - x) / x)%R. split. 2: { field. intros H. apply Rle_not_lt with (1 := H1). apply Rle_lt_trans with (1 := proj1 (proj2 Hx)). rewrite H, Rabs_R0. apply bpow_gt_0. } assert (Rabs ((rounding_float m p d x - x) / x) <= bpow radix2 (- Zpos p + 1))%R. { apply float_relative_whole with (1 := Hm). apply Rle_trans with (1 := H1). apply Hx. } split. - apply Rle_trans with (1 := H2). apply Ropp_le_cancel. rewrite Ropp_involutive. apply Rle_trans with (2 := H). rewrite <- Rabs_Ropp. apply Rabs_idem. - apply Rle_trans with (2 := H3). apply Rle_trans with (2 := H). apply Rabs_idem. Qed. Definition float_relative_dn := float_relative Zfloor _. Definition float_relative_up := float_relative Zceil _. Definition float_relative_zr_helper (p : positive) (d : Z) (xi zi : FF) := Fle2 (Float2 1 (d + Zpos p - 1)) (lower xi) && Fle2 (lower zi) (Float2 (-1) (Zneg p + 1)) && Fpos0 (upper zi). Theorem float_relative_zr : forall p d x xi zi, ABS x xi -> float_relative_zr_helper p d xi zi = true -> REL (rounding_float rndZR p d x) x zi. Proof. intros p d x xi zi Hx Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3). generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). generalize (Fle2_correct _ _ H1). unfold float2R at 1. simpl. rewrite F2R_bpow. clear H1. intro H1. generalize (Fle2_correct _ _ H2). unfold float2R at 2. simpl. rewrite (F2R_Zopp _ 1%Z), F2R_bpow. clear H2. intro H2. generalize (Fpos0_correct _ H3). clear H3. intro H3. exists ((rounding_float rndZR p d x - x) / x)%R. split. 2: { field. intros H. apply Rle_not_lt with (1 := H1). apply Rle_lt_trans with (1 := proj1 (proj2 Hx)). rewrite H, Rabs_R0. apply bpow_gt_0. } assert (Rabs ((rounding_float rndZR p d x - x) / x) <= bpow radix2 (- Zpos p + 1))%R. { apply float_relative_whole. apply valid_rnd_ZR. apply Rle_trans with (1 := H1). apply Hx. } split. - apply Rle_trans with (1 := H2). apply Ropp_le_cancel. rewrite Ropp_involutive. apply Rle_trans with (2 := H). rewrite <- Rabs_Ropp. apply Rabs_idem. - apply Rle_trans with (2 := H3). apply float_relative_zr_whole. intros Zx. apply Rlt_not_le with (2 := H1). apply Rle_lt_trans with (1 := proj1 (proj2 Hx)). rewrite Zx, Rabs_R0. apply bpow_gt_0. Qed. Definition floatx_relative_n_helper (p : positive) (zi : FF) := Fle2 (lower zi) (Float2 (-1) (Zneg p)) && Fle2 (Float2 1 (Zneg p)) (upper zi). Theorem floatx_relative_n : forall c p x zi, floatx_relative_n_helper p zi = true -> REL (rounding_floatx (Znearest c) p x) x zi. Proof. intros c p x zi Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). generalize (Fle2_correct _ _ H1). unfold float2R. simpl. rewrite (F2R_Zopp _ 1%Z), F2R_bpow. clear H1. intro H1. generalize (Fle2_correct _ _ H2). unfold float2R. simpl. rewrite F2R_bpow. clear H2. intro H2. destruct (relative_error_N_FLX_ex radix2 (Zpos p) (refl_equal _) c x) as (eps, (Hr1, Hr2)). exists eps. refine (conj _ Hr2). rewrite <- (bpow_plus radix2 (-1)%Z) in Hr1. rewrite (Zplus_comm (- Zpos p)), Zplus_assoc in Hr1. split. apply Rle_trans with (1 := H1). apply Ropp_le_cancel. rewrite Ropp_involutive. apply Rle_trans with (2 := Hr1). rewrite <- Rabs_Ropp. apply Rabs_idem. apply Rle_trans with (2 := H2). apply Rle_trans with (2 := Hr1). apply Rabs_idem. Qed. Definition floatx_relative_ne := floatx_relative_n (fun x => negb (Z.even x)). Definition floatx_relative_na := floatx_relative_n (Zle_bool 0). Definition floatx_relative_aw_helper (p : positive) (zi : FF) := Fneg0 (lower zi) && Fle2 (Float2 1 (Zneg p + 1)) (upper zi). Theorem floatx_relative_aw : forall p x zi, floatx_relative_aw_helper p zi = true -> REL (rounding_floatx Zaway p x) x zi. Proof. intros p x zi Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). generalize (Fneg0_correct _ H1). clear H1. intro H1. generalize (Fle2_correct _ _ H2). unfold float2R. cbn -[Z.add]. rewrite F2R_bpow. clear H2. intro H2. destruct (relative_error_FLX_ex radix2 (Zpos p) eq_refl Zaway x) as (eps, (Hr1, Hr2)). destruct (Req_dec x 0) as [->|Zx]. { exists 0%R. split. apply (conj (H1)). apply Rle_trans with (2 := H2). apply bpow_ge_0. now rewrite Hr2, 2!Rmult_0_l. } exists eps. refine (conj _ Hr2). split. 2: { apply Rle_trans with (2 := H2). apply Rabs_lt_inv in Hr1. now apply Rlt_le. } apply Rle_trans with (1 := H1). apply Rplus_le_reg_l with 1%R. rewrite Rplus_0_r. destruct (Rle_or_lt 0 x) as [[Hx|Hx]|Hx]. 2: now elim Zx. - apply Rmult_le_reg_l with (1 := Hx). rewrite Rmult_1_r, <- Hr2. rewrite round_AW_UP by now apply Rlt_le. apply round_UP_pt. now apply FLX_exp_valid. - apply Rmult_le_reg_l with (-x)%R. now apply Ropp_gt_lt_0_contravar. rewrite <- 2!Ropp_mult_distr_l, Rmult_1_r, <- Hr2. apply Ropp_le_contravar. rewrite round_AW_DN by now apply Rlt_le. apply round_DN_pt. now apply FLX_exp_valid. Qed. Definition float_relative_inv_n_helper (p : positive) (d : Z) (xi zi : FF) := Flt2 (Float2 1 (d + Zpos p - 1)) (lower xi) && Fle2 (lower zi) (Float2 (-1) (Zneg p)) && Fle2 (Float2 1 (Zneg p)) (upper zi). Theorem float_relative_inv_n : forall c p d x xi zi, ABS (rounding_float (Znearest c) p d x) xi -> float_relative_inv_n_helper p d xi zi = true -> REL (rounding_float (Znearest c) p d x) x zi. Proof with auto with typeclass_instances. intros c p d x xi zi Hx Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3). generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). generalize (Flt2_correct _ _ H1). unfold float2R. simpl. rewrite F2R_bpow. clear H1. intro H1. generalize (Fle2_correct _ _ H2). unfold float2R. simpl. rewrite (F2R_Zopp _ 1%Z), F2R_bpow. clear H2. intro H2. generalize (Fle2_correct _ _ H3). unfold float2R. simpl. rewrite F2R_bpow. clear H3. intro H3. exists ((rounding_float (Znearest c) p d x - x) / x)%R. split. assert (Rabs ((rounding_float (Znearest c) p d x - x) / x) <= bpow radix2 (- Zpos p))%R. apply float_relative_inv_n_whole. apply Rlt_le_trans with (1 := H1). apply Hx. split. apply Rle_trans with (1 := H2). apply Ropp_le_cancel. rewrite Ropp_involutive. apply Rle_trans with (2 := H). rewrite <- Rabs_Ropp. apply Rabs_idem. apply Rle_trans with (2 := H3). apply Rle_trans with (2 := H). apply Rabs_idem. field. intros H. apply Rlt_not_le with (1 := H1). apply Rle_trans with (1 := proj1 (proj2 Hx)). rewrite H, round_0, Rabs_R0... apply bpow_ge_0. Qed. Definition float_relative_inv_ne := float_relative_inv_n (fun x => negb (Z.even x)). Definition float_relative_inv_na := float_relative_inv_n (Zle_bool 0). Definition rel_of_fix_float_n_helper (p : positive) (d xn : Z) (zi : FF) := Zle_bool d xn && Fle2 (lower zi) (Float2 (-1) (Zneg p)) && Fle2 (Float2 1 (Zneg p)) (upper zi). Theorem rel_of_fix_float_n : forall c p d xn x zi, FIX x xn -> rel_of_fix_float_n_helper p d xn zi = true -> REL (rounding_float (Znearest c) p d x) x zi. Proof with auto with typeclass_instances. intros c p d xn x zi ((mx, ex), (Hx1, Hx2)) Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3). generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). generalize (Zle_bool_imp_le _ _ H1). clear H1. intro H1. generalize (Fle2_correct _ _ H2). unfold float2R. simpl. rewrite (F2R_Zopp _ 1%Z), F2R_bpow. clear H2. intro H2. generalize (Fle2_correct _ _ H3). unfold float2R. simpl. rewrite F2R_bpow. clear H3. intro H3. destruct (Rle_or_lt (Rabs x) (bpow radix2 (d + Zpos p))) as [He|He]. (* *) rewrite round_generic... exists 0%R. repeat split. apply Rle_trans with (1 := H2). rewrite <- Ropp_0. apply Ropp_le_contravar. apply bpow_ge_0. apply Rle_trans with (2 := H3). apply bpow_ge_0. now rewrite Rplus_0_r, Rmult_1_r. apply generic_format_FLT_FIX... rewrite <- Hx1. apply generic_format_F2R. intros _. now apply Z.le_trans with xn. (* *) exists ((rounding_float (Znearest c) p d x - x) / x)%R. assert (Rabs ((rounding_float (Znearest c) p d x - x) / x) <= bpow radix2 (- Zpos p))%R. apply float_relative_n_whole. apply Rlt_le. apply Rlt_trans with (2 := He). apply bpow_lt. pattern (d + Zpos p)%Z at 2 ; rewrite <- Zplus_0_r. now apply Zplus_lt_compat_l. repeat split. apply Rle_trans with (1 := H2). apply Ropp_le_cancel. rewrite Ropp_involutive. apply Rle_trans with (2 := H). rewrite <- Rabs_Ropp. apply Rabs_idem. apply Rle_trans with (2 := H3). apply Rle_trans with (2 := H). apply Rabs_idem. field. intros H0. apply Rlt_not_le with (1 := He). rewrite H0, Rabs_R0. apply bpow_ge_0. Qed. Definition rel_of_fix_float_ne := rel_of_fix_float_n (fun x => negb (Z.even x)). Definition rel_of_fix_float_na := rel_of_fix_float_n (Zle_bool 0). Definition rel_of_fix_float_zr_helper (p : positive) (d xn : Z) (zi : FF) := Zle_bool d xn && Fle2 (lower zi) (Float2 (-1) (Zneg p + 1)) && Fpos0 (upper zi). Theorem rel_of_fix_float_zr : forall p d xn x zi, FIX x xn -> rel_of_fix_float_zr_helper p d xn zi = true -> REL (rounding_float rndZR p d x) x zi. Proof with auto with typeclass_instances. intros p d xn x zi ((mx, ex), (Hx1, Hx2)) Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3). generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). generalize (Zle_bool_imp_le _ _ H1). clear H1. intro H1. generalize (Fle2_correct _ _ H2). unfold float2R. simpl. rewrite (F2R_Zopp _ 1%Z), F2R_bpow. clear H2. intro H2. generalize (Fpos0_correct _ H3). clear H3. intro H3. destruct (Rle_or_lt (Rabs x) (bpow radix2 (d + Zpos p))) as [He|He]. - rewrite round_generic... + exists 0%R. split. 2: ring. refine (conj _ H3). apply Rle_trans with (1 := H2). rewrite <- Ropp_0. apply Ropp_le_contravar. apply bpow_ge_0. + apply generic_format_FLT_FIX... rewrite <- Hx1. apply generic_format_F2R. intros _. now apply Z.le_trans with xn. - exists ((rounding_float Ztrunc p d x - x) / x)%R. assert (Zx: (x <> 0)%R). { intros H0. apply Rlt_not_le with (1 := He). rewrite H0, Rabs_R0. apply bpow_ge_0. } split. 2: now field. split. { apply Rle_trans with (1 := H2). refine (proj1 (Rabs_le_inv _ _ _)). apply float_relative_whole... apply Rlt_le, Rlt_trans with (2 := He). apply bpow_lt. lia. } apply Rle_trans with (2 := H3). now apply float_relative_zr_whole. Qed. Definition rel_of_fix_float_helper (p : positive) (d xn : Z) (zi : FF) := Zle_bool d xn && Fle2 (lower zi) (Float2 (-1) (Zneg p + 1)) && Fle2 (Float2 1 (Zneg p + 1)) (upper zi). Theorem rel_of_fix_float : forall m, Valid_rnd m -> forall p d xn x zi, FIX x xn -> rel_of_fix_float_helper p d xn zi = true -> REL (rounding_float m p d x) x zi. Proof with auto with typeclass_instances. intros m Hm p d xn x zi ((mx, ex), (Hx1, Hx2)) Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3). generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). generalize (Zle_bool_imp_le _ _ H1). clear H1. intro H1. generalize (Fle2_correct _ _ H2). unfold float2R. simpl. rewrite (F2R_Zopp _ 1%Z), F2R_bpow. clear H2. intro H2. generalize (Fle2_correct _ _ H3). unfold float2R. simpl. rewrite F2R_bpow. clear H3. intro H3. destruct (Rle_or_lt (Rabs x) (bpow radix2 (d + Zpos p))) as [He|He]. - rewrite round_generic... + exists 0%R. split. 2: ring. split. apply Rle_trans with (1 := H2). rewrite <- Ropp_0. apply Ropp_le_contravar. apply bpow_ge_0. apply Rle_trans with (2 := H3). apply bpow_ge_0. + apply generic_format_FLT_FIX... rewrite <- Hx1. apply generic_format_F2R. intros _. now apply Z.le_trans with xn. - exists ((rounding_float m p d x - x) / x)%R. assert (Zx: (x <> 0)%R). { intros H0. apply Rlt_not_le with (1 := He). rewrite H0, Rabs_R0. apply bpow_ge_0. } split. 2: now field. simple refine (_ (float_relative_whole m Hm p d x _)). 2: { apply Rlt_le, Rlt_trans with (2 := He). apply bpow_lt. lia. } intros H. apply Rabs_le_inv in H. split. + now apply Rle_trans with (1 := H2). + now apply Rle_trans with (2 := H3). Qed. Definition rel_of_fix_float_up := rel_of_fix_float rndUP _. Definition rel_of_fix_float_dn := rel_of_fix_float rndDN _. Theorem fix_float_of_fix : forall rdir {Hrnd : Valid_rnd rdir} p d xn zn x, FIX x xn -> Zle_bool zn xn = true -> FIX (rounding_float rdir p d x) zn. Proof with auto with typeclass_instances. intros rdir Hrnd p d xn zn x Hx Hb. generalize (Zle_bool_imp_le _ _ Hb). clear Hb. intro H1. apply FIX_iff_generic. apply generic_round_generic... apply FIX_iff_generic. now apply fix_le with xn. Qed. Theorem fix_floatx_of_fix : forall rdir {Hrnd : Valid_rnd rdir} p xn zn x, FIX x xn -> Zle_bool zn xn = true -> FIX (rounding_floatx rdir p x) zn. Proof with auto with typeclass_instances. intros rdir Hrnd p xn zn x Hx Hb. generalize (Zle_bool_imp_le _ _ Hb). clear Hb. intro H1. apply FIX_iff_generic. apply generic_round_generic... apply FIX_iff_generic. now apply fix_le with xn. Qed. Theorem flt_float_of_flt : forall rdir {Hrnd : Valid_rnd rdir} p d xn zn x, FLT x xn -> Zle_bool (Zpos xn) (Zpos zn) = true -> FLT (rounding_float rdir p d x) zn. Proof with auto with typeclass_instances. intros rdir Hrnd p d xn zn x H Hb. generalize (Zle_bool_imp_le _ _ Hb). clear Hb. intro H1. apply FLT_iff_generic. apply generic_round_generic... apply FLT_iff_generic. now apply flt_le with xn. Qed. Theorem flt_floatx_of_flt : forall rdir {Hrnd : Valid_rnd rdir} p xn zn x, FLT x xn -> Zle_bool (Zpos xn) (Zpos zn) = true -> FLT (rounding_floatx rdir p x) zn. Proof with auto with typeclass_instances. intros rdir Hrnd p xn zn x H Hb. generalize (Zle_bool_imp_le _ _ Hb). clear Hb. intro H1. apply FLT_iff_generic. apply generic_round_generic... apply FLT_iff_generic. now apply flt_le with xn. Qed. Lemma Znearest_IZR : forall c n, Znearest c (IZR n) = n. Proof. intros c n. destruct (Znearest_DN_or_UP c (IZR n)) as [-> | ->]. apply Zfloor_IZR. apply Zceil_IZR. Qed. Lemma ZnearestE_opp : forall x, ZnearestE (- x) = (- ZnearestE x)%Z. Proof. intros x. rewrite Znearest_opp. apply f_equal. unfold Znearest. destruct Rcompare ; try easy. rewrite negb_involutive. rewrite Z.even_opp. rewrite Z.negb_even. now rewrite <- Z.even_succ. Qed. Lemma round_NE_FLX_mult_bpow : forall p x y, FLT y 1 -> Generic_fmt.round radix2 (FLX_exp p) rndNE (y * x) = (y * Generic_fmt.round radix2 (FLX_exp p) rndNE x)%R. Proof. intros p x y [[my ey] [Hy1 Hy2]]. unfold Generic_fmt.round, scaled_mantissa, cexp, FLX_exp. simpl in Hy2. unfold rndNE. destruct (Req_dec x 0) as [-> |Zx]. { rewrite Rmult_0_r, Rmult_0_l. rewrite Znearest_IZR, F2R_0. apply eq_sym, Rmult_0_r. } rewrite <- Hy1. assert (Hy: my = 0%Z \/ my = (-1)%Z \/ my = 1%Z) by lia. clear -Zx Hy. unfold float2R. cbn. destruct Hy as [-> |[-> | ->]]. - rewrite F2R_0, !Rmult_0_l. rewrite Znearest_IZR. apply F2R_0. - unfold F2R. cbn. replace (-1 * bpow radix2 ey * x)%R with ((-x) * bpow radix2 ey)%R by ring. rewrite mag_mult_bpow. rewrite mag_opp. replace (mag radix2 x + ey - p)%Z with (mag radix2 x - p + ey)%Z by ring. rewrite bpow_plus. rewrite <- !Ropp_mult_distr_l. rewrite ZnearestE_opp, opp_IZR. replace (- (mag radix2 x - p + ey))%Z with (- ey + - (mag radix2 x - p))%Z by ring. rewrite bpow_plus. rewrite (Rmult_assoc x), <- (Rmult_assoc (bpow radix2 ey)). rewrite <- bpow_plus, Z.add_opp_diag_r, Rmult_1_l. ring. contradict Zx. rewrite <- (Ropp_involutive x), Zx. apply Ropp_0. - unfold F2R. cbn. rewrite Rmult_1_l. rewrite (Rmult_comm (bpow radix2 ey)). rewrite mag_mult_bpow by easy. replace (mag radix2 x + ey - p)%Z with (mag radix2 x - p + ey)%Z by ring. rewrite bpow_plus. replace (- (mag radix2 x - p + ey))%Z with (- ey + - (mag radix2 x - p))%Z by ring. rewrite bpow_plus. rewrite (Rmult_assoc x), <- (Rmult_assoc (bpow radix2 ey)). rewrite <- bpow_plus, Z.add_opp_diag_r, Rmult_1_l. ring. Qed. Definition lin_floatx_error_of_lin_flt_wide_ne_helper (p : positive) (xi : FF) (zi : FF) := let u := Fmag xi in let e := (floatx_ulp p (Fnum u) (Fexp u) - 2)%Z in Fle2 u (Float2 (Zpos (xI (shift_pos p xH))) e) && Fle2 (lower zi) (Float2 (-1) e) && Fle2 (Float2 1 e) (upper zi). Theorem lin_floatx_error_of_lin_flt_wide_ne : forall p x y xi zi, LIN x y xi -> FLT y 1 -> lin_floatx_error_of_lin_flt_wide_ne_helper p xi zi = true -> LIN (rounding_floatx rndNE p x - x) y zi. Proof with auto with typeclass_instances. intros p x' y xi zi [x [Hx1 Hx2]] Hy Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H4). generalize (andb_prop _ _ Hb). clear Hb. intros (H2,H3). generalize (Fle2_correct _ _ H2). unfold float2R at 2. simpl. clear H2. intro H2. generalize (Fle2_correct _ _ H3). unfold float2R at 2. simpl. rewrite (F2R_Zopp _ 1%Z), F2R_bpow. clear H3. intro H3. generalize (Fle2_correct _ _ H4). unfold float2R at 1. simpl. rewrite F2R_bpow. clear H4. intro H4. simple refine (let H := floatx_error_wide_n (fun x => negb (Z.even x)) p x (Fmag xi) (conj _ H2) in _). 2: clearbody H. now apply Fmag_correct. clear H2. set (e := (floatx_ulp p (Fnum (Fmag xi)) (Fexp (Fmag xi)) - 2)%Z) in H, H3, H4. exists (rounding_floatx rndNE p x - x)%R. split. - split. + apply Rle_trans with (1 := H3). apply Ropp_le_cancel. rewrite Ropp_involutive. apply Rle_trans with (2 := H). rewrite <- Rabs_Ropp. apply Rabs_idem. + apply Rle_trans with (2 := H4). apply Rle_trans with (2 := H). apply Rabs_idem. - rewrite Hx2. rewrite round_NE_FLX_mult_bpow with (1 := Hy). ring. Qed. Theorem lin_floatx_round_of_lin_flt_ne : forall p x y xi zi, LIN x y xi -> FLT y 1 -> round_helper (round roundNE (FLX_exp (Zpos p))) xi zi = true -> LIN (rounding_floatx rndNE p x) y zi. Proof with auto with typeclass_instances. intros p x' y xi zi [x [Hx1 Hx2]] Hy Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). generalize (Fle2_correct _ _ H1). rewrite rndG_conversion. clear H1. intro H1. generalize (Fle2_correct _ _ H2). rewrite rndG_conversion. clear H2. intro H2. exists (rounding_floatx (rndG_f roundNE_cs) p x)%R. split. 2: { rewrite Hx2. now apply round_NE_FLX_mult_bpow. } split. - apply Rle_trans with (1 := H1). apply round_le... apply Hx1. - apply Rle_trans with (2 := H2). apply round_le... apply Hx1. Qed. Definition lin_float_error_of_lin_abs_n_helper (p : positive) (d : Z) (xi yi zi : FF) := Fle2 (Fmult2 (lower yi) (lower zi)) (Float2 (-1) (d-1)) && Fle2 (Float2 1 (d-1)) (Fmult2 (lower yi) (upper zi)) && Fle2 (lower zi) (Fmult2 (upper xi) (Float2 (-1) (Zneg p))) && Fle2 (lower zi) (Fmult2 (lower xi) (Float2 1 (Zneg p))) && Fle2 (Fmult2 (upper xi) (Float2 1 (Zneg p))) (upper zi) && Fle2 (Fmult2 (lower xi) (Float2 (-1) (Zneg p))) (upper zi). Theorem lin_float_error_of_lin_abs_n : forall c p d x y xi yi zi, LIN x y xi -> ABS y yi -> lin_float_error_of_lin_abs_n_helper p d xi yi zi = true -> LIN (rounding_float (Znearest c) p d x - x) y zi. Proof with auto with typeclass_instances. intros c p d x' y xi yi zi [x [Hx1 Hx2]] [Hy1 Hy2] Hb. generalize (andb_prop _ _ Hb). clear Hb. intros [Hb H6]. generalize (andb_prop _ _ Hb). clear Hb. intros [Hb H5]. generalize (andb_prop _ _ Hb). clear Hb. intros [Hb H4]. generalize (andb_prop _ _ Hb). clear Hb. intros [Hb H3]. generalize (andb_prop _ _ Hb). clear Hb. intros [H1 H2]. generalize (Fle2_correct _ _ H1). rewrite Fmult2_correct. unfold float2R at 3. simpl. rewrite (F2R_Zopp _ 1%Z), F2R_bpow. clear H1. intro H1. generalize (Fle2_correct _ _ H2). rewrite Fmult2_correct. unfold float2R at 1. simpl. rewrite F2R_bpow. clear H2. intro H2. generalize (Fle2_correct _ _ H3). rewrite Fmult2_correct. unfold float2R at 3. simpl. rewrite (F2R_Zopp _ 1%Z), F2R_bpow. clear H3. intro H3. generalize (Fle2_correct _ _ H4). rewrite Fmult2_correct. unfold float2R at 3. simpl. rewrite F2R_bpow. clear H4. intro H4. generalize (Fle2_correct _ _ H5). rewrite Fmult2_correct. unfold float2R at 2. simpl. rewrite F2R_bpow. clear H5. intro H5. generalize (Fle2_correct _ _ H6). rewrite Fmult2_correct. unfold float2R at 2. simpl. rewrite (F2R_Zopp _ 1%Z), F2R_bpow. clear H6. intro H6. destruct Hy1 as [Hy1|Hy1]. 2: { elim Rle_not_lt with (1 := H1). rewrite <- Hy1, Rmult_0_l, <- Ropp_0. apply Ropp_lt_contravar, bpow_gt_0. } destruct (error_N_FLT radix2 d (Z.pos p) eq_refl c x') as (eps&eta&Heps&Heta&Hee&->). rewrite Hx2. destruct (Rmult_integral _ _ Hee) as [-> | ->]. - exists (eta / y)%R. split. apply Gappa_real.IRdiv_aa with (1 := Hy1) (2 := H1) (3 := H2) (5 := proj1 Hy2). unfold Zminus. rewrite Zplus_comm. now rewrite bpow_plus. field. intros Hy. apply Rlt_not_le with (1 := Hy1). apply Rle_trans with (1 := proj1 Hy2). rewrite Hy, Rabs_R0. apply Rle_refl. - exists (x * eps)%R. split. 2: ring. generalize (Rabs_le_inv _ _ Heps). replace (/2 * bpow radix2 (- Z.pos p + 1))%R with (bpow radix2 (Z.neg p)). 2: { rewrite bpow_plus, bpow_1. simpl Z.opp. set (v := bpow radix2 _). simpl. field. } clear Heps Hee Heta. intros Heps. apply Gappa_real.IRmult_uo with (3 := H3) (4 := H6) (5 := H4) (6 := H5) (7 := Hx1) (8 := Heps). rewrite <- Ropp_0. apply Ropp_le_contravar, bpow_ge_0. apply bpow_ge_0. Qed. Definition lin_float_error_of_lin_abs_ne := lin_float_error_of_lin_abs_n (fun x => negb (Z.even x)). Definition lin_float_error_of_lin_abs_na := lin_float_error_of_lin_abs_n (Zle_bool 0). coq-gappalib-coq-1.10.0-df59b68361b1efbd697b17c40f7fae4a35991c44/src/Gappa_library.v000066400000000000000000000011131517666064600262150ustar00rootroot00000000000000From Coq Require Export Rdefinitions. From Coq Require Export Rbasic_fun. From Coq Require Export R_sqrt. From Coq Require Export Bool. Require Export Gappa_definitions. Require Export Gappa_tree. Require Export Gappa_pred_bnd. Require Export Gappa_pred_abs. Require Export Gappa_pred_fixflt. Require Export Gappa_pred_nzr. Require Export Gappa_pred_rel. Require Export Gappa_pred_lin. Require Export Gappa_rewriting. Require Export Gappa_round_def. Require Export Gappa_fixed. Require Export Gappa_float. Require Export Gappa_user. Ltac finalize := vm_cast_no_check (refl_equal true). coq-gappalib-coq-1.10.0-df59b68361b1efbd697b17c40f7fae4a35991c44/src/Gappa_obfuscate.v000066400000000000000000000023251517666064600265320ustar00rootroot00000000000000(* This file forces Coq to use full locations to address Gappa constants with the same names, hence avoiding potential conflicts with user constants. *) Definition Float1 := 0. Definition float2 := 0. Definition Float2 := 0. Definition float2R := 0. Definition float10 := 0. Definition Float10 := 0. Definition float10R := 0. Definition FF := 0. Definition makepairF := 0. Definition BND := 0. Definition ABS := 0. Definition REL := 0. Definition FIX := 0. Definition FLT := 0. Definition NZR := 0. Definition contradiction := 0. Definition rounding_float := 0. Definition rounding_fixed := 0. Definition roundZR := 0. Definition roundAW := 0. Definition roundUP := 0. Definition roundDN := 0. Definition roundOD := 0. Definition roundNE := 0. Definition roundNO := 0. Definition roundNZ := 0. Definition roundNA := 0. Definition roundNU := 0. Definition roundND := 0. Definition R := 0. Definition Rle := 0. Definition Ropp := 0. Definition Rplus := 0. Definition Rminus := 0. Definition Rmult := 0. Definition Rdiv := 0. Definition Rabs := 0. Definition sqrt := 0. Definition R0 := 0. Definition R1 := 0. Definition xH := 0. Definition xI := 0. Definition xO := 0. Definition Zpos := 0. Definition Zneg := 0. Definition Z0 := 0. coq-gappalib-coq-1.10.0-df59b68361b1efbd697b17c40f7fae4a35991c44/src/Gappa_pred_abs.v000066400000000000000000000321541517666064600263410ustar00rootroot00000000000000Require Import Gappa_common. Require Import Gappa_pred_nzr. Lemma Rabs_def2b : forall x a : R, (Rabs x <= a)%R -> (-a <= x <= a)%R. Proof. intros x a H. split. case (Rcase_abs x); intros. rewrite Rabs_left with (1 := r) in H. rewrite <- (Ropp_involutive x). apply Ropp_le_contravar with (1 := H). apply Rle_trans with 0%R. rewrite <- Ropp_0. apply Ropp_le_contravar. apply Rle_trans with (2 := H). apply Rabs_pos. apply Rge_le with (1 := r). apply Rle_trans with (2 := H). apply RRle_abs. Qed. Theorem neg_a : forall x : R, forall zi : FF, ABS x zi -> ABS (-x) zi. Proof. intros x zi Hx. unfold ABS. now rewrite Rabs_Ropp. Qed. Theorem abs_a : forall x : R, forall zi : FF, ABS x zi -> ABS (Rabs x) zi. Proof. intros x zi Hx. unfold ABS. now rewrite Rabs_Rabsolu. Qed. Definition bnd_of_abs_helper (xi zi : FF) := Fle2 (lower zi) (Fopp2 (upper xi)) && Fle2 (upper xi) (upper zi). Theorem bnd_of_abs : forall x : R, forall xi zi : FF, ABS x xi -> bnd_of_abs_helper xi zi = true -> BND x zi. Proof. intros x xi zi Hx Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). generalize (Fle2_correct _ _ H1). rewrite Fopp2_correct. fold float2R. clear H1. intro H1. generalize (Fle2_correct _ _ H2). clear H2. intro H2. assert (H : (-(upper xi) <= x <= (upper xi))%R). apply (Rabs_def2b _ _ (proj2 (proj2 Hx))). split. apply Rle_trans with (1 := H1) (2 := proj1 H). apply Rle_trans with (1 := proj2 H) (2 := H2). Qed. Theorem abs_of_uabs : forall x : R, forall zi : FF, BND (Rabs x) zi -> Fpos0 (lower zi) = true -> ABS x zi. Proof. intros x zi Hx Hb. generalize (Fpos0_correct _ Hb). clear Hb. intro H1. exact (conj H1 Hx). Qed. Theorem uabs_of_abs : forall x : R, forall zi : FF, ABS x zi -> BND (Rabs x) zi. Proof. intros x zi (_,Hx2). exact Hx2. Qed. Definition abs_of_bnd_p_helper (xi zi : FF) := Fpos0 (lower zi) && Fle2 (lower zi) (lower xi) && Fle2 (upper xi) (upper zi). Theorem abs_of_bnd_p : forall x : R, forall xi zi : FF, BND x xi -> abs_of_bnd_p_helper xi zi = true -> ABS x zi. Proof. intros x xi zi Hx Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3). generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). generalize (Fpos0_correct _ H1). clear H1. intro H1. generalize (Fle2_correct _ _ H2). clear H2. intro H2. generalize (Fle2_correct _ _ H3). clear H3. intro H3. split. exact H1. apply IRabs_p with (2 := H2) (3 := H3) (4 := Hx). apply Rle_trans with (1 := H1) (2 := H2). Qed. Definition abs_of_bnd_o_helper (xi zi : FF) := Fis0 (lower zi) && Fle2 (upper xi) (upper zi) && Fle2 (Fopp2 (lower xi)) (upper zi). Theorem abs_of_bnd_o : forall x : R, forall xi zi : FF, BND x xi -> abs_of_bnd_o_helper xi zi = true -> ABS x zi. Proof. intros x xi zi Hx Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3). generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). generalize (Fis0_correct _ H1). clear H1. intro H1. generalize (Fle2_correct _ _ H2). clear H2. intro H2. generalize (Fle2_correct _ _ H3). rewrite Fopp2_correct. clear H3. intro H3. split. rewrite H1. apply Rle_refl. apply IRabs_o with (2 := H3) (3 := H2) (4 := Hx). rewrite H1. apply Rle_refl. Qed. Definition abs_of_bnd_n_helper (xi zi : FF) := Fpos0 (lower zi) && Fle2 (lower zi) (Fopp2 (upper xi)) && Fle2 (Fopp2 (lower xi)) (upper zi). Theorem abs_of_bnd_n : forall x : R, forall xi zi : FF, BND x xi -> abs_of_bnd_n_helper xi zi = true -> ABS x zi. Proof. intros x xi zi Hx Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3). generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). generalize (Fpos0_correct _ H1). clear H1. intro H1. generalize (Fle2_correct _ _ H2). rewrite Fopp2_correct. clear H2. intro H2. generalize (Fle2_correct _ _ H3). rewrite Fopp2_correct. clear H3. intro H3. split. exact H1. apply IRabs_n with (2 := H2) (3 := H3) (4 := Hx). apply Ropp_le_cancel. rewrite Ropp_0. apply Rle_trans with (1 := H1) (2 := H2). Qed. Definition abs_subset_helper (xi zi : FF) := Fpos0 (lower zi) && Fle2 (lower zi) (lower xi) && Fle2 (upper xi) (upper zi). Theorem abs_subset : forall x : R, forall xi zi : FF, ABS x xi -> abs_subset_helper xi zi = true -> ABS x zi. Proof. intros x xi zi (Hx1,Hx2) Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3). generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). generalize (Fpos0_correct _ H1). clear H1. intro H1. generalize (Fle2_correct _ _ H2). clear H2. intro H2. generalize (Fle2_correct _ _ H3). clear H3. intro H3. split. exact H1. apply IRsubset with (1 := H2) (2 := H3) (3 := Hx2). Qed. Definition intersect_aa_helper (xf yf : float2) (zi : FF) := Fpos0 (lower zi) && Fle2 (lower zi) yf && Fle2 xf (upper zi). Theorem intersect_aa : forall z : R, forall xi yi zi : FF, ABS z xi -> ABS z yi -> intersect_aa_helper (upper xi) (lower yi) zi = true -> ABS z zi. Proof. intros z xi yi zi Hx Hy Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3). generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). generalize (Fpos0_correct _ H1). clear H1. intro H1. generalize (Fle2_correct _ _ H2). clear H2. intro H2. generalize (Fle2_correct _ _ H3). clear H3. intro H3. split. exact H1. split. apply Rle_trans with (1 := H2) (2 := proj1 (proj2 Hy)). apply Rle_trans with (1 := proj2 (proj2 Hx)) (2 := H3). Qed. Theorem absurd_intersect_aa : forall z : R, forall xi yi : FF, ABS z xi -> ABS z yi -> Flt2 (upper xi) (lower yi) = true -> False. Proof. intros z xi yi Hx Hy Hb. generalize (Flt2_correct _ _ Hb). clear Hb. intro H. generalize (Rle_lt_trans _ _ _ (proj2 (proj2 Hx)) H). clear H. intro H. generalize (Rlt_le_trans _ _ _ H (proj1 (proj2 Hy))). clear H. intro H. elim (Rlt_irrefl _ H). Qed. Definition mul_aa_helper (xi yi zi : FF) := Fpos0 (lower zi) && Fle2 (lower zi) (Fmult2 (lower xi) (lower yi)) && Fle2 (Fmult2 (upper xi) (upper yi)) (upper zi). Theorem mul_aa : forall x y : R, forall xi yi zi : FF, ABS x xi -> ABS y yi -> mul_aa_helper xi yi zi = true -> ABS (x * y) zi. Proof. intros x y xi yi zi Hx Hy Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3). generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). generalize (Fpos0_correct _ H1). clear H1. intro H1. generalize (Fle2_correct _ _ H2). rewrite Fmult2_correct. clear H2. intro H2. generalize (Fle2_correct _ _ H3). rewrite Fmult2_correct. clear H3. intro H3. unfold ABS in *. split. exact H1. rewrite Rabs_mult. apply IRmult_pp with (lower xi) (upper xi) (lower yi) (upper yi) ; intuition. Qed. Definition div_aa_helper (xi yi zi : FF) := Fpos (lower yi) && Fpos0 (lower zi) && Fle2 (Fmult2 (upper yi) (lower zi)) (lower xi) && Fle2 (upper xi) (Fmult2 (lower yi) (upper zi)). Theorem div_aa : forall x y : R, forall xi yi zi : FF, ABS x xi -> ABS y yi -> div_aa_helper xi yi zi = true -> ABS (x / y) zi. Proof. intros x y xi yi zi Hx Hy Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H4). generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3). generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H2). generalize (Fpos_correct _ Hb). intro H1. generalize (Fpos0_correct _ H2). clear H2. intro H2. generalize (Fle2_correct _ _ H3). rewrite Fmult2_correct. clear H3. intro H3. generalize (Fle2_correct _ _ H4). rewrite Fmult2_correct. clear H4. intro H4. split. exact H2. replace (Rabs (x / y)) with (Rabs x / Rabs y)%R. unfold ABS in *. apply IRdiv_pp with (lower xi) (upper xi) (lower yi) (upper yi); try easy. unfold Rdiv. now rewrite Rabs_mult, Rabs_inv. Qed. Definition add_aa_p_helper (xi yi zi : FF) := Fpos0 (lower zi) && Fle2 (lower zi) (Fminus2 (lower xi) (upper yi)) && Fle2 (Fplus2 (upper xi) (upper yi)) (upper zi). Theorem add_aa_p : forall x y : R, forall xi yi zi : FF, ABS x xi -> ABS y yi -> add_aa_p_helper xi yi zi = true -> ABS (x + y) zi. Proof. intros x y xi yi zi Hx Hy Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3). generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). generalize (Fpos0_correct _ H1). clear H1. intro H1. generalize (Fle2_correct _ _ H2). rewrite Fminus2_correct. clear H2. intro H2. generalize (Fle2_correct _ _ H3). rewrite Fplus2_correct. clear H3. intro H3. split. exact H1. split. apply Rle_trans with (Rabs x - Rabs y)%R. apply Rle_trans with (1 := H2). unfold Rminus. apply Rplus_le_compat with (1 := proj1 (proj2 Hx)). apply Ropp_le_contravar with (1 := proj2 (proj2 Hy)). replace (x + y)%R with (x - -y)%R. 2: ring. rewrite<- (Rabs_Ropp y). apply Rabs_triang_inv. apply Rle_trans with (Rabs x + Rabs y)%R. apply Rabs_triang. apply Rle_trans with (2 := H3). apply Rplus_le_compat with (1 := proj2 (proj2 Hx)) (2 := proj2 (proj2 Hy)). Qed. Definition add_aa_o_helper (xi yi zi : FF) := Fis0 (lower zi) && Fle2 (Fplus2 (upper xi) (upper yi)) (upper zi). Theorem add_aa_o : forall x y : R, forall xi yi zi : FF, ABS x xi -> ABS y yi -> add_aa_o_helper xi yi zi = true -> ABS (x + y) zi. Proof. intros x y xi yi zi Hx Hy Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). generalize (Fis0_correct _ H1). clear H1. intro H1. generalize (Fle2_correct _ _ H2). rewrite Fplus2_correct. clear H2. intro H2. split. auto with real. split. rewrite H1. apply Rabs_pos. apply Rle_trans with (Rabs x + Rabs y)%R. apply Rabs_triang. apply Rle_trans with (2 := H2). apply Rplus_le_compat with (1 := proj2 (proj2 Hx)) (2 := proj2 (proj2 Hy)). Qed. Definition add_aa_n_helper (xi yi zi : FF) := Fpos0 (lower zi) && Fle2 (lower zi) (Fminus2 (lower yi) (upper xi)) && Fle2 (Fplus2 (upper xi) (upper yi)) (upper zi). Theorem add_aa_n : forall x y : R, forall xi yi zi : FF, ABS x xi -> ABS y yi -> add_aa_n_helper xi yi zi = true -> ABS (x + y) zi. Proof. intros x y xi yi zi Hx Hy Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3). generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). generalize (Fpos0_correct _ H1). clear H1. intro H1. generalize (Fle2_correct _ _ H2). rewrite Fminus2_correct. clear H2. intro H2. generalize (Fle2_correct _ _ H3). rewrite Fplus2_correct. clear H3. intro H3. split. exact H1. split. apply Rle_trans with (Rabs y - Rabs x)%R. apply Rle_trans with (1 := H2). unfold Rminus. apply Rplus_le_compat with (1 := proj1 (proj2 Hy)). apply Ropp_le_contravar with (1 := proj2 (proj2 Hx)). replace (x + y)%R with (y - -x)%R. 2: ring. rewrite<- (Rabs_Ropp x). apply Rabs_triang_inv. apply Rle_trans with (Rabs x + Rabs y)%R. apply Rabs_triang. apply Rle_trans with (2 := H3). apply Rplus_le_compat with (1 := proj2 (proj2 Hx)) (2 := proj2 (proj2 Hy)). Qed. Theorem sub_aa_p : forall x y : R, forall xi yi zi : FF, ABS x xi -> ABS y yi -> add_aa_p_helper xi yi zi = true -> ABS (x - y) zi. Proof. intros x y xi yi zi Hx Hy Hb. unfold Rminus. apply add_aa_p with xi yi. exact Hx. unfold ABS. rewrite Rabs_Ropp. exact Hy. exact Hb. Qed. Theorem sub_aa_o : forall x y : R, forall xi yi zi : FF, ABS x xi -> ABS y yi -> add_aa_o_helper xi yi zi = true -> ABS (x - y) zi. Proof. intros x y xi yi zi Hx Hy Hb. unfold Rminus. apply add_aa_o with xi yi. exact Hx. unfold ABS. rewrite Rabs_Ropp. exact Hy. exact Hb. Qed. Theorem sub_aa_n : forall x y : R, forall xi yi zi : FF, ABS x xi -> ABS y yi -> add_aa_n_helper xi yi zi = true -> ABS (x - y) zi. Proof. intros x y xi yi zi Hx Hy Hb. unfold Rminus. apply add_aa_n with xi yi. exact Hx. unfold ABS. rewrite Rabs_Ropp. exact Hy. exact Hb. Qed. Definition bnd_of_bnd_abs_p_helper (xi yi zi : FF) := Flt2 (Fopp2 (lower yi)) (lower xi) && Fle2 (lower zi) (lower yi) && Fle2 (upper xi) (upper zi). Theorem bnd_of_bnd_abs_p : forall x : R, forall xi yi zi : FF, BND x xi -> ABS x yi -> bnd_of_bnd_abs_p_helper xi yi zi = true -> BND x zi. Proof. intros x xi yi zi Hx Hy Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3). generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). generalize (Flt2_correct _ _ H1). rewrite Fopp2_correct. fold float2R. clear H1. intro H1. generalize (Fle2_correct _ _ H2). clear H2. intro H2. generalize (Fle2_correct _ _ H3). clear H3. intro H3. case (Rcase_abs x) ; intro H. unfold ABS in Hy. rewrite (Rabs_left _ H) in Hy. elim (Rlt_not_le (lower xi) x). 2: exact (proj1 Hx). apply Rle_lt_trans with (2 := H1). apply Ropp_le_cancel. rewrite Ropp_involutive. exact (proj1 (proj2 Hy)). unfold ABS in Hy. rewrite (Rabs_right _ H) in Hy. split. apply Rle_trans with (1 := H2) (2 := proj1 (proj2 Hy)). apply Rle_trans with (1 := proj2 Hx) (2 := H3). Qed. Definition bnd_of_bnd_abs_n_helper (xi yi zi : FF) := Flt2 (upper xi) (lower yi) && Fle2 (lower zi) (lower xi) && Fle2 (Fopp2 (lower yi)) (upper zi). Theorem bnd_of_bnd_abs_n : forall x : R, forall xi yi zi : FF, BND x xi -> ABS x yi -> bnd_of_bnd_abs_n_helper xi yi zi = true -> BND x zi. Proof. intros x xi yi zi Hx Hy Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3). generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). generalize (Flt2_correct _ _ H1). clear H1. intro H1. generalize (Fle2_correct _ _ H2). clear H2. intro H2. generalize (Fle2_correct _ _ H3). rewrite Fopp2_correct. fold float2R. clear H3. intro H3. case (Rcase_abs x) ; intro H. unfold ABS in Hy. rewrite (Rabs_left _ H) in Hy. split. apply Rle_trans with (1 := H2) (2 := proj1 Hx). apply Rle_trans with (2 := H3). apply Ropp_le_cancel. rewrite Ropp_involutive. exact (proj1 (proj2 Hy)). unfold ABS in Hy. rewrite (Rabs_right _ H) in Hy. elim (Rlt_not_le x (upper xi)). 2: exact (proj2 Hx). apply Rlt_le_trans with (1 := H1) (2 := proj1 (proj2 Hy)). Qed. coq-gappalib-coq-1.10.0-df59b68361b1efbd697b17c40f7fae4a35991c44/src/Gappa_pred_bnd.v000066400000000000000000000630571517666064600263450ustar00rootroot00000000000000Require Import Gappa_common. Require Import Gappa_decimal. Definition Float1 := IZR. Definition constant2_helper (x : float2) (zi : FF) := Fle2 (lower zi) x && Fle2 x (upper zi). Theorem constant2 : forall x : float2, forall zi : FF, constant2_helper x zi = true -> BND x zi. Proof. intros x zi Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). generalize (Fle2_correct _ _ H1). clear H1. intro H1. generalize (Fle2_correct _ _ H2). clear H2. intro H2. split ; assumption. Qed. Theorem constant1 : forall x : Z, forall zi : FF, constant2_helper (Float2 x 0) zi = true -> BND (Float1 x) zi. Proof. intros x zi Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). generalize (Fle2_correct _ _ H1). clear H1. intro H1. generalize (Fle2_correct _ _ H2). clear H2. intro H2. rewrite <- (Rmult_1_r (Float1 x)). change (Float1 x * 1)%R with (float2R (Float2 x 0)). split ; assumption. Qed. Definition constant10_helper (x : float10) (zi : FF) := Dle_fd (lower zi) x && Dle_df x (upper zi). Theorem constant10 : forall x : float10, forall zi : FF, constant10_helper x zi = true -> BND x zi. Proof. intros x zi Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). generalize (Dle_fd_correct _ _ H1). clear H1. intro H1. generalize (Dle_df_correct _ _ H2). clear H2. intro H2. split ; assumption. Qed. Definition subset_helper (xi zi : FF) := Fle2 (lower zi) (lower xi) && Fle2 (upper xi) (upper zi). Theorem subset : forall x : R, forall xi zi : FF, BND x xi -> subset_helper xi zi = true -> BND x zi. Proof. intros x xi zi Hx Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). generalize (Fle2_correct _ _ H1). clear H1. intro H1. generalize (Fle2_correct _ _ H2). clear H2. intro H2. apply IRsubset with (1 := H1) (2 := H2) (3 := Hx). Qed. Theorem subset_l : forall x : R, forall xi : FF, forall f : float2, BND x xi -> Fle2 f (lower xi) = true -> (f <= x)%R. Proof. intros x xi f Hx Hb. generalize (Fle2_correct _ _ Hb). clear Hb. intro H1. apply Rle_trans with (1 := H1). exact (proj1 Hx). Qed. Theorem subset_r : forall x : R, forall xi : FF, forall f : float2, BND x xi -> Fle2 (upper xi) f = true -> (x <= f)%R. Proof. intros x xi f Hx Hb. generalize (Fle2_correct _ _ Hb). clear Hb. intro H1. apply Rle_trans with (2 := H1). exact (proj2 Hx). Qed. Definition intersect_helper (xf yf : float2) (zi : FF) := Fle2 (lower zi) yf && Fle2 xf (upper zi). Theorem intersect : forall z : R, forall xi yi zi : FF, BND z xi -> BND z yi -> intersect_helper (upper xi) (lower yi) zi = true -> BND z zi. Proof. intros z xi yi zi Hx Hy Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). generalize (Fle2_correct _ _ H1). clear H1. intro H1. generalize (Fle2_correct _ _ H2). clear H2. intro H2. split. apply Rle_trans with (1 := H1) (2 := (proj1 Hy)). apply Rle_trans with (1 := (proj2 Hx)) (2 := H2). Qed. Theorem intersect_hb : forall z : R, forall xf : float2, forall yi zi : FF, (z <= xf)%R -> BND z yi -> intersect_helper xf (lower yi) zi = true -> BND z zi. Proof. intros z xf yi zi Hx Hy Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). generalize (Fle2_correct _ _ H1). clear H1. intro H1. generalize (Fle2_correct _ _ H2). clear H2. intro H2. split. apply Rle_trans with (1 := H1) (2 := (proj1 Hy)). apply Rle_trans with (1 := Hx) (2 := H2). Qed. Theorem intersect_bh : forall z : R, forall yf : float2, forall xi zi : FF, BND z xi -> (yf <= z)%R -> intersect_helper (upper xi) yf zi = true -> BND z zi. Proof. intros z yf xi zi Hx Hy Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). generalize (Fle2_correct _ _ H1). clear H1. intro H1. generalize (Fle2_correct _ _ H2). clear H2. intro H2. split. apply Rle_trans with (1 := H1) (2 := Hy). apply Rle_trans with (1 := (proj2 Hx)) (2 := H2). Qed. Theorem intersect_hh : forall z : R, forall xf yf : float2, forall zi : FF, (z <= xf)%R -> (yf <= z)%R -> intersect_helper xf yf zi = true -> BND z zi. Proof. intros z xf yf zi Hx Hy Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). apply Fle2_correct in H1. apply Fle2_correct in H2. split. apply Rle_trans with (1 := H1) (2 := Hy). apply Rle_trans with (1 := Hx) (2 := H2). Qed. Theorem absurd_intersect : forall z : R, forall xi yi : FF, BND z xi -> BND z yi -> Flt2 (upper xi) (lower yi) = true -> False. Proof. intros z xi yi Hx Hy Hb. generalize (Flt2_correct _ _ Hb). clear Hb. intro H. generalize (Rle_lt_trans _ _ _ (proj2 Hx) H). clear H. intro H. generalize (Rlt_le_trans _ _ _ H (proj1 Hy)). clear H. intro H. elim (Rlt_irrefl _ H). Qed. Theorem absurd_intersect_hb : forall z : R, forall xf : float2, forall yi : FF, (z <= xf)%R -> BND z yi -> Flt2 xf (lower yi) = true -> False. Proof. intros z xi yi Hx Hy Hb. generalize (Flt2_correct _ _ Hb). clear Hb. intro H. generalize (Rle_lt_trans _ _ _ Hx H). clear H. intro H. generalize (Rlt_le_trans _ _ _ H (proj1 Hy)). clear H. intro H. elim (Rlt_irrefl _ H). Qed. Theorem absurd_intersect_bh : forall z : R, forall xi : FF, forall yf : float2, BND z xi -> (yf <= z)%R -> Flt2 (upper xi) yf = true -> False. Proof. intros z xi yi Hx Hy Hb. generalize (Flt2_correct _ _ Hb). clear Hb. intro H. generalize (Rle_lt_trans _ _ _ (proj2 Hx) H). clear H. intro H. generalize (Rlt_le_trans _ _ _ H Hy). clear H. intro H. elim (Rlt_irrefl _ H). Qed. Theorem union : forall (x : R) (xl : float2) (P : Prop), (Rle x xl -> P) -> (Rle xl x -> P) -> P. Proof. intros x xl P H1 H2. destruct (Rlt_le_dec x xl) as [H|H]. apply H1. now apply Rlt_le. now apply H2. Qed. Theorem union' : forall (x : R) (xi : FF) (P : Prop), (BND x xi -> P) -> (Rle (upper xi) x -> P) -> Rle (lower xi) x -> P. Proof. intros x xi P H1 H2 Hx. destruct (Rlt_le_dec x (upper xi)) as [H|H]. apply H1. apply (conj Hx). now apply Rlt_le. now apply H2. Qed. Definition eql_of_cst_helper (xi yi : FF) := Feq2 (lower xi) (upper yi) && Feq2 (upper xi) (lower yi). Theorem eql_of_cst : forall x y : R, forall xi yi : FF, BND x xi -> BND y yi -> eql_of_cst_helper xi yi = true -> x = y. Proof. intros x y xi yi Hx Hy Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). generalize (Feq2_correct _ _ H1). clear H1. intro H1. generalize (Feq2_correct _ _ H2). clear H2. intro H2. apply Rle_antisym. apply Rle_trans with (1 := proj2 Hx). rewrite H2. apply Hy. apply Rle_trans with (1 := proj2 Hy). rewrite <- H1. apply Hx. Qed. Definition neg_helper (xi zi : FF) := Fle2 (lower zi) (Fopp2 (upper xi)) && Fle2 (Fopp2 (lower xi)) (upper zi). Theorem neg : forall x : R, forall xi zi : FF, BND x xi -> neg_helper xi zi = true -> BND (-x) zi. Proof. intros x xi zi Hx Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). generalize (Fle2_correct _ _ H1). rewrite Fopp2_correct. clear H1. intro H1. generalize (Fle2_correct _ _ H2). rewrite Fopp2_correct. clear H2. intro H2. apply IRopp with (1 := H1) (2 := H2) (3 := Hx). Qed. Definition add_helper (xi yi zi : FF) := Fle2 (lower zi) (Fplus2 (lower xi) (lower yi)) && Fle2 (Fplus2 (upper xi) (upper yi)) (upper zi). Theorem add : forall x y : R, forall xi yi zi : FF, BND x xi -> BND y yi -> add_helper xi yi zi = true -> BND (x + y) zi. Proof. intros x y xi yi zi Hx Hy Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). generalize (Fle2_correct _ _ H1). rewrite Fplus2_correct. clear H1. intro H1. generalize (Fle2_correct _ _ H2). rewrite Fplus2_correct. clear H2. intro H2. apply IRplus with (1 := H1) (2 := H2) (3 := Hx) (4 := Hy). Qed. Definition sub_helper (xi yi zi : FF) := Fle2 (lower zi) (Fminus2 (lower xi) (upper yi)) && Fle2 (Fminus2 (upper xi) (lower yi)) (upper zi). Theorem sub : forall x y : R, forall xi yi zi : FF, BND x xi -> BND y yi -> sub_helper xi yi zi = true -> BND (x - y) zi. Proof. intros x y xi yi zi Hx Hy Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). generalize (Fle2_correct _ _ H1). rewrite Fminus2_correct. clear H1. intro H1. generalize (Fle2_correct _ _ H2). rewrite Fminus2_correct. clear H2. intro H2. apply IRminus with (1 := H1) (2 := H2) (3 := Hx) (4 := Hy). Qed. Definition not_zero (zi : FF) := Fpos (lower zi) || Fneg (upper zi). Lemma not_zero_correct : forall z : R, forall zi : FF, BND z zi -> not_zero zi = true -> (z <> 0)%R. Proof. intros z zi Hz Hb. apply Rlt_dichotomy_converse. generalize (orb_prop _ _ Hb). clear Hb. intro H. elim H; clear H; intro H. right. generalize (Fpos_correct _ H). clear H. intro H. unfold Rgt. apply Rlt_le_trans with (1 := H). exact (proj1 Hz). left. generalize (Fneg_correct _ H). clear H. intro H. apply Rle_lt_trans with (2 := H). exact (proj2 Hz). Qed. Definition contains_zero_helper (zi : FF) := Fneg0 (lower zi) && Fpos0 (upper zi). Lemma contains_zero : forall zi : FF, contains_zero_helper zi = true -> BND 0 zi. Proof. intros zi Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). generalize (Fneg0_correct _ H1). clear H1. intro H1. generalize (Fpos0_correct _ H2). clear H2. intro H2. split ; assumption. Qed. Lemma sub_refl : forall x : R, forall zi : FF, contains_zero_helper zi = true -> BND (x - x) zi. Proof. intros x zi Hb. unfold Rminus. rewrite (Rplus_opp_r x). apply contains_zero with (1 := Hb). Qed. Lemma sub_of_eql : forall x y : R, forall zi : FF, x = y -> contains_zero_helper zi = true -> BND (x - y) zi. Proof. intros x y zi E Hb. unfold Rminus. rewrite E, Rplus_opp_r. apply contains_zero with (1 := Hb). Qed. Definition div_refl_helper (zi : FF) := Fle2 (lower zi) (Float2 1 0) && Fle2 (Float2 1 0) (upper zi). Lemma div_refl : forall x : R, forall zi : FF, NZR x -> div_refl_helper zi = true -> BND (x / x) zi. Proof. intros x zi Hx Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). assert (Float2 1 0 = 1 :>R)%R. apply Rmult_1_r. generalize (Fle2_correct _ _ H1). clear H1. rewrite H. intro H1. generalize (Fle2_correct _ _ H2). clear H2. rewrite H. intro H2. unfold Rdiv. rewrite Rinv_r. 2: exact Hx. exact (conj H1 H2). Qed. Definition mul_pp_helper (xi yi zi : FF) := Fpos0 (lower xi) && Fpos0 (lower yi) && Fle2 (lower zi) (Fmult2 (lower xi) (lower yi)) && Fle2 (Fmult2 (upper xi) (upper yi)) (upper zi). Theorem mul_pp : forall x y : R, forall xi yi zi : FF, BND x xi -> BND y yi -> mul_pp_helper xi yi zi = true -> BND (x * y) zi. Proof. intros x y xi yi zi Hx Hy Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H4). generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3). generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). generalize (Fpos0_correct _ H1). clear H1. intro H1. generalize (Fpos0_correct _ H2). clear H2. intro H2. generalize (Fle2_correct _ _ H3). rewrite Fmult2_correct. clear H3. intro H3. generalize (Fle2_correct _ _ H4). rewrite Fmult2_correct. clear H4. intro H4. apply IRmult_pp with (1 := H1) (2 := H2) (3 := H3) (4 := H4) (5 := Hx) (6 := Hy). Qed. Definition mul_pn_helper (xi yi zi : FF) := Fpos0 (lower xi) && Fneg0 (upper yi) && Fle2 (lower zi) (Fmult2 (upper xi) (lower yi)) && Fle2 (Fmult2 (lower xi) (upper yi)) (upper zi). Theorem mul_pn : forall x y : R, forall xi yi zi : FF, BND x xi -> BND y yi -> mul_pn_helper xi yi zi = true -> BND (x * y) zi. Proof. intros x y xi yi zi Hx Hy Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H4). generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3). generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). generalize (Fpos0_correct _ H1). clear H1. intro H1. generalize (Fneg0_correct _ H2). clear H2. intro H2. generalize (Fle2_correct _ _ H3). rewrite Fmult2_correct. clear H3. intro H3. generalize (Fle2_correct _ _ H4). rewrite Fmult2_correct. clear H4. intro H4. apply IRmult_pn with (1 := H1) (2 := H2) (3 := H3) (4 := H4) (5 := Hx) (6 := Hy). Qed. Definition mul_np_helper (xi yi zi : FF) := mul_pn_helper yi xi zi. Theorem mul_np : forall x y : R, forall xi yi zi : FF, BND x xi -> BND y yi -> mul_np_helper xi yi zi = true -> BND (x * y) zi. Proof. intros x y xi yi zi Hx Hy Hb. rewrite Rmult_comm. exact (mul_pn _ _ _ _ _ Hy Hx Hb). Qed. Definition mul_nn_helper (xi yi zi : FF) := Fneg0 (upper xi) && Fneg0 (upper yi) && Fle2 (lower zi) (Fmult2 (upper xi) (upper yi)) && Fle2 (Fmult2 (lower xi) (lower yi)) (upper zi). Theorem mul_nn : forall x y : R, forall xi yi zi : FF, BND x xi -> BND y yi -> mul_nn_helper xi yi zi = true -> BND (x * y) zi. Proof. intros x y xi yi zi Hx Hy Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H4). generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3). generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). generalize (Fneg0_correct _ H1). clear H1. intro H1. generalize (Fneg0_correct _ H2). clear H2. intro H2. generalize (Fle2_correct _ _ H3). rewrite Fmult2_correct. clear H3. intro H3. generalize (Fle2_correct _ _ H4). rewrite Fmult2_correct. clear H4. intro H4. apply IRmult_nn with (1 := H1) (2 := H2) (3 := H3) (4 := H4) (5 := Hx) (6 := Hy). Qed. Definition mul_po_helper (xi yi zi : FF) := Fpos0 (lower xi) && Fneg0 (lower yi) && Fpos0 (upper yi) && Fle2 (lower zi) (Fmult2 (upper xi) (lower yi)) && Fle2 (Fmult2 (upper xi) (upper yi)) (upper zi). Theorem mul_po : forall x y : R, forall xi yi zi : FF, BND x xi -> BND y yi -> mul_po_helper xi yi zi = true -> BND (x * y) zi. Proof. intros x y xi yi zi Hx Hy Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H5). generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H4). generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3). generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). generalize (Fpos0_correct _ H1). clear H1. intro H1. generalize (Fneg0_correct _ H2). clear H2. intro H2. generalize (Fpos0_correct _ H3). clear H3. intro H3. generalize (Fle2_correct _ _ H4). rewrite Fmult2_correct. clear H4. intro H4. generalize (Fle2_correct _ _ H5). rewrite Fmult2_correct. clear H5. intro H5. apply IRmult_po with (1 := H1) (2 := H2) (3 := H3) (4 := H4) (5 := H5) (6 := Hx) (7 := Hy). Qed. Definition mul_op_helper (xi yi zi : FF) := mul_po_helper yi xi zi. Theorem mul_op : forall x y : R, forall xi yi zi : FF, BND x xi -> BND y yi -> mul_po_helper yi xi zi = true -> BND (x * y) zi. Proof. intros x y xi yi zi Hx Hy Hb. rewrite Rmult_comm. exact (mul_po _ _ _ _ _ Hy Hx Hb). Qed. Definition mul_no_helper (xi yi zi : FF) := Fneg0 (upper xi) && Fneg0 (lower yi) && Fpos0 (upper yi) && Fle2 (lower zi) (Fmult2 (lower xi) (upper yi)) && Fle2 (Fmult2 (lower xi) (lower yi)) (upper zi). Theorem mul_no : forall x y : R, forall xi yi zi : FF, BND x xi -> BND y yi -> mul_no_helper xi yi zi = true -> BND (x * y) zi. Proof. intros x y xi yi zi Hx Hy Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H5). generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H4). generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3). generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). generalize (Fneg0_correct _ H1). clear H1. intro H1. generalize (Fneg0_correct _ H2). clear H2. intro H2. generalize (Fpos0_correct _ H3). clear H3. intro H3. generalize (Fle2_correct _ _ H4). rewrite Fmult2_correct. clear H4. intro H4. generalize (Fle2_correct _ _ H5). rewrite Fmult2_correct. clear H5. intro H5. apply IRmult_no with (1 := H1) (2 := H2) (3 := H3) (4 := H4) (5 := H5) (6 := Hx) (7 := Hy). Qed. Definition mul_on_helper (xi yi zi : FF) := mul_no_helper yi xi zi. Theorem mul_on : forall x y : R, forall xi yi zi : FF, BND x xi -> BND y yi -> mul_no_helper yi xi zi = true -> BND (x * y) zi. Proof. intros x y xi yi zi Hx Hy Hb. rewrite Rmult_comm. exact (mul_no _ _ _ _ _ Hy Hx Hb). Qed. Definition mul_oo_helper (xi yi zi : FF) := Fneg0 (lower xi) && Fpos0 (upper xi) && Fneg0 (lower yi) && Fpos0 (upper yi) && Fle2 (lower zi) (Fmult2 (lower xi) (upper yi)) && Fle2 (lower zi) (Fmult2 (upper xi) (lower yi)) && Fle2 (Fmult2 (lower xi) (lower yi)) (upper zi) && Fle2 (Fmult2 (upper xi) (upper yi)) (upper zi). Theorem mul_oo : forall x y : R, forall xi yi zi : FF, BND x xi -> BND y yi -> mul_oo_helper xi yi zi = true -> BND (x * y) zi. Proof. intros x y xi yi zi Hx Hy Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H8). generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H7). generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H6). generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H5). generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H4). generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3). generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). generalize (Fneg0_correct _ H1). clear H1. intro H1. generalize (Fpos0_correct _ H2). clear H2. intro H2. generalize (Fneg0_correct _ H3). clear H3. intro H3. generalize (Fpos0_correct _ H4). clear H4. intro H4. generalize (Fle2_correct _ _ H5). rewrite Fmult2_correct. clear H5. intro H5. generalize (Fle2_correct _ _ H6). rewrite Fmult2_correct. clear H6. intro H6. generalize (Fle2_correct _ _ H7). rewrite Fmult2_correct. clear H7. intro H7. generalize (Fle2_correct _ _ H8). rewrite Fmult2_correct. clear H8. intro H8. exact (IRmult_oo _ _ _ _ _ _ H1 H2 H3 H4 H6 H5 H7 H8 _ _ Hx Hy). Qed. Definition square_helper (xi zi : FF) := Fle2 (lower zi) (Fmult2 (lower xi) (lower xi)) && Fle2 (Fmult2 (upper xi) (upper xi)) (upper zi). Theorem square : forall x : R, forall xi zi : FF, ABS x xi -> square_helper xi zi = true -> BND (x * x) zi. Proof. intros x xi zi (Hx1,Hx2) Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). fold (Rsqr x). rewrite Rsqr_abs. apply mul_pp with (1 := Hx2) (2 := Hx2). unfold mul_pp_helper. rewrite H1, H2. apply Float_prop.ge_0_F2R in Hx1. revert Hx1. unfold Fpos0. now case (Fnum (lower xi)). Qed. Definition div_pp_helper (xi yi zi : FF) := Fpos (lower yi) && Fpos0 (lower xi) && Fle2 (Fmult2 (upper yi) (lower zi)) (lower xi) && Fle2 (upper xi) (Fmult2 (lower yi) (upper zi)). Theorem div_pp : forall x y : R, forall xi yi zi : FF, BND x xi -> BND y yi -> div_pp_helper xi yi zi = true -> BND (x / y) zi. Proof. intros x y xi yi zi Hx Hy Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H4). generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3). generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). generalize (Fpos_correct _ H1). clear H1. intro H1. generalize (Fpos0_correct _ H2). clear H2. intro H2. generalize (Fle2_correct _ _ H3). rewrite Fmult2_correct. clear H3. intro H3. generalize (Fle2_correct _ _ H4). rewrite Fmult2_correct. clear H4. intro H4. apply IRdiv_pp with (1 := H2) (2 := H1) (3 := H3) (4 := H4) (5 := Hx) (6 := Hy). Qed. Definition div_op_helper (xi yi zi : FF) := Fpos (lower yi) && Fneg0 (lower xi) && Fpos0 (upper xi) && Fle2 (Fmult2 (lower yi) (lower zi)) (lower xi) && Fle2 (upper xi) (Fmult2 (lower yi) (upper zi)). Theorem div_op : forall x y : R, forall xi yi zi : FF, BND x xi -> BND y yi -> div_op_helper xi yi zi = true -> BND (x / y) zi. Proof. intros x y xi yi zi Hx Hy Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H5). generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H4). generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3). generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). generalize (Fpos_correct _ H1). clear H1. intro H1. generalize (Fneg0_correct _ H2). clear H2. intro H2. generalize (Fpos0_correct _ H3). clear H3. intro H3. generalize (Fle2_correct _ _ H4). rewrite Fmult2_correct. clear H4. intro H4. generalize (Fle2_correct _ _ H5). rewrite Fmult2_correct. clear H5. intro H5. apply IRdiv_op with (1 := H2) (2 := H3) (3 := H1) (4 := H4) (5 := H5) (6 := Hx) (7 := Hy). Qed. Definition div_np_helper (xi yi zi : FF) := Fpos (lower yi) && Fneg0 (upper xi) && Fle2 (Fmult2 (lower yi) (lower zi)) (lower xi) && Fle2 (upper xi) (Fmult2 (upper yi) (upper zi)). Theorem div_np : forall x y : R, forall xi yi zi : FF, BND x xi -> BND y yi -> div_np_helper xi yi zi = true -> BND (x / y) zi. Proof. intros x y xi yi zi Hx Hy Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H4). generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3). generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). generalize (Fpos_correct _ H1). clear H1. intro H1. generalize (Fneg0_correct _ H2). clear H2. intro H2. generalize (Fle2_correct _ _ H3). rewrite Fmult2_correct. clear H3. intro H3. generalize (Fle2_correct _ _ H4). rewrite Fmult2_correct. clear H4. intro H4. apply IRdiv_np with (1 := H2) (2 := H1) (3 := H3) (4 := H4) (5 := Hx) (6 := Hy). Qed. Definition div_pn_helper (xi yi zi : FF) := Fneg (upper yi) && Fpos0 (lower xi) && Fle2 (upper xi) (Fmult2 (upper yi) (lower zi)) && Fle2 (Fmult2 (lower yi) (upper zi)) (lower xi). Theorem div_pn : forall x y : R, forall xi yi zi : FF, BND x xi -> BND y yi -> div_pn_helper xi yi zi = true -> BND (x / y) zi. Proof. intros x y xi yi zi Hx Hy Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H4). generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3). generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). generalize (Fneg_correct _ H1). clear H1. intro H1. generalize (Fpos0_correct _ H2). clear H2. intro H2. generalize (Fle2_correct _ _ H3). rewrite Fmult2_correct. clear H3. intro H3. generalize (Fle2_correct _ _ H4). rewrite Fmult2_correct. clear H4. intro H4. apply IRdiv_pn with (1 := H2) (2 := H1) (3 := H3) (4 := H4) (5 := Hx) (6 := Hy). Qed. Definition div_on_helper (xi yi zi : FF) := Fneg (upper yi) && Fneg0 (lower xi) && Fpos0 (upper xi) && Fle2 (upper xi) (Fmult2 (upper yi) (lower zi)) && Fle2 (Fmult2 (upper yi) (upper zi)) (lower xi). Theorem div_on : forall x y : R, forall xi yi zi : FF, BND x xi -> BND y yi -> div_on_helper xi yi zi = true -> BND (x / y) zi. Proof. intros x y xi yi zi Hx Hy Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H5). generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H4). generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3). generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). generalize (Fneg_correct _ H1). clear H1. intro H1. generalize (Fneg0_correct _ H2). clear H2. intro H2. generalize (Fpos0_correct _ H3). clear H3. intro H3. generalize (Fle2_correct _ _ H4). rewrite Fmult2_correct. clear H4. intro H4. generalize (Fle2_correct _ _ H5). rewrite Fmult2_correct. clear H5. intro H5. apply IRdiv_on with (1 := H2) (2 := H3) (3 := H1) (4 := H4) (5 := H5) (6 := Hx) (7 := Hy). Qed. Definition div_nn_helper (xi yi zi : FF) := Fneg (upper yi) && Fneg0 (upper xi) && Fle2 (upper xi) (Fmult2 (lower yi) (lower zi)) && Fle2 (Fmult2 (upper yi) (upper zi)) (lower xi). Theorem div_nn : forall x y : R, forall xi yi zi : FF, BND x xi -> BND y yi -> div_nn_helper xi yi zi = true -> BND (x / y) zi. Proof. intros x y xi yi zi Hx Hy Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H4). generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3). generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). generalize (Fneg_correct _ H1). clear H1. intro H1. generalize (Fneg0_correct _ H2). clear H2. intro H2. generalize (Fle2_correct _ _ H3). rewrite Fmult2_correct. clear H3. intro H3. generalize (Fle2_correct _ _ H4). rewrite Fmult2_correct. clear H4. intro H4. apply IRdiv_nn with (1 := H2) (2 := H1) (3 := H3) (4 := H4) (5 := Hx) (6 := Hy). Qed. Lemma Rabs_idem : forall x : R, (x <= Rabs x)%R. Proof. intro x. unfold Rabs. case Rcase_abs ; intro H. apply Rle_trans with (1 := (Rlt_le _ _ H)). auto with real. apply Req_le. apply refl_equal. Qed. Definition invert_abs_helper (xi zi : FF) := Fle2 (lower zi) (Fopp2 (upper xi)) && Fle2 (upper xi) (upper zi). Theorem invert_abs : forall x : R, forall xi zi : FF, BND (Rabs x) xi -> invert_abs_helper xi zi = true -> BND x zi. Proof. intros x xi zi Hx Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). generalize (Fle2_correct _ _ H1). rewrite Fopp2_correct. clear H1. intro H1. generalize (Fle2_correct _ _ H2). clear H2. intro H2. split. apply Rle_trans with (1 := H1). apply Ropp_le_cancel. rewrite Ropp_involutive. apply Rle_trans with (2 := proj2 Hx). pattern x at 2 ; rewrite <- Ropp_involutive. rewrite Rabs_Ropp. apply Rabs_idem. apply Rle_trans with (2 := H2). apply Rle_trans with (1 := Rabs_idem x) (2 := proj2 Hx). Qed. Definition sqrt_helper (xi zi : FF) := (if (Fneg0 (lower zi)) then Fpos0 (lower xi) else Fle2 (Fmult2 (lower zi) (lower zi)) (lower xi)) && Fpos0 (upper zi) && Fle2 (upper xi) (Fmult2 (upper zi) (upper zi)). Theorem sqrtG: forall x : R, forall xi zi : FF, BND x xi -> sqrt_helper xi zi = true -> BND (sqrt x) zi. Proof. intros x xi zi Hx Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3). generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). generalize (Fpos0_correct _ H2). clear H2. intro H2. generalize (Fle2_correct _ _ H3). rewrite Fmult2_correct. clear H3. intro H3. unfold BND. apply IRsqrt with (2 := H2) (3 := H3) (4 := Hx). induction (lower zi). induction Fnum ; simpl in H1. rewrite float2_zero. rewrite Rmult_0_l. assert (H4 := Fpos0_correct _ H1). case (Rlt_le_dec 0 0) ; intros _ ; exact H4. case (Rlt_le_dec 0 (Float2 (Zpos p) Fexp)). intros _. rewrite <- Fmult2_correct. apply Fle2_correct. exact H1. intro H. elim (Rlt_irrefl R0). apply Rlt_le_trans with (2 := H). apply Fpos_correct. apply refl_equal. case (Rlt_le_dec 0 (Float2 (Zneg p) Fexp)). intro H. elim (Rlt_irrefl R0). apply Rlt_trans with (1 := H). apply Fneg_correct. apply refl_equal. intros _. apply Fpos0_correct. exact H1. Qed. Definition square_rev_helper (xi zi : FF) := Fpos0 (lower zi) && Fpos0 (upper zi) && Fle2 (Fmult2 (lower zi) (lower zi)) (lower xi) && Fle2 (upper xi) (Fmult2 (upper zi) (upper zi)). Theorem square_rev : forall x : R, forall xi zi : FF, ABS (x * x) xi -> square_rev_helper xi zi = true -> ABS x zi. Proof. intros x xi zi [Hx1 Hx2] Hb. apply andb_prop in Hb. destruct Hb as [Hb H4]. apply andb_prop in Hb. destruct Hb as [Hb H3]. apply andb_prop in Hb. destruct Hb as [H1 H2]. apply Fpos0_correct in H1. apply Fpos0_correct in H2. apply Fle2_correct in H3. apply Fle2_correct in H4. split. exact H1. rewrite <- sqrt_Rsqr_abs. rewrite Rabs_pos_eq in Hx2 by apply Rle_0_sqr. apply IRsqrt with (2 := H2) (4 := Hx2). case Rlt_le_dec ; intros H5. now rewrite <- Fmult2_correct. exact Hx1. now rewrite <- Fmult2_correct. Qed. coq-gappalib-coq-1.10.0-df59b68361b1efbd697b17c40f7fae4a35991c44/src/Gappa_pred_fixflt.v000066400000000000000000000413751517666064600270750ustar00rootroot00000000000000From Coq Require Import Lra. From Flocq Require Import Core Sterbenz. Require Import Gappa_common. Require Import Gappa_round_aux. Theorem fix_subset : forall x : R, forall xn zn : Z, FIX x xn -> Zle_bool zn xn = true -> FIX x zn. Proof. intros x xn zn Hx Hb. apply fix_le with (1 := Hx). now apply Zle_bool_imp_le. Qed. Theorem flt_subset : forall x : R, forall xn zn : positive, FLT x xn -> Zle_bool (Zpos xn) (Zpos zn) = true -> FLT x zn. Proof. intros x xn zn Hx Hb. apply flt_le with (1 := Hx). now apply Zle_bool_imp_le. Qed. Definition fix_of_singleton_bnd_helper (xi : FF) (n : Z) := Zeq_bool (Fnum (lower xi)) (Fnum (upper xi)) && Zeq_bool (Fexp (lower xi)) (Fexp (upper xi)) && Zle_bool n (Fexp (lower xi)). Theorem fix_of_singleton_bnd : forall x : R, forall xi : FF, forall n : Z, ABS x xi -> fix_of_singleton_bnd_helper xi n = true -> FIX x n. Proof. intros x xi n (_, (Hx1, Hx2)) Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3). generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). generalize (Zeq_bool_eq _ _ H1). clear H1. intro H1. generalize (Zeq_bool_eq _ _ H2). clear H2. intro H2. generalize (Zle_bool_imp_le _ _ H3). clear H3. intro H3. assert (float2R (lower xi) = Rabs x). apply Rle_antisym. exact Hx1. replace (lower xi) with (upper xi). exact Hx2. apply sym_equal. induction (lower xi). induction (upper xi). exact (f_equal2 _ H1 H2). unfold Rabs in H. induction (Rcase_abs x). exists (Fopp2 (lower xi)). split. rewrite Fopp2_correct. rewrite <- (Ropp_involutive x). apply Ropp_eq_compat. exact H. exact H3. exists (lower xi). exact (conj H H3). Qed. Definition flt_of_singleton_bnd_helper (xi : FF) (n : positive) := Zeq_bool (Fnum (lower xi)) (Fnum (upper xi)) && Zeq_bool (Fexp (lower xi)) (Fexp (upper xi)) && Zlt_bool (Z.abs (Fnum (lower xi))) (two_power_pos n). Theorem flt_of_singleton_bnd : forall x : R, forall xi : FF, forall n : positive, ABS x xi -> flt_of_singleton_bnd_helper xi n = true -> FLT x n. Proof. intros x xi n (_, (Hx1, Hx2)) Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3). generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). generalize (Zeq_bool_eq _ _ H1). clear H1. intro H1. generalize (Zeq_bool_eq _ _ H2). clear H2. intro H2. generalize (Zlt_cases (Z.abs (Fnum (lower xi))) (two_power_pos n)). rewrite H3. rewrite two_power_pos_correct. clear H3. intro H3. assert (float2R (lower xi) = Rabs x). apply Rle_antisym. exact Hx1. replace (lower xi) with (upper xi). exact Hx2. apply sym_equal. induction (lower xi). induction (upper xi). exact (f_equal2 _ H1 H2). unfold Rabs in H. induction (Rcase_abs x). exists (Fopp2 (lower xi)). split. rewrite Fopp2_correct. rewrite <- (Ropp_involutive x). apply Ropp_eq_compat. exact H. simpl. rewrite Zabs_Zopp. exact H3. exists (lower xi). exact (conj H H3). Qed. Theorem neg_fix : forall x : R, forall xn zn : Z, FIX x xn -> Zle_bool zn xn = true -> FIX (-x)%R zn. Proof. intros x xn zn [fx [Hx1 Hx2]] Hb. generalize (Zle_bool_imp_le _ _ Hb). clear Hb. intro H1. exists (Fopp2 fx). split. rewrite <- Hx1. apply Fopp2_correct. now apply Z.le_trans with xn. Qed. Theorem abs_fix : forall x : R, forall xn zn : Z, FIX x xn -> Zle_bool zn xn = true -> FIX (Rabs x) zn. Proof. intros x xn zn [[mx ex] [Hx1 Hx2]] Hb. generalize (Zle_bool_imp_le _ _ Hb). clear Hb. intro H1. exists (Float2 (Z.abs mx) ex). split. rewrite <- Hx1. apply F2R_Zabs. now apply Z.le_trans with xn. Qed. Definition add_fix_helper (xn yn zn : Z) := Zle_bool zn xn && Zle_bool zn yn. Theorem add_fix : forall x y : R, forall xn yn zn : Z, FIX x xn -> FIX y yn -> add_fix_helper xn yn zn = true -> FIX (x + y)%R zn. Proof. intros x y xn yn zn (fx,(Hx1,Hx2)) (fy,(Hy1,Hy2)) Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). generalize (Zle_bool_imp_le _ _ H1). clear H1. intro H1. generalize (Zle_bool_imp_le _ _ H2). clear H2. intro H2. exists (Fplus2 fx fy). split. rewrite <- Hx1. rewrite <- Hy1. apply Fplus2_correct. unfold Fplus2, Fshift2. case (Fexp fx - Fexp fy)%Z ; intros. exact (Z.le_trans _ _ _ H1 Hx2). exact (Z.le_trans _ _ _ H2 Hy2). exact (Z.le_trans _ _ _ H1 Hx2). Qed. Theorem sub_fix : forall x y : R, forall xn yn zn : Z, FIX x xn -> FIX y yn -> add_fix_helper xn yn zn = true -> FIX (x - y)%R zn. Proof. intros x y xn yn zn Hx (fy,(Hy1,Hy2)) Hb. unfold Rminus. apply (add_fix _ (-y) _ yn zn Hx). exists (Fopp2 fy). split. rewrite <- Hy1. apply Fopp2_correct. exact Hy2. exact Hb. Qed. Theorem mul_fix : forall x y : R, forall xn yn zn : Z, FIX x xn -> FIX y yn -> Zle_bool zn (xn + yn) = true -> FIX (x * y)%R zn. Proof. intros x y xn yn zn (fx,(Hx1,Hx2)) (fy,(Hy1,Hy2)) Hb. generalize (Zle_bool_imp_le _ _ Hb). clear Hb. intro H1. exists (Fmult2 fx fy). split. rewrite <- Hx1. rewrite <- Hy1. apply Fmult2_correct. apply Z.le_trans with (1 := H1). exact (Zplus_le_compat _ _ _ _ Hx2 Hy2). Qed. Lemma flt_abs_aux : forall x : R, forall xn : positive, FLT (Rabs x) xn <-> FLT x xn. Proof. intros x xn. unfold Rabs. case Rcase_abs ; intros Hx. 2: easy. split ; intros [[mx ex] [Hx1 Hx2]] ; exists (Float2 (Z.opp mx) ex) ; split ; simpl. rewrite <- (Ropp_involutive x), <- Hx1. apply F2R_Zopp. now rewrite Zabs_Zopp. rewrite <- Hx1. apply F2R_Zopp. now rewrite Zabs_Zopp. Qed. Theorem neg_flt : forall x : R, forall xn zn : positive, FLT x xn -> Zle_bool (Zpos xn) (Zpos zn) = true -> FLT (-x)%R zn. Proof. intros x xn zn Hx Hb. apply flt_subset with (2 := Hb) in Hx. destruct Hx as [fx [Hx1 Hx2]]. exists (Fopp2 fx). split. rewrite <- Hx1. apply Fopp2_correct. simpl. now rewrite Z.abs_opp. Qed. Theorem abs_flt : forall x : R, forall xn zn : positive, FLT x xn -> Zle_bool (Zpos xn) (Zpos zn) = true -> FLT (Rabs x) zn. Proof. intros x xn zn Hx Hb. apply flt_subset with (2 := Hb) in Hx. destruct Hx as [fx [Hx1 Hx2]]. exists (Fabs2 fx). split. rewrite <- Hx1. apply Fabs2_correct. simpl. now rewrite Z.abs_involutive. Qed. Lemma flt_1_aux : forall x y : R, forall yn : positive, FLT x 1 -> FLT y yn -> FLT (x * y)%R yn. Proof. intros x y yn [[mx ex] [<- Hx]] Hy. destruct mx as [|mx|mx]. rewrite float2_zero, Rmult_0_l. exists (Float2 Z0 0). split. apply float2_zero. now apply (Zpower_gt_0 radix2 (Zpos yn)). destruct mx ; try now destruct mx. destruct Hy as [[my ey] [<- Hy]]. exists (Float2 my (ex + ey)). split. 2: exact Hy. unfold float2R ; simpl. rewrite <- Operations.F2R_mult. unfold Operations.Fmult. now rewrite Zmult_1_l. destruct mx ; try now destruct mx. destruct Hy as [[my ey] [<- Hy]]. exists (Float2 (-my) (ex + ey)). split. 2: simpl ; now rewrite Zabs_Zopp. unfold float2R ; simpl. rewrite <- Operations.F2R_mult. unfold Operations.Fmult. now replace (-1 * my)%Z with (Z.opp my) by ring. Qed. Theorem mul_flt : forall x y : R, forall xn yn zn : positive, FLT x xn -> FLT y yn -> Zle_bool (Zpos (if xn =? 1 then yn else if yn =? 1 then xn else xn + yn)%positive) (Zpos zn) = true -> FLT (x * y)%R zn. Proof. intros x y xn yn zn Hx Hy Hb. apply Zle_bool_imp_le in Hb. revert Hb. apply flt_le. case Pos.eqb_spec. intros ->. now apply flt_1_aux. intros _. case Pos.eqb_spec. intros ->. rewrite Rmult_comm. now apply flt_1_aux. intros _. destruct Hx as [fx [Hx1 Hx2]]. destruct Hy as [fy [Hy1 Hy2]]. exists (Fmult2 fx fy). split. rewrite <- Hx1. rewrite <- Hy1. apply Fmult2_correct. change (Z.pow_pos 2 (xn + yn)) with (Zpower radix2 (Zpos xn + Zpos yn)). rewrite Zpower_plus by easy. simpl Z.abs. rewrite Zabs_Zmult. apply Zmult_lt_compat ; split ; try assumption ; apply Zabs_pos. Qed. Theorem fix_of_flt_bnd : forall x : R, forall xi : FF, forall n : Z, forall p : positive, FLT x p -> ABS x xi -> Zle_bool (n + Zpos p) (Zpos (digits (pos_of_Z (Fnum (lower xi)))) + Fexp (lower xi)) && Fpos (lower xi) = true -> FIX x n. Proof. intros x ((ml,el),xu) n p ((mx,ex),(Hx1,Hx2)) (_,(Hxi,_)) Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). generalize (Zle_bool_imp_le _ _ H1). simpl Fnum. simpl Fexp. clear H1. intro H1. generalize (Fpos_correct _ H2). simpl. clear H2. intro H2. exists (Float2 mx ex). split. exact Hx1. apply Zplus_le_reg_l with (Zpos p). rewrite Zplus_comm. apply Z.le_trans with (1 := H1). clear H1. rewrite digits2_digits. assert (H0: (0 < ml)%Z). apply gt_0_F2R with (1 := H2). rewrite Zpos_pos_of_Z with (1 := H0). assert (H0': ml <> Z0). intros H. now rewrite H in H0. rewrite Zdigits_mag with (1 := H0'). rewrite <- mag_F2R with (1 := H0'). apply Z.le_trans with (mag radix2 (Rabs (Float2 mx ex))). apply mag_le. now apply F2R_gt_0. now rewrite Hx1. rewrite mag_abs. unfold float2R. assert (Hx0: mx <> Z0). intros H. apply Rle_not_lt with (1 := Hxi). rewrite <- Hx1, H. unfold float2R. rewrite F2R_0, Rabs_R0. now apply F2R_gt_0. rewrite mag_F2R with (1 := Hx0). apply Zplus_le_compat_r. destruct (mag radix2 (IZR mx)) as (e, He). simpl. apply bpow_lt_bpow with radix2. apply Rle_lt_trans with (Rabs (IZR mx)). apply He. now apply (IZR_neq _ 0%Z). rewrite <- abs_IZR. rewrite <- IZR_Zpower. 2: easy. now apply IZR_lt. Qed. Theorem flt_of_fix_bnd : forall x xi n p, FIX x n -> ABS x xi -> Zle_bool (Zpos (digits (pos_of_Z (Fnum (upper xi)))) + Fexp (upper xi)) (n + Zpos p) = true -> FLT x p. Proof. intros x (xl,(mu,eu)) n p ((m,e),(Hx1,Hx2)) Hxi H. generalize (Zle_bool_imp_le _ _ H). clear H. intro H. exists (Float2 m e). split. exact Hx1. unfold float2R in Hx1. simpl in Hx1. simpl Fnum in H. simpl Fexp in H. apply (lt_F2R radix2 e). rewrite F2R_Zabs. apply Rle_lt_trans with (F2R (Float radix2 mu eu)). simpl. rewrite Hx1. apply Hxi. apply Rlt_le_trans with (bpow radix2 (n + Zpos p)). destruct (Zle_or_lt mu 0) as [Hu|Hu]. apply Rle_lt_trans with R0. now apply F2R_le_0. apply bpow_gt_0. apply Rlt_le_trans with (bpow radix2 (Digits.Zdigits radix2 mu + eu)). rewrite Zdigits_mag. 2: intros Hu' ; now rewrite Hu' in Hu. rewrite <- mag_F2R. 2: intros Hu' ; now rewrite Hu' in Hu. destruct (mag radix2 (F2R (Float radix2 mu eu))) as (e', He). apply (Rle_lt_trans _ _ _ (RRle_abs _)). apply He. apply Rgt_not_eq. now apply F2R_gt_0. rewrite <- (Zpos_pos_of_Z _ Hu). rewrite <- digits2_digits. now apply bpow_le. unfold F2R. simpl. change (Zpower_pos 2 p) with (Zpower radix2 (Zpos p)). rewrite IZR_Zpower. 2: easy. rewrite <- bpow_plus. apply bpow_le. rewrite Zplus_comm. now apply Zplus_le_compat_l. Qed. Lemma flt_lin_aux : forall a b x n, FLT a n -> FLT b n -> a = (b * x)%R -> (/2 <= x <= 2)%R -> FLT (a - b) n. Proof. intros a b x n Ha Hb H Hx. destruct (Rlt_or_le b 0) as [Zb|Zb]. (* Case b < 0 *) - unfold Rminus. rewrite <- (Ropp_involutive a), Rplus_comm. apply <- FLT_iff_generic. apply sterbenz. now apply FLX_exp_valid. apply FLX_exp_monotone. 1-2: now apply generic_format_opp ; apply -> FLT_iff_generic. rewrite H. rewrite <- (Rmult_1_r (-b)). split. unfold Rdiv. replace (- (b * x) * /2)%R with ((-b) * (x * /2))%R by ring. apply Rmult_le_compat_l ; lra. replace (2 * -(b * x))%R with ((-b) * (2 * x))%R by ring. apply Rmult_le_compat_l ; lra. (* Case b > 0 *) - unfold Rminus. apply <- FLT_iff_generic. apply sterbenz. now apply FLX_exp_valid. apply FLX_exp_monotone. 1-2: now apply -> FLT_iff_generic. rewrite H. unfold Rdiv. rewrite (Rmult_comm 2). split ; apply Rmult_le_compat_l with (1 := Zb) ; lra. Qed. Definition add_flt_lin_helper (xn yn zn : positive) (xyi : FF) := Zle_bool (Zpos xn) (Zpos zn) && Zle_bool (Zpos yn) (Zpos zn) && Fle2 (Float2 (-1) 1) (lower xyi) && Fle2 (upper xyi) (Float2 (-1) (-1)). Theorem add_flt_lin : forall a b an bn I cn, FLT a an -> FLT b bn -> LIN a b I -> add_flt_lin_helper an bn cn I = true -> FLT (a + b) cn. Proof. intros a b an bn I cn Fa Fb [x [[Hx1 Hx2] Hx]] f. generalize (andb_prop _ _ f) ; clear f ; intros [f H4]. generalize (andb_prop _ _ f) ; clear f ; intros [f H3]. generalize (andb_prop _ _ f) ; clear f ; intros [H1 H2]. apply Fle2_correct in H3, H4. unfold float2R at 1, F2R in H3. cbn in H3. unfold float2R at 2, F2R in H4. cbn in H4. rewrite <- (Ropp_involutive b). apply flt_lin_aux with (x := Ropp x). now apply flt_subset with (1 := Fa). now apply neg_flt with (1 := Fb). rewrite Hx. ring. lra. Qed. Theorem add_flt_lin_rev : forall a b an bn I cn, FLT a an -> FLT b bn -> LIN b a I -> add_flt_lin_helper bn an cn I = true -> FLT (a + b) cn. Proof. intros a b an bn I cn Fa Fb [x [[Hx1 Hx2] Hx]] f. generalize (andb_prop _ _ f) ; clear f ; intros [f H4]. generalize (andb_prop _ _ f) ; clear f ; intros [f H3]. generalize (andb_prop _ _ f) ; clear f ; intros [H1 H2]. apply Fle2_correct in H3, H4. unfold float2R at 1, F2R in H3. cbn in H3. unfold float2R at 2, F2R in H4. cbn in H4. rewrite <- (Ropp_involutive a), Rplus_comm. apply flt_lin_aux with (x := Ropp x). now apply flt_subset with (1 := Fb). now apply neg_flt with (1 := Fa). rewrite Hx. ring. lra. Qed. Definition sub_flt_lin_helper (xn yn zn : positive) (xyi : FF) := Zle_bool (Zpos xn) (Zpos zn) && Zle_bool (Zpos yn) (Zpos zn) && Fle2 (Float2 1 (-1)) (lower xyi) && Fle2 (upper xyi) (Float2 1 1). Theorem sub_flt_lin : forall a b an bn I cn, FLT a an -> FLT b bn -> LIN a b I -> sub_flt_lin_helper an bn cn I = true -> FLT (a - b) cn. Proof. intros a b an bn I cn Fa Fb [x [[Hx1 Hx2] Hx]] f. generalize (andb_prop _ _ f) ; clear f ; intros [f H4]. generalize (andb_prop _ _ f) ; clear f ; intros [f H3]. generalize (andb_prop _ _ f) ; clear f ; intros [H1 H2]. apply Fle2_correct in H3, H4. unfold float2R at 1, F2R in H3. cbn in H3. unfold float2R at 2, F2R in H4. cbn in H4. apply flt_lin_aux with (3 := Hx). now apply flt_subset with (2 := H1). now apply flt_subset with (2 := H2). lra. Qed. Theorem sub_flt_lin_rev : forall a b an bn I cn, FLT a an -> FLT b bn -> LIN b a I -> sub_flt_lin_helper bn an cn I = true -> FLT (a - b) cn. Proof. intros a b an bn I cn Fa Fb [x [[Hx1 Hx2] Hx]] f. generalize (andb_prop _ _ f) ; clear f ; intros [f H4]. generalize (andb_prop _ _ f) ; clear f ; intros [f H3]. generalize (andb_prop _ _ f) ; clear f ; intros [H1 H2]. apply Fle2_correct in H3, H4. unfold float2R at 1, F2R in H3. cbn in H3. unfold float2R at 2, F2R in H4. cbn in H4. replace (a - b)%R with ((-b) - (-a))%R by ring. apply flt_lin_aux with (x := x). now apply neg_flt with (1 := Fb). now apply neg_flt with (1 := Fa). rewrite Hx. ring. lra. Qed. Definition sub_flt_helper (xn yn zn : positive) (xyi : FF) := Zle_bool (Zpos xn) (Zpos zn) && Zle_bool (Zpos yn) (Zpos zn) && Fle2 (Float2 (-1) (-1)) (lower xyi) && Fle2 (upper xyi) (Float2 1 0). Theorem sub_flt : forall x y xn yn xyi zn, FLT x xn -> FLT y yn -> REL x y xyi -> sub_flt_helper xn yn zn xyi = true -> FLT (x - y) zn. Proof. intros x y xn yn xyi zn Hx Hy (eps,((Hxy1,Hxy2),Hxy3)) Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H4). generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3). generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). generalize (Fle2_correct _ _ H3). clear H3. intro H3. generalize (Fle2_correct _ _ H4). clear H4. intro H4. destruct (total_order_T y 0) as [[Zy|Zy]|Zy]. (* *) apply <- FLT_iff_generic. unfold Rminus. rewrite <- (Ropp_involutive x), Rplus_comm. apply sterbenz. now apply FLX_exp_valid. apply FLX_exp_monotone. apply generic_format_opp. apply -> FLT_iff_generic. now apply flt_subset with yn. apply generic_format_opp. apply -> FLT_iff_generic. now apply flt_subset with xn. rewrite Hxy3, <- Ropp_mult_distr_l_reverse. unfold Rdiv. rewrite (Rmult_comm 2), 2!Rmult_assoc. pattern (-y)%R at 2 3 ; rewrite <- Rmult_1_r. assert (Zy': (0 <= -y)%R). apply Rlt_le. now apply Ropp_0_gt_lt_contravar. split ; apply Rmult_le_compat_l ; try easy. apply Rmult_le_reg_r with 2%R. now apply IZR_lt. rewrite Rmult_assoc, Rinv_l, Rmult_1_l, Rmult_1_r. apply (Rplus_le_compat_l _ _ 1%R). apply Rle_trans with (1 := Hxy2). now rewrite <- (Rmult_1_r 1). apply Rgt_not_eq. now apply IZR_lt. replace 1%R with ((1 + -1 / 2)*2)%R at 1 by field. apply Rmult_le_compat_r. now apply IZR_le. apply Rplus_le_compat_l. now apply Rle_trans with (2 := Hxy1). (* *) rewrite Zy, Rminus_0_r. now apply flt_subset with xn. (* *) apply <- FLT_iff_generic. apply sterbenz. now apply FLX_exp_valid. apply FLX_exp_monotone. apply -> FLT_iff_generic. now apply flt_subset with xn. apply -> FLT_iff_generic. now apply flt_subset with yn. rewrite Hxy3. unfold Rdiv. rewrite (Rmult_comm 2). assert (Zy': (0 <= y)%R). now apply Rlt_le. split ; apply Rmult_le_compat_l ; try easy. replace (/2)%R with (1 + -1/2)%R by field. apply Rplus_le_compat_l. now apply Rle_trans with (2 := Hxy1). apply (Rplus_le_compat_l _ _ 1%R). apply Rle_trans with (1 := Hxy2). now rewrite <- (Rmult_1_r 1). Qed. Theorem sub_flt_rev : forall x y xn yn xyi zn, FLT x xn -> FLT y yn -> REL x y xyi -> sub_flt_helper xn yn zn xyi = true -> FLT (y - x) zn. Proof. intros x y xn yn xyi zn Hx Hy Hxy Hb. apply <- FLT_iff_generic. rewrite <- Ropp_minus_distr. apply generic_format_opp. apply -> FLT_iff_generic. eapply sub_flt ; eassumption. Qed. coq-gappalib-coq-1.10.0-df59b68361b1efbd697b17c40f7fae4a35991c44/src/Gappa_pred_lin.v000066400000000000000000000207301517666064600263530ustar00rootroot00000000000000From Flocq Require Import Core Sterbenz. Require Import Gappa_common. Require Import Gappa_pred_bnd. Require Import Gappa_round_aux. Lemma compose_lin_generic : forall f, (forall x y : R, forall xi yi zi : FF, BND x xi -> BND y yi -> f xi yi zi = true -> BND (x * y) zi) -> forall x1 x2 y2 : R, forall xi yi zi : FF, LIN x1 x2 xi -> LIN x2 y2 yi -> f xi yi zi = true -> LIN x1 y2 zi. Proof. intros f t x1 x2 y2 xi yi zi [x [Hx1 Hx2]] [y [Hy1 Hy2]] Hb. exists (x * y)%R. split. - now apply t with (1 := Hx1) (2 := Hy1). - rewrite Hx2, Hy2. ring. Qed. Definition compose_lin_pp := compose_lin_generic _ mul_pp. Definition compose_lin_po := compose_lin_generic _ mul_po. Definition compose_lin_pn := compose_lin_generic _ mul_pn. Definition compose_lin_op := compose_lin_generic _ mul_op. Definition compose_lin_oo := compose_lin_generic _ mul_oo. Definition compose_lin_on := compose_lin_generic _ mul_on. Definition compose_lin_np := compose_lin_generic _ mul_np. Definition compose_lin_no := compose_lin_generic _ mul_no. Definition compose_lin_nn := compose_lin_generic _ mul_nn. Lemma lin_refl : forall x : R, forall zi : FF, div_refl_helper zi = true -> LIN x x zi. Proof. intros x zi Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). assert (Float2 1 0 = 1 :>R)%R. apply Rmult_1_r. generalize (Fle2_correct _ _ H1). clear H1. rewrite H. intro H1. generalize (Fle2_correct _ _ H2). clear H2. rewrite H. intro H2. exists 1%R. split. apply (conj H1 H2). apply eq_sym, Rmult_1_r. Qed. Theorem add_ll : forall (a b c : R) (I J K : FF), LIN a c I -> LIN b c J -> add_helper I J K = true -> LIN (a + b) c K. Proof. intros a b c I J K [i [Hi1 Hi2]] [j [Hj1 Hj2]] Hb. exists (i + j)%R. split. - now apply add with (3 := Hb). - rewrite Hi2, Hj2. ring. Qed. Theorem lin_of_bnd_div : forall (a b : R) (I : FF), NZR b -> BND (a / b) I -> LIN a b I. Proof. intros a b I Hb H1. exists (a / b)%R. split. - now apply H1. - now field. Qed. Theorem bnd_div_of_lin : forall (a b : R) (I : FF), NZR b -> LIN a b I -> BND (a / b) I. Proof. intros a b I Hb [x [H1 H2]]. rewrite H2. now replace (b * x / b)%R with x by now field. Qed. Theorem bnd_of_lin : forall a b : R, forall zi : FF, LIN a b zi -> contains_zero_helper zi = true -> BND (a / b) zi. Proof. intros a b zi [x [Hx ->]] Hb. destruct (Req_dec b 0) as [->|Zb]. rewrite Rdiv_0_r. now apply contains_zero. replace (_ / b)%R with x by now field. exact Hx. Qed. Theorem sub_ll : forall (a b c : R) (I J K : FF), LIN a c I -> LIN b c J -> sub_helper I J K = true -> LIN (a - b) c K. Proof. intros a b c I J K [i [Hi1 Hi2]] [j [Hj1 Hj2]] Hb. exists (i - j)%R. split. - now apply sub with (3 := Hb). - rewrite Hi2, Hj2. ring. Qed. Theorem minus_lin : forall (a b : R) (I J : FF), LIN a b I -> neg_helper I J = true -> LIN (-a) b J. Proof. intros a b I J [x [Hx1 ->]] Hb. exists (-x)%R. split. - now apply neg with (2 := Hb). - apply Ropp_mult_distr_r. Qed. Lemma mul_ll_generic : forall f, (forall x y : R, forall xi yi zi : FF, BND x xi -> BND y yi -> f xi yi zi = true -> BND (x * y) zi) -> forall (a b c d : R) (I J K : FF), LIN a c I -> LIN b d J -> f I J K = true -> LIN (a * b) (c * d) K. Proof. intros f t a b c d I J K [x [Hx1 Hx2]] [y [Hy1 Hy2]]. exists (x * y)%R. split. - now apply t with (1 := Hx1) (2 := Hy1). - rewrite Hx2, Hy2 ; ring. Qed. Definition mul_ll_pp := mul_ll_generic _ mul_pp. Definition mul_ll_po := mul_ll_generic _ mul_po. Definition mul_ll_pn := mul_ll_generic _ mul_pn. Definition mul_ll_op := mul_ll_generic _ mul_op. Definition mul_ll_oo := mul_ll_generic _ mul_oo. Definition mul_ll_on := mul_ll_generic _ mul_on. Definition mul_ll_np := mul_ll_generic _ mul_np. Definition mul_ll_no := mul_ll_generic _ mul_no. Definition mul_ll_nn := mul_ll_generic _ mul_nn. Lemma bnd_of_lin_bnd_generic : forall f, (forall x y : R, forall xi yi zi : FF, BND x xi -> BND y yi -> f xi yi zi = true -> BND (x * y) zi) -> forall (a b : R) (I J K : FF), LIN a b I -> BND b J -> f I J K = true -> BND a K. Proof. intros f t a b I J K [x [Hx1 Hx2]] Hb Hf. rewrite Hx2. replace (b * x)%R with (x * b)%R by now ring. now apply t with (1 := Hx1) (2 := Hb). Qed. Definition bnd_of_lin_bnd_pp := bnd_of_lin_bnd_generic _ mul_pp. Definition bnd_of_lin_bnd_po := bnd_of_lin_bnd_generic _ mul_po. Definition bnd_of_lin_bnd_pn := bnd_of_lin_bnd_generic _ mul_pn. Definition bnd_of_lin_bnd_op := bnd_of_lin_bnd_generic _ mul_op. Definition bnd_of_lin_bnd_oo := bnd_of_lin_bnd_generic _ mul_oo. Definition bnd_of_lin_bnd_on := bnd_of_lin_bnd_generic _ mul_on. Definition bnd_of_lin_bnd_np := bnd_of_lin_bnd_generic _ mul_np. Definition bnd_of_lin_bnd_no := bnd_of_lin_bnd_generic _ mul_no. Definition bnd_of_lin_bnd_nn := bnd_of_lin_bnd_generic _ mul_nn. Theorem lin_subset : forall (a b : R) (I J : FF), LIN a b I -> subset_helper I J = true -> LIN a b J. Proof. intros a b I J [x [Hx1 Hx2]] Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). apply Fle2_correct in H1. apply Fle2_correct in H2. exists x. split. apply IRsubset with (1 := H1) (2 := H2) (3 := Hx1). exact Hx2. Qed. Definition intersect_ll_helper (xf yf : float2) (zi : FF) := Fle2 (lower zi) (upper zi) && Fle2 (lower zi) yf && Fle2 xf (upper zi). Theorem intersect_ll : forall (a b : R) (I J K : FF), LIN a b I -> LIN a b J -> intersect_ll_helper (upper I) (lower J) K = true -> LIN a b K. Proof. intros a b I J K [x [Hx1 Hx2]] [y [Hy1 Hy2]] Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3). generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). apply Fle2_correct in H1. apply Fle2_correct in H2. apply Fle2_correct in H3. case (Req_dec b 0) ; intro. exists (float2R (lower K)). split. split. apply Rle_refl. exact H1. rewrite Hx2. rewrite H. repeat rewrite Rmult_0_l. apply refl_equal. exists x. split. split. apply Rle_trans with (1 := H2). replace x with y. apply Hy1. apply Rmult_eq_reg_l with (2 := H). now rewrite <- Hy2. now apply Rle_trans with (2 := H3). exact Hx2. Qed. Definition intersect_ll0_helper (xf yf : float2) (zi : FF) := Flt2 xf yf && Fneg0 (lower zi) && Fpos0 (upper zi). Theorem intersect_ll0 : forall (a b : R) (I J K : FF), LIN a b I -> LIN a b J -> intersect_ll0_helper (upper I) (lower J) K = true -> BND b K. Proof. intros a b I J K [x [Hx1 Hx2]] [y [Hy1 Hy2]] Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3). generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). apply Flt2_correct in H1. apply Fneg0_correct in H2. apply Fpos0_correct in H3. destruct (Req_dec b 0) as [Hz|Hz]. rewrite Hz. now split. elim (Rle_not_lt x y). apply Req_le. apply Rmult_eq_reg_l with (2 := Hz). now rewrite <- Hy2. apply Rle_lt_trans with (1 := proj2 Hx1). apply Rlt_le_trans with (2 := proj1 Hy1). exact H1. Qed. Definition lin_of_rel_helper (ri li : FF) := Fle2 (lower li) (Fplus2 (Float2 1 0) (lower ri)) && Fle2 (Fplus2 (Float2 1 0) (upper ri)) (upper li). Lemma lin_of_rel : forall x y : R, forall ri li : FF, REL x y ri -> lin_of_rel_helper ri li = true -> LIN x y li. Proof. intros x y ri li [e [Hr ->]] Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). generalize (Fle2_correct _ _ H1). rewrite Fplus2_correct. clear H1. intro H1. generalize (Fle2_correct _ _ H2). rewrite Fplus2_correct. clear H2. intro H2. exists (1 + e)%R. refine (conj _ eq_refl). apply IRplus with (1 := H1) (2 := H2) (4 := Hr). rewrite <- (Rmult_1_r 1). split ; apply Rle_refl. Qed. Lemma lin_of_lin_rel_generic : forall f, (forall x y : R, forall xi yi zi : FF, BND x xi -> BND y yi -> f xi yi zi = true -> BND (x * y) zi) -> forall (a b c : R) (I J K : FF), LIN a c I -> REL b a J -> f I J K = true -> LIN (b - a) c K. Proof. intros f t a b c I J K [x [Hx1 Hx2]] [y [Hy1 Hy2]] Hf. rewrite Hy2. exists (x * y)%R. replace (a * (1 + y) - a)%R with (a * y)%R by ring. split. - now apply t with (1 := Hx1) (2 := Hy1). - rewrite Hx2 ; ring. Qed. Definition lin_of_lin_rel_pp := lin_of_lin_rel_generic _ mul_pp. Definition lin_of_lin_rel_po := lin_of_lin_rel_generic _ mul_po. Definition lin_of_lin_rel_pn := lin_of_lin_rel_generic _ mul_pn. Definition lin_of_lin_rel_op := lin_of_lin_rel_generic _ mul_op. Definition lin_of_lin_rel_oo := lin_of_lin_rel_generic _ mul_oo. Definition lin_of_lin_rel_on := lin_of_lin_rel_generic _ mul_on. Definition lin_of_lin_rel_np := lin_of_lin_rel_generic _ mul_np. Definition lin_of_lin_rel_no := lin_of_lin_rel_generic _ mul_no. Definition lin_of_lin_rel_nn := lin_of_lin_rel_generic _ mul_nn. coq-gappalib-coq-1.10.0-df59b68361b1efbd697b17c40f7fae4a35991c44/src/Gappa_pred_nzr.v000066400000000000000000000033541517666064600264050ustar00rootroot00000000000000Require Import Gappa_common. Theorem neg_nzr : forall x : R, NZR x -> NZR (-x). Proof. unfold NZR. intros x Hx. contradict Hx. rewrite <- (Ropp_involutive x), Hx. apply Ropp_0. Qed. Theorem mul_nzr : forall x y : R, NZR x -> NZR y -> NZR (x * y). Proof. intros x y Hx Hy. apply Rmult_integral_contrapositive. now split. Qed. Theorem div_nzr : forall x y : R, NZR x -> NZR y -> NZR (x / y). Proof. intros x y Hx Hy. apply Rmult_integral_contrapositive. split. exact Hx. now apply Rinv_neq_0_compat. Qed. Theorem div_nzr_rev_l : forall x y : R, NZR (x / y) -> NZR x. Proof. intros x y Hxy Hx. apply Hxy. rewrite Hx. apply Rmult_0_l. Qed. Theorem div_nzr_rev_r : forall x y : R, NZR (x / y) -> NZR y. Proof. intros x y Hxy Hy. apply Hxy. rewrite Hy. apply Rdiv_0_r. Qed. Theorem nzr_of_abs : forall z : R, forall zi : FF, ABS z zi -> Fpos (lower zi) = true -> NZR z. Proof. intros z zi Hz Hb. generalize (Fpos_correct _ Hb). clear Hb. intro H. case (Rcase_abs z) ; intro. apply Rlt_not_eq with (1 := r). rewrite <- (Rabs_right z r). unfold NZR. apply Rgt_not_eq. apply Rlt_le_trans with (1 := H) (2 := proj1 (proj2 Hz)). Qed. Theorem nzr_of_nzr_rel : forall z zr : R, forall zi : FF, NZR zr -> REL z zr zi -> Flt2_m1 (lower zi) = true -> NZR z. Proof. intros z zr zi Hn (ze,(Hz1,Hz2)) H1. apply Flt2_m1_correct in H1. rewrite Hz2. apply prod_neq_R0. exact Hn. apply Rgt_not_eq. apply Rlt_le_trans with (1 + lower zi)%R. rewrite <- (Rplus_opp_r 1). apply Rplus_lt_compat_l. exact H1. apply Rplus_le_compat_l. apply Hz1. Qed. Theorem nzr_of_nzr_rel_rev : forall z zr : R, forall zi : FF, NZR z -> REL z zr zi -> NZR zr. Proof. intros z zr zi Hn (ze,(Hz1,Hz2)) H1. apply Hn. rewrite Hz2, H1. apply Rmult_0_l. Qed. coq-gappalib-coq-1.10.0-df59b68361b1efbd697b17c40f7fae4a35991c44/src/Gappa_pred_rel.v000066400000000000000000000574051517666064600263640ustar00rootroot00000000000000From Coq Require Import Lra. Require Import Gappa_common. Require Import Gappa_pred_bnd. Theorem bnd_of_nzr_rel : forall a b : R, forall zi : FF, NZR b -> REL a b zi -> BND ((a - b) / b) zi. Proof. intros a b zi Hb (x,(Hr1,Hr2)). replace ((a - b) / b)%R with x. exact Hr1. rewrite Hr2. field. exact Hb. Qed. Theorem bnd_of_rel : forall a b : R, forall zi : FF, REL a b zi -> contains_zero_helper zi = true -> BND ((a - b) / b) zi. Proof. intros a b zi [x [Hx ->]] Hb. destruct (Req_dec b 0) as [->|Zb]. rewrite Rdiv_0_r. now apply contains_zero. replace (_ / b)%R with x by now field. exact Hx. Qed. Theorem rel_of_nzr_bnd : forall a b : R, forall zi : FF, NZR b -> BND ((a - b) / b) zi -> REL a b zi. Proof. intros a b zi Hb Hr. exists ((a - b) / b)%R. split. exact Hr. now field. Qed. Definition one_plus (xi : FF) := makepairF (Fplus2 (Float2 1 0) (lower xi)) (Fplus2 (Float2 1 0) (upper xi)). Lemma one_plus_correct : forall x xi, BND x xi -> BND (1 + x) (one_plus xi). Proof. intros x xi Hx. apply IRplus with (xl := 1%R) (xu := 1%R) (4 := Hx) ; simpl. rewrite Fplus2_correct. apply Rplus_le_compat_r. unfold float2R, Defs.F2R. simpl. rewrite Rmult_1_l. apply Rle_refl. rewrite Fplus2_correct. apply Rplus_le_compat_r. unfold float2R, Defs.F2R. simpl. rewrite Rmult_1_l. apply Rle_refl. split ; apply Rle_refl. Qed. Theorem bnd_of_bnd_rel_p : forall x y : R, forall yi ei xi : FF, BND y yi -> REL x y ei -> mul_pp_helper yi (one_plus ei) xi = true -> BND x xi. Proof. intros x y yi ei xi Hy (e,(He1,He2)) Hb. rewrite He2. apply mul_pp with (1 := Hy) (3 := Hb). apply one_plus_correct with (1 := He1). Qed. Theorem bnd_of_bnd_rel_o : forall x y : R, forall yi ei xi : FF, BND y yi -> REL x y ei -> mul_op_helper yi (one_plus ei) xi = true -> BND x xi. Proof. intros x y yi ei xi Hy (e,(He1,He2)) Hb. rewrite He2. apply mul_op with (1 := Hy) (3 := Hb). apply one_plus_correct with (1 := He1). Qed. Theorem bnd_of_bnd_rel_n : forall x y : R, forall yi ei xi : FF, BND y yi -> REL x y ei -> mul_np_helper yi (one_plus ei) xi = true -> BND x xi. Proof. intros x y yi ei xi Hy (e,(He1,He2)) Hb. rewrite He2. apply mul_np with (1 := Hy) (3 := Hb). apply one_plus_correct with (1 := He1). Qed. Lemma rel_swap : forall x y e ei, BND e ei -> x = (y * (1 + e))%R -> Fpos (lower (one_plus ei)) = true -> y = (x / (1 + e))%R. Proof. intros x y e ei He Hx Hb. rewrite Hx. field. apply Rgt_not_eq. apply Rlt_gt. assert (H := one_plus_correct _ _ He). destruct H as (H,_). apply Rlt_le_trans with (2 := H). now apply Fpos_correct. Qed. Theorem bnd_of_rel_bnd_p : forall x y : R, forall xi ei yi : FF, BND x xi -> REL x y ei -> div_pp_helper xi (one_plus ei) yi = true -> BND y yi. Proof. intros x y yi ei xi Hy (e,(He1,He2)) Hb. destruct (andb_prop _ _ Hb) as (H1,_). generalize (andb_prop _ _ H1). clear H1. intros (H1,_). generalize (andb_prop _ _ H1). clear H1. intros (H1,_). rewrite rel_swap with (1 := He1) (2 := He2) (3 := H1). apply div_pp with (1 := Hy) (3 := Hb). apply one_plus_correct with (1 := He1). Qed. Theorem bnd_of_rel_bnd_o : forall x y : R, forall xi ei yi : FF, BND x xi -> REL x y ei -> div_op_helper xi (one_plus ei) yi = true -> BND y yi. Proof. intros x y yi ei xi Hy (e,(He1,He2)) Hb. destruct (andb_prop _ _ Hb) as (H1,_). generalize (andb_prop _ _ H1). clear H1. intros (H1,_). generalize (andb_prop _ _ H1). clear H1. intros (H1,_). generalize (andb_prop _ _ H1). clear H1. intros (H1,_). rewrite rel_swap with (1 := He1) (2 := He2) (3 := H1). apply div_op with (1 := Hy) (3 := Hb). apply one_plus_correct with (1 := He1). Qed. Theorem bnd_of_rel_bnd_n : forall x y : R, forall xi ei yi : FF, BND x xi -> REL x y ei -> div_np_helper xi (one_plus ei) yi = true -> BND y yi. Proof. intros x y yi ei xi Hy (e,(He1,He2)) Hb. destruct (andb_prop _ _ Hb) as (H1,_). generalize (andb_prop _ _ H1). clear H1. intros (H1,_). generalize (andb_prop _ _ H1). clear H1. intros (H1,_). rewrite rel_swap with (1 := He1) (2 := He2) (3 := H1). apply div_np with (1 := Hy) (3 := Hb). apply one_plus_correct with (1 := He1). Qed. Theorem rel_refl : forall a : R, forall zi : FF, contains_zero_helper zi = true -> REL a a zi. Proof. intros a zi Hb. exists R0. split. now apply contains_zero. ring. Qed. Lemma error_of_rel_generic : forall f, forall t: (forall x y : R, forall xi yi zi : FF, BND x xi -> BND y yi -> f xi yi zi = true -> BND (x * y) zi), forall a b : R, forall xi yi zi : FF, REL a b xi -> BND b yi -> f xi yi zi = true -> BND (a - b) zi. Proof. intros f t a b xi yi zi (x,(Hr1,Hr2)). replace (a - b)%R with (x * b)%R. now apply t. rewrite Hr2. ring. Qed. Definition error_of_rel_pp := error_of_rel_generic mul_pp_helper mul_pp. Definition error_of_rel_po := error_of_rel_generic mul_po_helper mul_po. Definition error_of_rel_pn := error_of_rel_generic mul_pn_helper mul_pn. Definition error_of_rel_op := error_of_rel_generic mul_op_helper mul_op. Definition error_of_rel_oo := error_of_rel_generic mul_oo_helper mul_oo. Definition error_of_rel_on := error_of_rel_generic mul_on_helper mul_on. Definition error_of_rel_np := error_of_rel_generic mul_np_helper mul_np. Definition error_of_rel_no := error_of_rel_generic mul_no_helper mul_no. Definition error_of_rel_nn := error_of_rel_generic mul_nn_helper mul_nn. Theorem rel_subset : forall x xr : R, forall xi zi : FF, REL x xr xi -> subset_helper xi zi = true -> REL x xr zi. Proof. intros x xr xi zi (xe,(Hx1,Hx2)) Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). apply Fle2_correct in H1. apply Fle2_correct in H2. exists xe. split. apply IRsubset with (1 := H1) (2 := H2) (3 := Hx1). exact Hx2. Qed. Definition intersect_rr_helper (xf yf : float2) (zi : FF) := Fle2 (lower zi) (upper zi) && Fle2 (lower zi) yf && Fle2 xf (upper zi). Theorem intersect_rr : forall z1 z2 : R, forall xi yi zi : FF, REL z1 z2 xi -> REL z1 z2 yi -> intersect_rr_helper (upper xi) (lower yi) zi = true -> REL z1 z2 zi. Proof. intros z1 z2 xi yi zi (xe,(Hx1,Hx2)) (ye,(Hy1,Hy2)) Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3). generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). apply Fle2_correct in H1. apply Fle2_correct in H2. apply Fle2_correct in H3. case (Req_dec z2 0) ; intro. exists (float2R (lower zi)). split. split. apply Rle_refl. exact H1. rewrite Hx2. rewrite H. repeat rewrite Rmult_0_l. apply refl_equal. exists xe. split. split. apply Rle_trans with (1 := H2). replace xe with ye. apply Hy1. apply Rplus_eq_reg_l with 1%R. apply Rmult_eq_reg_l with (2 := H). now rewrite <- Hy2. now apply Rle_trans with (2 := H3). exact Hx2. Qed. Definition intersect_rr0_helper (xf yf : float2) (zi : FF) := Flt2 xf yf && Fneg0 (lower zi) && Fpos0 (upper zi). Theorem intersect_rr0 : forall z1 z2 : R, forall xi yi zi : FF, REL z1 z2 xi -> REL z1 z2 yi -> intersect_rr0_helper (upper xi) (lower yi) zi = true -> BND z2 zi. Proof. intros z1 z2 xi yi zi (xe,(Hx1,Hx2)) (ye,(Hy1,Hy2)) Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3). generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). apply Flt2_correct in H1. apply Fneg0_correct in H2. apply Fpos0_correct in H3. destruct (Req_dec z2 0) as [Hz|Hz]. rewrite Hz. now split. elim (Rle_not_lt xe ye). apply Req_le. apply Rplus_eq_reg_l with 1%R. apply Rmult_eq_reg_l with (2 := Hz). now rewrite <- Hy2. apply Rle_lt_trans with (1 := proj2 Hx1). apply Rlt_le_trans with (2 := proj1 Hy1). exact H1. Qed. Definition mul_rr_helper (xi yi zi : FF) := Fle2_m1 (lower xi) && Fle2_m1 (lower yi) && Fle2 (lower zi) (Fplus2 (Fplus2 (lower xi) (lower yi)) (Fmult2 (lower xi) (lower yi))) && Fle2 (Fplus2 (Fplus2 (upper xi) (upper yi)) (Fmult2 (upper xi) (upper yi))) (upper zi). Theorem mul_rr : forall x1 x2 y1 y2 : R, forall xi yi zi : FF, REL x1 x2 xi -> REL y1 y2 yi -> mul_rr_helper xi yi zi = true -> REL (x1 * y1) (x2 * y2) zi. Proof. intros x1 x2 y1 y2 xi yi zi (xe,(Hx1,Hx2)) (ye,(Hy1,Hy2)) Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H4). generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3). generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). apply Fle2_m1_correct in H1. apply Fle2_m1_correct in H2. generalize (Fle2_correct _ _ H3). repeat rewrite Fplus2_correct. rewrite Fmult2_correct. clear H3. intro H3. generalize (Fle2_correct _ _ H4). repeat rewrite Fplus2_correct. rewrite Fmult2_correct. clear H4. intro H4. exists (xe + ye + xe * ye)%R. split. apply IRcompose with (1 := H1) (2 := H2) (3 := H3) (4 := H4) (5 := Hx1) (6 := Hy1). rewrite Hx2. rewrite Hy2. ring. Qed. Definition div_rr_helper (xi yi zi : FF) := Fle2_m1 (lower xi) && Flt2_m1 (lower yi) && Fle2 (upper xi) (Fplus2 (Fplus2 (lower yi) (upper zi)) (Fmult2 (lower yi) (upper zi))) && Fle2 (Fplus2 (Fplus2 (upper yi) (lower zi)) (Fmult2 (upper yi) (lower zi))) (lower xi). Theorem div_rr' : forall x1 x2 y1 y2 : R, forall xi yi zi : FF, REL x1 x2 xi -> REL y1 y2 yi -> div_rr_helper xi yi zi = true -> REL (x1 / y1) (x2 / y2) zi. Proof. intros x1 x2 y1 y2 xi yi zi (xe,(Hx1,Hx2)) (ye,(Hy1,Hy2)) Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H4). generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3). generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). apply Fle2_m1_correct in H1. apply Flt2_m1_correct in H2. generalize (Fle2_correct _ _ H3). repeat rewrite Fplus2_correct. rewrite Fmult2_correct. clear H3. intro H3. generalize (Fle2_correct _ _ H4). repeat rewrite Fplus2_correct. rewrite Fmult2_correct. clear H4. intro H4. exists ((xe - ye) / (1 + ye))%R. split. apply IRcompose_inv with (1 := H1) (2 := H2) (3 := H4) (4 := H3) (5 := Hx1) (6 := Hy1). rewrite Hx2. rewrite Hy2. destruct (Req_dec y2 0) as [->|Hz]. now rewrite Rmult_0_l, 2!Rdiv_0_r, Rmult_0_l. field. refine (conj _ Hz). lra. Qed. Theorem div_rr : forall x1 x2 y1 y2 : R, forall xi yi zi : FF, REL x1 x2 xi -> REL y1 y2 yi -> NZR y2 -> div_rr_helper xi yi zi = true -> REL (x1 / y1) (x2 / y2) zi. Proof. intros x1 x2 y1 y2 xi yi zi Hx Hy _. now apply div_rr'. Qed. Definition inv_r_helper (xi zi : FF) := Flt2_m1 (lower xi) && Fpos0 (Fplus2 (Fplus2 (lower xi) (upper zi)) (Fmult2 (lower xi) (upper zi))) && Fneg0 (Fplus2 (Fplus2 (upper xi) (lower zi)) (Fmult2 (upper xi) (lower zi))). Theorem inv_r' : forall x1 x2 y : R, forall xi zi : FF, REL x1 x2 xi -> inv_r_helper xi zi = true -> REL (y / x1) (y / x2) zi. Proof. intros x1 x2 y xi zi (xe,(Hx1,Hx2)) Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3). generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). apply Flt2_m1_correct in H1. generalize (Fpos0_correct _ H2). repeat rewrite Fplus2_correct. rewrite Fmult2_correct. clear H2. intro H2. generalize (Fneg0_correct _ H3). repeat rewrite Fplus2_correct. rewrite Fmult2_correct. clear H3. intro H3. exists ((0 - xe) / (1 + xe))%R. split. apply IRcompose_inv with (xl := 0%R) (xu := 0%R) (2 := H1) (3 := H3) (4 := H2) (6 := Hx1). now apply IZR_le. split ; apply Rle_refl. rewrite Hx2. destruct (Req_dec x2 0) as [->|Hz]. now rewrite Rmult_0_l, Rdiv_0_r, Rmult_0_l. field. refine (conj _ Hz). lra. Qed. Theorem inv_r : forall x1 x2 y : R, forall xi zi : FF, REL x1 x2 xi -> NZR x2 -> inv_r_helper xi zi = true -> REL (y / x1) (y / x2) zi. Proof. intros x1 x2 y xi zi Hr _. now apply inv_r'. Qed. Theorem compose : forall x1 x2 y2 : R, forall xi yi zi : FF, REL x1 x2 xi -> REL x2 y2 yi -> mul_rr_helper xi yi zi = true -> REL x1 y2 zi. Proof. intros x1 x2 y2 xi yi zi (xe,(Hx1,Hx2)) (ye,(Hy1,Hy2)) Hb. generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H4). generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3). generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2). apply Fle2_m1_correct in H1. apply Fle2_m1_correct in H2. generalize (Fle2_correct _ _ H3). repeat rewrite Fplus2_correct. rewrite Fmult2_correct. clear H3. intro H3. generalize (Fle2_correct _ _ H4). repeat rewrite Fplus2_correct. rewrite Fmult2_correct. clear H4. intro H4. exists (xe + ye + xe * ye)%R. split. apply IRcompose with (1 := H1) (2 := H2) (3 := H3) (4 := H4) (5 := Hx1) (6 := Hy1). rewrite Hx2. rewrite Hy2. ring. Qed. Theorem compose_swap : forall x y r1 r2 : R, forall xi yi zi : FF, REL x (y * r2) xi -> REL r1 (1 / r2) yi -> NZR r2 -> mul_rr_helper xi yi zi = true -> REL (x * r1) y zi. Proof. intros x y r1 r2 xi yi zi Hx Hy Hr Hb. generalize (mul_rr _ _ _ _ _ _ _ Hx Hy Hb). replace (y * r2 * (1 / r2))%R with y. easy. now field. Qed. Definition FImult2 (x : float2) (yi : FF) := let (yl,yu) := yi in if Fpos0 x then makepairF (Fmult2 x yl) (Fmult2 x yu) else makepairF (Fmult2 x yu) (Fmult2 x yl). Lemma FImult2_correct : forall (x : float2) yi y, BND y yi -> BND (x * y) (FImult2 x yi). Proof. intros x (yl,yu) y Hy. unfold FImult2. replace (Fpos0 x) with (Zle_bool 0 (Fnum x)) by now unfold Fpos0 ; case (Fnum x). case Zle_bool_spec ; split ; simpl ; rewrite Fmult2_correct. apply monotony_1p. now apply Float_prop.F2R_ge_0. apply Hy. apply monotony_1p. now apply Float_prop.F2R_ge_0. apply Hy. apply monotony_1n. apply Float_prop.F2R_le_0. now apply Zlt_le_weak. apply Hy. apply monotony_1n. apply Float_prop.F2R_le_0. now apply Zlt_le_weak. apply Hy. Qed. Definition add_rr_helper (xi yi qi zi : FF) := let xql := FImult2 (lower qi) xi in let xqu := FImult2 (upper qi) xi in let yql := FImult2 (Fminus2 (Float2 1 0) (lower qi)) yi in let yqu := FImult2 (Fminus2 (Float2 1 0) (upper qi)) yi in Fle2 (lower zi) (Fplus2 (lower xql) (lower yql)) && Fle2 (lower zi) (Fplus2 (lower xqu) (lower yqu)) && Fle2 (Fplus2 (upper xql) (upper yql)) (upper zi) && Fle2 (Fplus2 (upper xqu) (upper yqu)) (upper zi). Theorem add_rr_left : forall x1 x2 y1 y2 : R, forall xi yi qi zi : FF, REL x1 x2 xi -> REL y1 y2 yi -> LIN x2 (x2 + y2) qi -> add_rr_helper xi yi qi zi = true -> REL (x1 + y1) (x2 + y2) zi. Proof. intros x1 x2 y1 y2 xi yi qi zi [ex [Hx1 Hx2]] [ey [Hy1 Hy2]] [eq [Hq1 Hq2]] Hb. generalize (andb_prop _ _ Hb). clear Hb. intros [Hb H4]. generalize (andb_prop _ _ Hb). clear Hb. intros [Hb H3]. generalize (andb_prop _ _ Hb). clear Hb. intros [H1 H2]. apply Fle2_correct in H1. rewrite Fplus2_correct in H1. apply Fle2_correct in H2. rewrite Fplus2_correct in H2. apply Fle2_correct in H3. rewrite Fplus2_correct in H3. apply Fle2_correct in H4. rewrite Fplus2_correct in H4. assert (H5 := FImult2_correct (lower qi) xi _ Hx1). assert (H6 := FImult2_correct (upper qi) xi _ Hx1). assert (H7 := FImult2_correct (Fminus2 (Float2 1 0) (lower qi)) yi _ Hy1). assert (H8 := FImult2_correct (Fminus2 (Float2 1 0) (upper qi)) yi _ Hy1). assert (H9 : float2R (Float2 1 0) = R1) by apply Rmult_1_r. assert (Ha : (float2R (Fminus2 (Float2 1 0) (lower qi)) = 1 - lower qi)%R). now rewrite Fminus2_correct, H9. assert (Hb : (float2R (Fminus2 (Float2 1 0) (upper qi)) = 1 - upper qi)%R). now rewrite Fminus2_correct, H9. destruct (Req_dec (x2 + y2) 0) as [Zxy|Zxy]. { exists (lower zi). split. - apply (conj (Rle_refl _)). apply Rle_trans with (2 := H3). apply Rle_trans with (1 := H1). apply Rplus_le_compat. eapply Rle_trans ; apply H5. eapply Rle_trans ; apply H7. - rewrite Zxy, Rmult_0_l. assert (Hx: x2 = 0%R). { rewrite Hq2, Zxy. apply Rmult_0_l. } rewrite Hx2, Hx, Hy2. replace y2 with (x2 + y2 - x2)%R by ring. rewrite Zxy, Hx. ring. } exists ((x1 + y1) / (x2 + y2) - 1)%R. split. 2: now field. rewrite Hx2, Hy2. replace y2 with (x2 + y2 - x2)%R at 1 3 by ring. rewrite Hq2 at 1 3 5 7. replace (_ / (x2 + y2) - 1)%R with (ey + eq * (ex - ey))%R by now field. destruct (Rle_or_lt (ex - ey) 0) as [He|He]. - split. + apply Rle_trans with (ey + upper qi * (ex - ey))%R. replace (ey + upper qi * (ex - ey))%R with (upper qi * ex + (1 - upper qi) * ey)%R by ring. apply Rle_trans with (1 := H2). apply Rplus_le_compat. apply H6. rewrite <- Hb. apply H8. apply Rplus_le_compat_l. now apply monotony_2n. + apply Rle_trans with (ey + lower qi * (ex - ey))%R. apply Rplus_le_compat_l. now apply monotony_2n. replace (ey + lower qi * (ex - ey))%R with (lower qi * ex + (1 - lower qi) * ey)%R by ring. apply Rle_trans with (2 := H3). apply Rplus_le_compat. apply H5. rewrite <- Ha. apply H7. - apply Rlt_le in He. split. + apply Rle_trans with (ey + lower qi * (ex - ey))%R. replace (ey + lower qi * (ex - ey))%R with (lower qi * ex + (1 - lower qi) * ey)%R by ring. apply Rle_trans with (1 := H1). apply Rplus_le_compat. apply H5. rewrite <- Ha. apply H7. apply Rplus_le_compat_l. now apply monotony_2p. + apply Rle_trans with (ey + upper qi * (ex - ey))%R. apply Rplus_le_compat_l. now apply monotony_2p. replace (ey + upper qi * (ex - ey))%R with (upper qi * ex + (1 - upper qi) * ey)%R by ring. apply Rle_trans with (2 := H4). apply Rplus_le_compat. apply H6. rewrite <- Hb. apply H8. Qed. Theorem add_rr_right : forall x1 x2 y1 y2 : R, forall xi yi qi zi : FF, REL x1 x2 xi -> REL y1 y2 yi -> LIN y2 (x2 + y2) qi -> add_rr_helper yi xi qi zi = true -> REL (x1 + y1) (x2 + y2) zi. Proof. intros x1 x2 y1 y2 xi yi qi zi Hx Hy Hq Hb. rewrite (Rplus_comm x1), (Rplus_comm x2). apply add_rr_left with (1 := Hy) (2 := Hx) (4 := Hb). now rewrite Rplus_comm. Qed. Theorem sub_rr_left : forall x1 x2 y1 y2 : R, forall xi yi qi zi : FF, REL x1 x2 xi -> REL y1 y2 yi -> LIN x2 (x2 - y2) qi -> add_rr_helper xi yi qi zi = true -> REL (x1 - y1) (x2 - y2) zi. Proof. intros x1 x2 y1 y2 xi yi qi zi Hx [ey [Hy1 Hy2]] Hq Hb. apply add_rr_left with (1 := Hx) (3 := Hq) (4 := Hb). exists ey. apply (conj Hy1). rewrite Hy2. ring. Qed. Definition sub_rr_helper (xi yi qi zi : FF) := let ri := makepairF (Fopp2 (upper qi)) (Fopp2 (lower qi)) in add_rr_helper xi yi ri zi. Theorem sub_rr_right : forall x1 x2 y1 y2 : R, forall xi yi qi zi : FF, REL x1 x2 xi -> REL y1 y2 yi -> LIN y2 (x2 - y2) qi -> sub_rr_helper yi xi qi zi = true -> REL (x1 - y1) (x2 - y2) zi. Proof. intros x1 x2 y1 y2 xi yi qi zi Hx [ey [Hy1 Hy2]] [eq [Hq1 Hq2]] Hb. apply add_rr_right with (1 := Hx) (4 := Hb). exists ey. apply (conj Hy1). rewrite Hy2. ring. exists (- eq)%R. split. 2: rewrite Hq2 at 1 ; ring. simpl. rewrite 2!Fopp2_correct. now split ; apply Ropp_le_contravar. Qed. Theorem add_rr : forall x1 x2 y1 y2 : R, forall xi yi qi zi : FF, REL x1 x2 xi -> REL y1 y2 yi -> BND (x2 / (x2 + y2)) qi -> NZR (x2 + y2) -> add_rr_helper xi yi qi zi = true -> REL (x1 + y1) (x2 + y2) zi. Proof. intros x1 x2 y1 y2 xi yi qi zi Hx Hy Hq Zxy Hb. apply add_rr_left with (1 := Hx) (2 := Hy) (4 := Hb). exists (x2 / (x2 + y2))%R. apply (conj Hq). now field. Qed. Theorem sub_rr : forall x1 x2 y1 y2 : R, forall xi yi qi zi : FF, REL x1 x2 xi -> REL y1 y2 yi -> BND (x2 / (x2 - y2)) qi -> NZR (x2 - y2) -> add_rr_helper xi yi qi zi = true -> REL (x1 - y1) (x2 - y2) zi. Proof. intros x1 x2 y1 y2 xi yi qi zi Hx (ey,(Hy1,Hy2)) Hq Zxy Hb. apply add_rr with (1 := Hx) (3 := Hq) (4 := Zxy) (5 := Hb). exists ey. split. exact Hy1. rewrite Hy2. ring. Qed. Definition mul_helper (xi yi zi : FF) := let xly := FImult2 (lower xi) yi in let xuy := FImult2 (upper xi) yi in Fle2 (lower zi) (lower xly) && Fle2 (lower zi) (lower xuy) && Fle2 (upper xly) (upper zi) && Fle2 (upper xuy) (upper zi). Theorem bnd_div_of_rel_bnd_div : forall x1 x2 y : R, forall xi yi zi : FF, REL x1 x2 xi -> BND (x2 / y) yi -> NZR y -> mul_helper xi yi zi = true -> BND ((x1 - x2) / y) zi. Proof. intros x1 x2 y xi yi zi (ex,(Hx1,Hx2)) Hxy Zy Hb. rewrite Hx2. replace ((x2 * (1 + ex) - x2) / y)%R with (ex * (x2 / y))%R by now field. generalize (andb_prop _ _ Hb). clear Hb. intros (Hb, H4). generalize (andb_prop _ _ Hb). clear Hb. intros (Hb, H3). generalize (andb_prop _ _ Hb). clear Hb. intros (H1, H2). apply Fle2_correct in H1. apply Fle2_correct in H2. apply Fle2_correct in H3. apply Fle2_correct in H4. assert (H5 := FImult2_correct (lower xi) yi _ Hxy). assert (H6 := FImult2_correct (upper xi) yi _ Hxy). destruct (Rle_or_lt 0 (x2 / y)) as [Hy|Hy]. split. apply Rle_trans with (1 := H1). apply Rle_trans with (1 := proj1 H5). now apply monotony_2p. apply Rle_trans with (2 := H4). apply Rle_trans with (2 := proj2 H6). now apply monotony_2p. apply Rlt_le in Hy. split. apply Rle_trans with (1 := H2). apply Rle_trans with (1 := proj1 H6). now apply monotony_2n. apply Rle_trans with (2 := H3). apply Rle_trans with (2 := proj2 H5). now apply monotony_2n. Qed. Lemma lin_of_lin_rel1_generic : forall f, (forall x y : R, forall xi yi zi : FF, BND x xi -> BND y yi -> f xi yi zi = true -> BND (x * y) zi) -> forall (a b c : R) (xi yi zi : FF), LIN a b xi -> REL c a yi -> f xi (one_plus yi) zi = true -> LIN c b zi. Proof. intros f Hf a b c xi yi zi [x [Hx1 Hx2]] [y [Hy1 Hy2]] Hb. rewrite Hy2, Hx2. exists (x * (1 + y))%R. split. 2: ring. apply Hf with (1 := Hx1) (3 := Hb). now apply one_plus_correct. Qed. Definition lin_of_lin_rel1_p := lin_of_lin_rel1_generic _ mul_pp. Definition lin_of_lin_rel1_o := lin_of_lin_rel1_generic _ mul_op. Definition lin_of_lin_rel1_n := lin_of_lin_rel1_generic _ mul_np. Lemma lin_of_lin_rel2_generic : forall f, (forall x y : R, forall xi yi zi : FF, BND x xi -> BND y yi -> f xi yi zi = true -> BND (x / y) zi) -> (forall xi yi zi : FF, f xi yi zi = true -> Fpos (lower yi) = true) -> forall (a b c : R) (xi yi zi : FF), LIN a b xi -> REL c b yi -> f xi (one_plus yi) zi = true -> LIN a c zi. Proof. intros f Hf1 Hf2 a b c xi yi zi [x [Hx1 Hx2]] [y [Hy1 Hy2]] Hb. rewrite Hy2, Hx2. exists (x / (1 + y))%R. split. { apply Hf1 with (1 := Hx1) (3 := Hb). now apply one_plus_correct. } field. apply Rgt_not_eq, Rlt_le_trans with (lower (one_plus yi)). apply Fpos_correct. apply Hf2 with (1 := Hb). now apply one_plus_correct. Qed. Lemma lin_of_lin_rel2_p : forall (a b c : R) (xi yi zi : FF), LIN a b xi -> REL c b yi -> div_pp_helper xi (one_plus yi) zi = true -> LIN a c zi. Proof. apply (lin_of_lin_rel2_generic _ div_pp). intros xi yi zi. unfold div_pp_helper. now destruct Fpos. Qed. Lemma lin_of_lin_rel2_o : forall (a b c : R) (xi yi zi : FF), LIN a b xi -> REL c b yi -> div_op_helper xi (one_plus yi) zi = true -> LIN a c zi. Proof. apply (lin_of_lin_rel2_generic _ div_op). intros xi yi zi. unfold div_op_helper. now destruct Fpos. Qed. Lemma lin_of_lin_rel2_n : forall (a b c : R) (xi yi zi : FF), LIN a b xi -> REL c b yi -> div_np_helper xi (one_plus yi) zi = true -> LIN a c zi. Proof. apply (lin_of_lin_rel2_generic _ div_np). intros xi yi zi. unfold div_np_helper. now destruct Fpos. Qed. Lemma lin_of_lin_rel3_generic : forall f, (forall x y : R, forall xi yi zi : FF, BND x xi -> BND y yi -> f xi yi zi = true -> BND (x / y) zi) -> (forall xi yi zi : FF, f xi yi zi = true -> Fpos (lower yi) = true) -> forall (a b c : R) (xi yi zi : FF), LIN a b xi -> REL a c yi -> f xi (one_plus yi) zi = true -> LIN c b zi. Proof. intros f Hf1 Hf2 a b c xi yi zi [x [Hx1 Hx2]] [y [Hy1 Hy2]] Hb. exists (x / (1 + y))%R. unfold Rdiv. split. { apply Hf1 with (1 := Hx1) (3 := Hb). now apply one_plus_correct. } rewrite <- Rmult_assoc, <- Hx2, Hy2. field. apply Rgt_not_eq, Rlt_le_trans with (lower (one_plus yi)). apply Fpos_correct. apply Hf2 with (1 := Hb). now apply one_plus_correct. Qed. Lemma lin_of_lin_rel3_p : forall (a b c : R) (xi yi zi : FF), LIN a b xi -> REL a c yi -> div_pp_helper xi (one_plus yi) zi = true -> LIN c b zi. Proof. apply (lin_of_lin_rel3_generic _ div_pp). intros xi yi zi. unfold div_pp_helper. now destruct Fpos. Qed. Lemma lin_of_lin_rel3_o : forall (a b c : R) (xi yi zi : FF), LIN a b xi -> REL a c yi -> div_op_helper xi (one_plus yi) zi = true -> LIN c b zi. Proof. apply (lin_of_lin_rel3_generic _ div_op). intros xi yi zi. unfold div_op_helper. now destruct Fpos. Qed. Lemma lin_of_lin_rel3_n : forall (a b c : R) (xi yi zi : FF), LIN a b xi -> REL a c yi -> div_np_helper xi (one_plus yi) zi = true -> LIN c b zi. Proof. apply (lin_of_lin_rel3_generic _ div_np). intros xi yi zi. unfold div_np_helper. now destruct Fpos. Qed. coq-gappalib-coq-1.10.0-df59b68361b1efbd697b17c40f7fae4a35991c44/src/Gappa_real.v000066400000000000000000000577151517666064600255170ustar00rootroot00000000000000From Coq Require Import Reals. From Flocq Require Import Raux. Theorem IRsubset : forall yl yu zl zu : R, (zl <= yl)%R -> (yu <= zu)%R -> forall y : R, (yl <= y <= yu)%R -> (zl <= y <= zu)%R. Proof. intros yl yu zl zu Hzl Hzu y (Hyl,Hyu). split. apply Rle_trans with (1 := Hzl) (2 := Hyl). apply Rle_trans with (1 := Hyu) (2 := Hzu). Qed. Theorem IRplus : forall xl xu yl yu zl zu : R, (zl <= xl + yl)%R -> (xu + yu <= zu)%R -> forall x y : R, (xl <= x <= xu)%R -> (yl <= y <= yu)%R -> (zl <= x + y <= zu)%R. Proof. intros xl xu yl yu zl zu Hzl Hzu x y (Hxl,Hxu) (Hyl,Hyu). apply IRsubset with (1 := Hzl) (2 := Hzu). split. apply Rplus_le_compat with (1 := Hxl) (2 := Hyl). apply Rplus_le_compat with (1 := Hxu) (2 := Hyu). Qed. Theorem IRopp : forall yl yu zl zu : R, (zl <= -yu)%R -> (-yl <= zu)%R -> forall y : R, (yl <= y <= yu)%R -> (zl <= -y <= zu)%R. Proof. intros yl yu zl zu Hzl Hzu y (Hyl,Hyu). apply IRsubset with (1 := Hzl) (2 := Hzu). split. apply Ropp_le_contravar with (1 := Hyu). apply Ropp_le_contravar with (1 := Hyl). Qed. Theorem IRminus : forall xl xu yl yu zl zu : R, (zl <= xl - yu)%R -> (xu - yl <= zu)%R -> forall x y : R, (xl <= x <= xu)%R -> (yl <= y <= yu)%R -> (zl <= x - y <= zu)%R. Proof. unfold Rminus. intros xl xu yl yu zl zu Hzl Hzu x y Hx Hy. apply IRplus with (1 := Hzl) (2 := Hzu) (3 := Hx). apply IRopp with (3 := Hy) ; auto with real. Qed. Lemma monotony_1p : forall a x y : R, (0 <= a)%R -> (x <= y)%R -> (a * x <= a * y)%R. Proof. auto with real. Qed. Lemma monotony_2p : forall a x y : R, (0 <= a)%R -> (x <= y)%R -> (x * a <= y * a)%R. Proof. auto with real. Qed. Lemma monotony_1n : forall a x y : R, (a <= 0)%R -> (x <= y)%R -> (a * y <= a * x)%R. Proof. auto with real. Qed. Lemma monotony_2n : forall a x y : R, (a <= 0)%R -> (x <= y)%R -> (y * a <= x * a)%R. Proof. intros a x y Ha H. rewrite Rmult_comm. rewrite (Rmult_comm x). apply Rge_le. auto with real. Qed. Theorem IRmult_pp : forall xl xu yl yu zl zu : R, (0 <= xl)%R -> (0 <= yl)%R -> (zl <= xl * yl)%R -> (xu * yu <= zu)%R -> forall x y : R, (xl <= x <= xu)%R -> (yl <= y <= yu)%R -> (zl <= x * y <= zu)%R. Proof. intros xl xu yl yu zl zu Hx Hy Hzl Hzu x y (Hxl,Hxu) (Hyl,Hyu). apply IRsubset with (1 := Hzl) (2 := Hzu). split. apply Rle_trans with (xl * y)%R. exact (monotony_1p _ _ _ Hx Hyl). exact (monotony_2p _ _ _ (Rle_trans _ _ _ Hy Hyl) Hxl). apply Rle_trans with (x * yu)%R. exact (monotony_1p _ _ _ (Rle_trans _ _ _ Hx Hxl) Hyu). exact (monotony_2p _ _ _ (Rle_trans _ _ _ Hy (Rle_trans _ _ _ Hyl Hyu)) Hxu). Qed. Theorem IRmult_po : forall xl xu yl yu zl zu : R, (0 <= xl)%R -> (yl <= 0)%R -> (0 <= yu)%R -> (zl <= xu * yl)%R -> (xu * yu <= zu)%R -> forall x y : R, (xl <= x <= xu)%R -> (yl <= y <= yu)%R -> (zl <= x * y <= zu)%R. Proof. intros xl xu yl yu zl zu Hx Hy1 Hy2 Hzl Hzu x y (Hxl,Hxu) (Hyl,Hyu). apply IRsubset with (1 := Hzl) (2 := Hzu). split. apply Rle_trans with (x * yl)%R. exact (monotony_2n _ _ _ Hy1 Hxu). exact (monotony_1p _ _ _ (Rle_trans _ _ _ Hx Hxl) Hyl). apply Rle_trans with (x * yu)%R. exact (monotony_1p _ _ _ (Rle_trans _ _ _ Hx Hxl) Hyu). exact (monotony_2p _ _ _ Hy2 Hxu). Qed. Theorem IRmult_pn : forall xl xu yl yu zl zu : R, (0 <= xl)%R -> (yu <= 0)%R -> (zl <= xu * yl)%R -> (xl * yu <= zu)%R -> forall x y : R, (xl <= x <= xu)%R -> (yl <= y <= yu)%R -> (zl <= x * y <= zu)%R. Proof. intros xl xu yl yu zl zu Hx Hy Hzl Hzu x y (Hxl,Hxu) (Hyl,Hyu). apply IRsubset with (1 := Hzl) (2 := Hzu). split. apply Rle_trans with (xu * y)%R. exact (monotony_1p _ _ _ (Rle_trans _ _ _ Hx (Rle_trans _ _ _ Hxl Hxu)) Hyl). exact (monotony_2n _ _ _ (Rle_trans _ _ _ Hyu Hy) Hxu). apply Rle_trans with (x * yu)%R. exact (monotony_1p _ _ _ (Rle_trans _ _ _ Hx Hxl) Hyu). exact (monotony_2n _ _ _ Hy Hxl). Qed. Theorem IRmult_op : forall xl xu yl yu zl zu : R, (xl <= 0)%R -> (0 <= xu)%R -> (0 <= yl)%R -> (zl <= xl * yu)%R -> (xu * yu <= zu)%R -> forall x y : R, (xl <= x <= xu)%R -> (yl <= y <= yu)%R -> (zl <= x * y <= zu)%R. Proof. intros xl xu yl yu zl zu Hx1 Hx2 Hy Hzl Hzu x y (Hxl,Hxu) (Hyl,Hyu). apply IRsubset with (1 := Hzl) (2 := Hzu). split. apply Rle_trans with (xl * y)%R. exact (monotony_1n _ _ _ Hx1 Hyu). exact (monotony_2p _ _ _ (Rle_trans _ _ _ Hy Hyl) Hxl). apply Rle_trans with (xu * y)%R. exact (monotony_2p _ _ _ (Rle_trans _ _ _ Hy Hyl) Hxu). exact (monotony_1p _ _ _ Hx2 Hyu). Qed. Theorem IRmult_oo : forall xl xu yl yu zl zu : R, (xl <= 0)%R -> (0 <= xu)%R -> (yl <= 0)%R -> (0 <= yu)%R -> (zl <= xu * yl)%R -> (zl <= xl * yu)%R -> (xl * yl <= zu)%R -> (xu * yu <= zu)%R -> forall x y : R, (xl <= x <= xu)%R -> (yl <= y <= yu)%R -> (zl <= x * y <= zu)%R. Proof. intros xl xu yl yu zl zu Hx1 Hx2 Hy1 Hy2 Hzl1 Hzl2 Hzu1 Hzu2 x y (Hxl,Hxu) (Hyl,Hyu). case (Rlt_le_dec 0 x) ; intro H. generalize (Rlt_le _ _ H). clear H. intro H. split. apply Rle_trans with (1 := Hzl1). apply Rle_trans with (x * yl)%R. exact (monotony_2n _ _ _ Hy1 Hxu). exact (monotony_1p _ _ _ H Hyl). apply Rle_trans with (2 := Hzu2). apply Rle_trans with (x * yu)%R. exact (monotony_1p _ _ _ H Hyu). exact (monotony_2p _ _ _ Hy2 Hxu). split. apply Rle_trans with (1 := Hzl2). apply Rle_trans with (x * yu)%R. exact (monotony_2p _ _ _ Hy2 Hxl). exact (monotony_1n _ _ _ H Hyu). apply Rle_trans with (2 := Hzu1). apply Rle_trans with (x * yl)%R. exact (monotony_1n _ _ _ H Hyl). exact (monotony_2n _ _ _ Hy1 Hxl). Qed. Theorem IRmult_on : forall xl xu yl yu zl zu : R, (xl <= 0)%R -> (0 <= xu)%R -> (yu <= 0)%R -> (zl <= xu * yl)%R -> (xl * yl <= zu)%R -> forall x y : R, (xl <= x <= xu)%R -> (yl <= y <= yu)%R -> (zl <= x * y <= zu)%R. Proof. intros xl xu yl yu zl zu Hx1 Hx2 Hy Hzl Hzu x y (Hxl,Hxu) (Hyl,Hyu). apply IRsubset with (1 := Hzl) (2 := Hzu). split. apply Rle_trans with (xu * y)%R. exact (monotony_1p _ _ _ Hx2 Hyl). exact (monotony_2n _ _ _ (Rle_trans _ _ _ Hyu Hy) Hxu). apply Rle_trans with (xl * y)%R. exact (monotony_2n _ _ _ (Rle_trans _ _ _ Hyu Hy) Hxl). exact (monotony_1n _ _ _ Hx1 Hyl). Qed. Theorem IRmult_np : forall xl xu yl yu zl zu : R, (xu <= 0)%R -> (0 <= yl)%R -> (zl <= xl * yu)%R -> (xu * yl <= zu)%R -> forall x y : R, (xl <= x <= xu)%R -> (yl <= y <= yu)%R -> (zl <= x * y <= zu)%R. Proof. intros xl xu yl yu zl zu Hx Hy Hzl Hzu x y (Hxl,Hxu) (Hyl,Hyu). apply IRsubset with (1 := Hzl) (2 := Hzu). split. apply Rle_trans with (x * yu)%R. exact (monotony_2p _ _ _ (Rle_trans _ _ _ Hy (Rle_trans _ _ _ Hyl Hyu)) Hxl). exact (monotony_1n _ _ _ (Rle_trans _ _ _ Hxu Hx) Hyu). apply Rle_trans with (xu * y)%R. exact (monotony_2p _ _ _ (Rle_trans _ _ _ Hy Hyl) Hxu). exact (monotony_1n _ _ _ Hx Hyl). Qed. Theorem IRmult_no : forall xl xu yl yu zl zu : R, (xu <= 0)%R -> (yl <= 0)%R -> (0 <= yu)%R -> (zl <= xl * yu)%R -> (xl * yl <= zu)%R -> forall x y : R, (xl <= x <= xu)%R -> (yl <= y <= yu)%R -> (zl <= x * y <= zu)%R. Proof. intros xl xu yl yu zl zu Hx Hy1 Hy2 Hzl Hzu x y (Hxl,Hxu) (Hyl,Hyu). apply IRsubset with (1 := Hzl) (2 := Hzu). split. apply Rle_trans with (x * yu)%R. exact (monotony_2p _ _ _ Hy2 Hxl). exact (monotony_1n _ _ _ (Rle_trans _ _ _ Hxu Hx) Hyu). apply Rle_trans with (x * yl)%R. exact (monotony_1n _ _ _ (Rle_trans _ _ _ Hxu Hx) Hyl). exact (monotony_2n _ _ _ Hy1 Hxl). Qed. Theorem IRmult_nn : forall xl xu yl yu zl zu : R, (xu <= 0)%R -> (yu <= 0)%R -> (zl <= xu * yu)%R -> (xl * yl <= zu)%R -> forall x y : R, (xl <= x <= xu)%R -> (yl <= y <= yu)%R -> (zl <= x * y <= zu)%R. Proof. intros xl xu yl yu zl zu Hx Hy Hzl Hzu x y (Hxl,Hxu) (Hyl,Hyu). apply IRsubset with (1 := Hzl) (2 := Hzu). split. apply Rle_trans with (xu * y)%R. exact (monotony_1n _ _ _ Hx Hyu). exact (monotony_2n _ _ _ (Rle_trans _ _ _ Hyu Hy) Hxu). apply Rle_trans with (xl * y)%R. exact (monotony_2n _ _ _ (Rle_trans _ _ _ Hyu Hy) Hxl). exact (monotony_1n _ _ _ (Rle_trans _ _ _ (Rle_trans _ _ _ Hxl Hxu) Hx) Hyl). Qed. Theorem IRmult_uo : forall xl xu yl yu zl zu : R, (yl <= 0)%R -> (0 <= yu)%R -> (zl <= xu * yl)%R -> (xl * yl <= zu)%R -> (zl <= xl * yu)%R -> (xu * yu <= zu)%R -> forall x y : R, (xl <= x <= xu)%R -> (yl <= y <= yu)%R -> (zl <= x * y <= zu)%R. Proof. intros xl xu yl yu zl zu Hy1 Hy2 Hzl1 Hzu1 Hzl2 Hzu2 x y [Hxl Hxu] [Hyl Hyu]. split. - destruct (Rlt_or_le x 0) as [Hx|Hx]. + apply Rle_trans with (1 := Hzl2). apply Rle_trans with (x * yu)%R. now apply monotony_2p. apply Rlt_le in Hx. now apply monotony_1n. + apply Rle_trans with (1 := Hzl1). apply Rle_trans with (x * yl)%R. now apply monotony_2n. now apply monotony_1p. - destruct (Rlt_or_le x 0) as [Hx|Hx]. + apply Rle_trans with (2 := Hzu1). apply Rle_trans with (x * yl)%R. apply Rlt_le in Hx. now apply monotony_1n. now apply monotony_2n. + apply Rle_trans with (2 := Hzu2). apply Rle_trans with (x * yu)%R. now apply monotony_1p. now apply monotony_2p. Qed. Inductive interval_sign (xl xu : R) : Set := | Nsign : (xu <= 0)%R -> interval_sign xl xu | Msign : (xl <= 0)%R -> (0 <= xu)%R -> interval_sign xl xu | Psign : (0 <= xl)%R -> interval_sign xl xu. Lemma interval_sign_correct : forall xl xu : R, (xl <= xu)%R -> interval_sign xl xu. Proof. intros xl xu H. case (Rlt_le_dec xu 0); intro H0. exact (Nsign _ _ (Rlt_le _ _ H0)). case (Rlt_le_dec xl 0); intro H1. exact (Msign _ _ (Rlt_le _ _ H1) H0). exact (Psign _ _ H1). Qed. Lemma Rmin_trans : forall a b c : R, (c <= Rmin a b)%R -> (c <= a)%R /\ (c <= b)%R. Proof. intros a b c H. split. exact (Rle_trans _ _ _ H (Rmin_l _ _)). exact (Rle_trans _ _ _ H (Rmin_r _ _)). Qed. Lemma Rmax_trans : forall a b c : R, (Rmax a b <= c)%R -> (a <= c)%R /\ (b <= c)%R. Proof. intros a b c H. split. exact (Rle_trans _ _ _ (RmaxLess1 _ _) H). exact (Rle_trans _ _ _ (RmaxLess2 _ _) H). Qed. Lemma IRmult_minmax : forall xl xu yl yu zl zu : R, (zl <= Rmin (Rmin (xl * yl) (xl * yu)) (Rmin (xu * yl) (xu * yu)))%R -> (Rmax (Rmax (xl * yl) (xl * yu)) (Rmax (xu * yl) (xu * yu)) <= zu)%R -> forall x y : R, (xl <= x <= xu)%R -> (yl <= y <= yu)%R -> (zl <= x * y <= zu)%R. Proof. intros xl xu yl yu zl zu Hzl Hzu x y Hx Hy. decompose [and] (Rmin_trans _ _ _ Hzl). decompose [and] (Rmin_trans _ _ _ H). decompose [and] (Rmin_trans _ _ _ H0). clear Hzl H H0. decompose [and] (Rmax_trans _ _ _ Hzu). decompose [and] (Rmax_trans _ _ _ H). decompose [and] (Rmax_trans _ _ _ H0). clear Hzu H H0. case (interval_sign_correct _ _ (Rle_trans _ _ _ (proj1 Hx) (proj2 Hx))) ; case (interval_sign_correct _ _ (Rle_trans _ _ _ (proj1 Hy) (proj2 Hy))) ; intros. apply IRmult_nn with xl xu yl yu ; assumption. apply IRmult_no with xl xu yl yu ; assumption. apply IRmult_np with xl xu yl yu ; assumption. apply IRmult_on with xl xu yl yu ; assumption. apply IRmult_oo with xl xu yl yu ; assumption. apply IRmult_op with xl xu yl yu ; assumption. apply IRmult_pn with xl xu yl yu ; assumption. apply IRmult_po with xl xu yl yu ; assumption. apply IRmult_pp with xl xu yl yu ; assumption. Qed. Lemma Rle_Rinv_pos : forall x y : R, (0 < x)%R -> (x <= y)%R -> (/y <= /x)%R. Proof. intros x y Hx H. apply Rle_Rinv with (1 := Hx) (3 := H). apply Rlt_le_trans with (1 := Hx) (2 := H). Qed. Lemma Rle_Rinv_neg : forall x y : R, (y < 0)%R -> (x <= y)%R -> (/y <= /x)%R. Proof. intros x y Hy H. apply Ropp_le_cancel. repeat rewrite <- Rinv_opp. apply Rle_Rinv_pos. apply Ropp_0_gt_lt_contravar with (1 := Hy). apply Ropp_le_contravar with (1 := H). Qed. Lemma IRinv_p : forall yl yu zl zu : R, (0 < yl)%R -> (zl <= /yu)%R -> (/yl <= zu)%R -> forall y : R, (yl <= y <= yu)%R -> (zl <= /y <= zu)%R. Proof. intros yl yu zl zu Hy Hzl Hzu y (Hyl,Hyu). apply IRsubset with (1 := Hzl) (2 := Hzu). split. apply Rle_Rinv_pos with (2 := Hyu). exact (Rlt_le_trans _ _ _ Hy Hyl). exact (Rle_Rinv_pos _ _ Hy Hyl). Qed. Lemma IRinv_n : forall yl yu zl zu, (yu < 0)%R -> (zl <= /yu)%R -> (/yl <= zu)%R -> forall y : R, (yl <= y <= yu)%R -> (zl <= /y <= zu)%R. Proof. intros yl yu zl zu Hy Hzl Hzu y (Hyl,Hyu). apply IRsubset with (1 := Hzl) (2 := Hzu). split. exact (Rle_Rinv_neg _ _ Hy Hyu). apply Rle_Rinv_neg with (2 := Hyl). exact (Rle_lt_trans _ _ _ Hyu Hy). Qed. Lemma IRinv_disj : forall yl yu zl zu : R, (yu < 0)%R \/ (0 < yl)%R -> (zl <= /yu)%R -> (/yl <= zu)%R -> forall y : R, (yl <= y <= yu)%R -> (zl <= /y <= zu)%R. Proof. intros yl yu zl zu [Hy2|Hy1] Hzl Hzu y Hy. exact (IRinv_n _ _ _ _ Hy2 Hzl Hzu _ Hy). exact (IRinv_p _ _ _ _ Hy1 Hzl Hzu _ Hy). Qed. Lemma IRdiv_minmax : forall xl xu yl yu zl zu : R, (yu < 0)%R \/ (yl > 0)%R -> (zl <= Rmin (Rmin (xl / yu) (xl / yl)) (Rmin (xu / yu) (xu / yl)))%R -> (Rmax (Rmax (xl / yu) (xl / yl)) (Rmax (xu / yu) (xu / yl)) <= zu)%R -> forall x y : R, (xl <= x <= xu)%R -> (yl <= y <= yu)%R -> (zl <= x / y <= zu)%R. Proof. unfold Rdiv. intros xl xu yl yu zl zu H Hzl Hzu x y Hx Hy. apply (IRmult_minmax _ _ (/yu) (/yl) _ _ Hzl Hzu _ (/y) Hx). apply (IRinv_disj _ _ (/yu) (/yl) H) with (3 := Hy) ; auto with real. Qed. Lemma IRdiv_aux_p : forall yl yu y : R, (0 < yl)%R -> (yl <= y <= yu)%R -> (0 <= / yl)%R /\ (0 <= / yu)%R /\ (yl <> 0)%R /\ (yu <> 0)%R /\ (/ yu <= /y <= / yl)%R. Proof. intros yl yu y Hyl Hy. split. left. apply Rinv_0_lt_compat. exact Hyl. split. left. apply Rinv_0_lt_compat. exact (Rlt_le_trans _ _ _ Hyl (Rle_trans _ _ _ (proj1 Hy) (proj2 Hy))). split. apply Rgt_not_eq. exact Hyl. split. apply Rgt_not_eq. exact (Rlt_le_trans _ _ _ Hyl (Rle_trans _ _ _ (proj1 Hy) (proj2 Hy))). split. exact (Rle_Rinv_pos _ _ (Rlt_le_trans _ _ _ Hyl (proj1 Hy)) (proj2 Hy)). exact (Rle_Rinv_pos _ _ Hyl (proj1 Hy)). Qed. Theorem IRdiv_pp : forall xl xu yl yu zl zu : R, (0 <= xl)%R -> (0 < yl)%R -> (yu * zl <= xl)%R -> (xu <= yl * zu)%R -> forall x y : R, (xl <= x <= xu)%R -> (yl <= y <= yu)%R -> (zl <= x / y <= zu)%R. Proof. intros xl xu yl yu zl zu Hxl Hyl Hzl Hzu x y Hx Hy. generalize (IRdiv_aux_p _ _ _ Hyl Hy). intros (Hy1, (Hy2, (Hy3, (Hy4, Hy5)))). unfold Rdiv. apply IRmult_pp with (1 := Hxl) (2 := Hy2) (5 := Hx) (6 := Hy5). replace zl with (yu * zl * / yu)%R. exact (monotony_2p _ _ _ Hy2 Hzl). field. exact Hy4. replace zu with (yl * zu * / yl)%R. exact (monotony_2p _ _ _ Hy1 Hzu). field. exact Hy3. Qed. Theorem IRdiv_op : forall xl xu yl yu zl zu : R, (xl <= 0)%R -> (0 <= xu)%R -> (0 < yl)%R -> (yl * zl <= xl)%R -> (xu <= yl * zu)%R -> forall x y : R, (xl <= x <= xu)%R -> (yl <= y <= yu)%R -> (zl <= x / y <= zu)%R. Proof. intros xl xu yl yu zl zu Hxl Hxu Hyl Hzl Hzu x y Hx Hy. generalize (IRdiv_aux_p _ _ _ Hyl Hy). intros (Hy1, (Hy2, (Hy3, (Hy4, Hy5)))). unfold Rdiv. apply IRmult_op with (1 := Hxl) (2 := Hxu) (3 := Hy2) (6 := Hx) (7 := Hy5). replace zl with (yl * zl * / yl)%R. exact (monotony_2p _ _ _ Hy1 Hzl). field. exact Hy3. replace zu with (yl * zu * / yl)%R. exact (monotony_2p _ _ _ Hy1 Hzu). field. exact Hy3. Qed. Theorem IRdiv_np : forall xl xu yl yu zl zu : R, (xu <= 0)%R -> (0 < yl)%R -> (yl * zl <= xl)%R -> (xu <= yu * zu)%R -> forall x y : R, (xl <= x <= xu)%R -> (yl <= y <= yu)%R -> (zl <= x / y <= zu)%R. Proof. intros xl xu yl yu zl zu Hxu Hyl Hzl Hzu x y Hx Hy. generalize (IRdiv_aux_p _ _ _ Hyl Hy). intros (Hy1, (Hy2, (Hy3, (Hy4, Hy5)))). unfold Rdiv. apply IRmult_np with (1 := Hxu) (2 := Hy2) (5 := Hx) (6 := Hy5). replace zl with (yl * zl * / yl)%R. exact (monotony_2p _ _ _ Hy1 Hzl). field. exact Hy3. replace zu with (yu * zu * / yu)%R. exact (monotony_2p _ _ _ Hy2 Hzu). field. exact Hy4. Qed. Lemma IRdiv_aux_n : forall yl yu y : R, (yu < 0)%R -> (yl <= y <= yu)%R -> (/ yl <= 0)%R /\ (/ yu <= 0)%R /\ (yl <> 0)%R /\ (yu <> 0)%R /\ (/ yu <= /y <= / yl)%R. Proof. intros yl yu y Hyu Hy. split. left. apply Rinv_lt_0_compat. exact (Rle_lt_trans _ _ _ (Rle_trans _ _ _ (proj1 Hy) (proj2 Hy)) Hyu). split. left. apply Rinv_lt_0_compat. exact Hyu. split. apply Rlt_not_eq. exact (Rle_lt_trans _ _ _ (Rle_trans _ _ _ (proj1 Hy) (proj2 Hy)) Hyu). split. apply Rlt_not_eq. exact Hyu. split. exact (Rle_Rinv_neg _ _ Hyu (proj2 Hy)). exact (Rle_Rinv_neg _ _ (Rle_lt_trans _ _ _ (proj2 Hy) Hyu) (proj1 Hy)). Qed. Theorem IRdiv_pn : forall xl xu yl yu zl zu : R, (0 <= xl)%R -> (yu < 0)%R -> (xu <= yu * zl)%R -> (yl * zu <= xl)%R -> forall x y : R, (xl <= x <= xu)%R -> (yl <= y <= yu)%R -> (zl <= x / y <= zu)%R. Proof. intros xl xu yl yu zl zu Hxl Hyu Hzl Hzu x y Hx Hy. generalize (IRdiv_aux_n _ _ _ Hyu Hy). intros (Hy1, (Hy2, (Hy3, (Hy4, Hy5)))). unfold Rdiv. apply IRmult_pn with (1 := Hxl) (2 := Hy1) (5 := Hx) (6 := Hy5). replace zl with (yu * zl * / yu)%R. exact (monotony_2n _ _ _ Hy2 Hzl). field. exact Hy4. replace zu with (yl * zu * / yl)%R. exact (monotony_2n _ _ _ Hy1 Hzu). field. exact Hy3. Qed. Theorem IRdiv_on : forall xl xu yl yu zl zu : R, (xl <= 0)%R -> (0 <= xu)%R -> (yu < 0)%R -> (xu <= yu * zl)%R -> (yu * zu <= xl)%R -> forall x y : R, (xl <= x <= xu)%R -> (yl <= y <= yu)%R -> (zl <= x / y <= zu)%R. Proof. intros xl xu yl yu zl zu Hxl Hxu Hyu Hzl Hzu x y Hx Hy. generalize (IRdiv_aux_n _ _ _ Hyu Hy). intros (Hy1, (Hy2, (Hy3, (Hy4, Hy5)))). unfold Rdiv. apply IRmult_on with (1 := Hxl) (2 := Hxu) (3 := Hy1) (6 := Hx) (7 := Hy5). replace zl with (yu * zl * / yu)%R. exact (monotony_2n _ _ _ Hy2 Hzl). field. exact Hy4. replace zu with (yu * zu * / yu)%R. exact (monotony_2n _ _ _ Hy2 Hzu). field. exact Hy4. Qed. Theorem IRdiv_nn : forall xl xu yl yu zl zu : R, (xu <= 0)%R -> (yu < 0)%R -> (xu <= yl * zl)%R -> (yu * zu <= xl)%R -> forall x y : R, (xl <= x <= xu)%R -> (yl <= y <= yu)%R -> (zl <= x / y <= zu)%R. Proof. intros xl xu yl yu zl zu Hxu Hyu Hzl Hzu x y Hx Hy. generalize (IRdiv_aux_n _ _ _ Hyu Hy). intros (Hy1, (Hy2, (Hy3, (Hy4, Hy5)))). unfold Rdiv. apply IRmult_nn with (1 := Hxu) (2 := Hy1) (5 := Hx) (6 := Hy5). replace zl with (yl * zl * / yl)%R. exact (monotony_2n _ _ _ Hy1 Hzl). field. exact Hy3. replace zu with (yu * zu * / yu)%R. exact (monotony_2n _ _ _ Hy2 Hzu). field. exact Hy4. Qed. Theorem IRdiv_aa : forall xu yl zl zu : R, (0 < yl)%R -> (yl * zl <= (-xu))%R -> (xu <= yl * zu)%R -> forall x y : R, (Rabs x <= xu)%R -> (yl <= Rabs y)%R -> (zl <= x / y <= zu)%R. Proof. intros xu yl zl zu Hyl Hzl Hzu x y Hx Hy. assert (Hx2: (0 <= xu)%R). { apply Rle_trans with (2 := Hx). now apply Rabs_pos. } assert (Hx1: (-xu <= 0)%R). { rewrite <- Ropp_0. now apply Ropp_le_contravar. } destruct (Rle_or_lt 0 y) as [Sy|Sy]. - apply IRdiv_op with (yu := y) (1 := Hx1) (2 := Hx2) (3 := Hyl) (4 := Hzl) (5 := Hzu). now apply Rabs_le_inv. refine (conj _ (Rle_refl _)). now rewrite <- (Rabs_pos_eq y). - replace (x / y)%R with ((-x) / (-y))%R. 2: rewrite Rdiv_opp_r ; unfold Rdiv ; ring. apply IRdiv_op with (yu := Ropp y) (1 := Hx1) (2 := Hx2) (3 := Hyl) (4 := Hzl) (5 := Hzu). apply Rabs_le_inv. now rewrite Rabs_Ropp. refine (conj _ (Rle_refl _)). now rewrite <- (Rabs_left y). Qed. Theorem IRsquare_o : forall yl yu zl zu : R, (yl <= 0)%R -> (0 <= yu)%R -> (zl <= 0)%R -> (yl * yl <= zu)%R -> (yu * yu <= zu)%R -> forall y : R, (yl <= y <= yu)%R -> (zl <= y * y <= zu)%R. Proof. intros yl yu zl zu Hy1 Hy2 Hzl Hzu1 Hzu2 y (Hyl,Hyu). split. fold (Rsqr y). apply Rle_trans with 0%R ; auto with real. case (Rlt_le_dec 0 y) ; intro H. generalize (Rlt_le _ _ H). clear H. intro H. apply Rle_trans with (yu * yu)%R ; auto with real. apply Rle_trans with (2 := Hzu1). apply Rle_trans with (y * yl)%R. exact (monotony_1n _ _ _ H Hyl). exact (monotony_2n _ _ _ Hy1 Hyl). Qed. Theorem IRsqrt : forall yl yu zl zu : R, match (Rlt_le_dec 0 zl) with | left _ => (zl * zl <= yl)%R | right _ => (0 <= yl)%R end -> (0 <= zu)%R -> (yu <= zu * zu)%R -> forall y : R, (yl <= y <= yu)%R -> (zl <= sqrt y <= zu)%R. Proof. intros yl yu zl zu. case (Rlt_le_dec 0 zl) ; intros Hzl1 Hzl2 Hzu1 Hzu2 y (Hyl,Hyu). assert (H1: (zl * zl <= y)%R). apply Rle_trans with (1 := Hzl2) (2 := Hyl). assert (H2: (0 <= y)%R). apply Rle_trans with (2 := H1). exact (Rle_0_sqr _). split. rewrite <- (sqrt_square zl). apply sqrt_le_1. 3: exact H1. exact (Rle_0_sqr _). exact H2. exact (Rlt_le _ _ Hzl1). rewrite <- (sqrt_square zu). 2: exact Hzu1. apply sqrt_le_1. exact H2. exact (Rle_0_sqr _). apply Rle_trans with (1 := Hyu) (2 := Hzu2). split. apply Rle_trans with (1 := Hzl1). apply sqrt_positivity. apply Rle_trans with (1 := Hzl2) (2 := Hyl). rewrite <- (sqrt_square zu). 2: exact Hzu1. apply sqrt_le_1. apply Rle_trans with (1 := Hzl2) (2 := Hyl). exact (Rle_0_sqr _). apply Rle_trans with (1 := Hyu) (2 := Hzu2). Qed. Theorem IRcompose : forall xl xu yl yu zl zu : R, (-1 <= xl)%R -> (-1 <= yl)%R -> (zl <= xl + yl + xl * yl)%R -> (xu + yu + xu * yu <= zu)%R -> forall x y : R, (xl <= x <= xu)%R -> (yl <= y <= yu)%R -> (zl <= x + y + x * y <= zu)%R. Proof. intros xl xu yl yu zl zu Hx Hy Hzl Hzu x y (Hxl,Hxu) (Hyl,Hyu). replace (x + y + x * y)%R with ((1 + x) * (1 + y) - 1)%R. 2: ring. assert (H : (1 + zl <= (1 + x) * (1 + y) <= 1 + zu)%R). assert (H0 : (0 = 1 + -1)%R). ring. assert (Hc : forall a b : R, ((1 + a) * (1 + b) = 1 + (a + b + a * b))%R). intros a b. ring. assert (Hi : forall a b c : R, (a <= b)%R -> (b <= c)%R -> (1 + a <= 1 + b <= 1 + c)%R). intros a b c H1 H2. split. apply Rplus_le_compat_l with (1 := H1). apply Rplus_le_compat_l with (1 := H2). apply IRmult_pp with (1 + xl)%R (1 + xu)%R (1 + yl)%R (1 + yu)%R. rewrite H0. apply Rplus_le_compat_l with (1 := Hx). rewrite H0. apply Rplus_le_compat_l with (1 := Hy). rewrite Hc. apply Rplus_le_compat_l with (1 := Hzl). rewrite Hc. apply Rplus_le_compat_l with (1 := Hzu). apply Hi with (1 := Hxl) (2 := Hxu). apply Hi with (1 := Hyl) (2 := Hyu). assert (H0 : forall a : R, (a = (1 + a) + -1)%R). intros a. ring. split. rewrite (H0 zl). exact (Rplus_le_compat_r _ _ _ (proj1 H)). rewrite (H0 zu). exact (Rplus_le_compat_r _ _ _ (proj2 H)). Qed. Theorem IRcompose_inv : forall xl xu yl yu zl zu : R, (-1 <= xl)%R -> (-1 < yl)%R -> (yu + zl + yu * zl <= xl)%R -> (xu <= yl + zu + yl * zu)%R -> forall x y : R, (xl <= x <= xu)%R -> (yl <= y <= yu)%R -> (zl <= (x - y) / (1 + y) <= zu)%R. Proof. intros xl xu yl yu zl zu Hx Hy Hzl Hzu x y (Hxl,Hxu) (Hyl,Hyu). assert (H0: (0 = 1 + -1)%R). ring. assert (Hc: (0 < 1 + yl)%R). rewrite H0. apply Rplus_lt_compat_l with (1 := Hy). replace ((x - y) / (1 + y))%R with ((1 + x) / (1 + y) - 1)%R. assert (H : (1 + zl <= (1 + x) / (1 + y) <= 1 + zu)%R). assert (Hi : forall a b c : R, (a <= b)%R -> (b <= c)%R -> (1 + a <= 1 + b <= 1 + c)%R). intros a b c H1 H2. split. apply Rplus_le_compat_l with (1 := H1). apply Rplus_le_compat_l with (1 := H2). destruct (IRdiv_aux_p _ _ _ Hc (Hi _ _ _ Hyl Hyu))%R as (H1, (H2, (H3, (H4, H5)))). unfold Rdiv. apply IRmult_pp with (2 := H2) (5 := Hi _ _ _ Hxl Hxu) (6 := H5). rewrite H0. apply Rplus_le_compat_l with (1 := Hx). replace (1 + zl)%R with ((1 + zl) * (1 + yu) * /(1 + yu))%R. apply monotony_2p with (1 := H2). replace ((1 + zl) * (1 + yu))%R with (1 + (yu + zl + yu * zl))%R. 2: ring. apply Rplus_le_compat_l with (1 := Hzl). field. exact H4. replace (1 + zu)%R with ((1 + zu) * (1 + yl) * /(1 + yl))%R. apply monotony_2p with (1 := H1). replace ((1 + zu) * (1 + yl))%R with (1 + (yl + zu + yl * zu))%R. 2: ring. apply Rplus_le_compat_l with (1 := Hzu). field. exact H3. replace zl with (1 + zl + -1)%R. 2: ring. replace zu with (1 + zu + -1)%R. 2: ring. unfold Rminus. split ; apply Rplus_le_compat_r. exact (proj1 H). exact (proj2 H). field. apply Rgt_not_eq. unfold Rgt. apply Rlt_le_trans with (1 := Hc). apply Rplus_le_compat_l with (1 := Hyl). Qed. Theorem IRabs_p : forall yl yu zl zu : R, (0 <= yl)%R -> (zl <= yl)%R -> (yu <= zu)%R -> forall y : R, (yl <= y <= yu)%R -> (zl <= Rabs y <= zu)%R. Proof. intros yl yu zl zu Hy Hzl Hzu y Hylu. rewrite Rabs_pos_eq. apply IRsubset with (1 := Hzl) (2 := Hzu) (3 := Hylu). apply Rle_trans with (1 := Hy) (2 := proj1 Hylu). Qed. Theorem IRabs_o : forall yl yu zl zu : R, (zl <= 0)%R -> (-yl <= zu)%R -> (yu <= zu)%R -> forall y : R, (yl <= y <= yu)%R -> (zl <= Rabs y <= zu)%R. Proof. intros yl yu zl zu Hzl Hzu1 Hzu2 y (Hyl,Hyu). split. apply Rle_trans with (1 := Hzl) (2 := Rabs_pos y). unfold Rabs. case Rcase_abs ; intro H. apply Rle_trans with (2 := Hzu1). apply Ropp_le_contravar with (1 := Hyl). apply Rle_trans with (1 := Hyu) (2 := Hzu2). Qed. Theorem IRabs_n : forall yl yu zl zu : R, (yu <= 0)%R -> (zl <= -yu)%R -> (-yl <= zu)%R -> forall y : R, (yl <= y <= yu)%R -> (zl <= Rabs y <= zu)%R. Proof. intros yl yu zl zu Hy Hzl Hzu y Hylu. rewrite Rabs_left1. apply IRopp with (1 := Hzl) (2 := Hzu) (3 := Hylu). apply Rle_trans with (1 := proj2 Hylu) (2 := Hy). Qed. coq-gappalib-coq-1.10.0-df59b68361b1efbd697b17c40f7fae4a35991c44/src/Gappa_rewriting.v000066400000000000000000000546311517666064600266000ustar00rootroot00000000000000From Coq Require Import Lra Reals. Require Import Gappa_common. Theorem bnd_rewrite : forall a b : R, forall zi : FF, a = b -> BND b zi -> BND a zi. Proof. intros a b zi E Hz. now rewrite E. Qed. Theorem abs_rewrite : forall a b : R, forall zi : FF, a = b -> ABS b zi -> ABS a zi. Proof. intros a b zi E Hz. now rewrite E. Qed. Theorem fix_rewrite : forall a b : R, forall zn : Z, a = b -> FIX b zn -> FIX a zn. Proof. intros a b zn E Hz. now rewrite E. Qed. Theorem flt_rewrite : forall a b : R, forall zn : positive, a = b -> FLT b zn -> FLT a zn. Proof. intros a b zn E Hz. now rewrite E. Qed. Theorem nzr_rewrite : forall a b : R, a = b -> NZR b -> NZR a. Proof. intros a b E Hz. now rewrite E. Qed. Theorem rel_rewrite_1 : forall a b c : R, forall zi : FF, a = b -> REL b c zi -> REL a c zi. Proof. intros a b c zi E Hz. now rewrite E. Qed. Theorem rel_rewrite_2 : forall a b c : R, forall zi : FF, a = b -> REL c b zi -> REL c a zi. Proof. intros a b c zi E Hz. now rewrite E. Qed. Theorem lin_rewrite_1 : forall a b c : R, forall zi : FF, a = b -> LIN b c zi -> LIN a c zi. Proof. intros a b c zi E Hz. now rewrite E. Qed. Theorem lin_rewrite_2 : forall a b c : R, forall zi : FF, a = b -> LIN c b zi -> LIN c a zi. Proof. intros a b c zi E Hz. now rewrite E. Qed. Theorem eql_trans : forall a b c : R, a = b -> b = c -> a = c. Proof. intros a b c H1 H2. now rewrite H1. Qed. Theorem opp_mibs : forall a b : R, forall zi : FF, BND (-(a - b)) zi -> BND (-a - -b) zi. Proof. intros a b zi Hz. now replace (-a - -b)%R with (-(a - b))%R by ring. Qed. Theorem opp_xibu : forall a : R, forall zi : FF, BND (-(-a)) zi -> BND a zi. Proof. intros a zi Hz. now rewrite <- (Ropp_involutive a). Qed. Theorem add_xals : forall a b c : R, forall zi : FF, BND ((a - c) + (c + b)) zi -> BND (a + b) zi. Proof. intros a b c zi Hz. replace (a + b)%R with ((a - c) + (c + b))%R. exact Hz. ring. Qed. Theorem add_xars : forall a b c : R, forall zi : FF, BND ((a + c) + (b - c)) zi -> BND (a + b) zi. Proof. intros a b c zi Hz. replace (a + b)%R with ((a + c) + (b - c))%R. exact Hz. ring. Qed. Theorem sub_xals : forall a b c : R, forall zi : FF, BND ((a - c) + (c - b)) zi -> BND (a - b) zi. Proof. intros a b c zi Hz. replace (a - b)%R with ((a - c) + (c - b))%R. exact Hz. ring. Qed. Theorem sub_xars : forall a b c : R, forall zi : FF, BND ((a - c) - (b - c)) zi -> BND (a - b) zi. Proof. intros a b c zi Hz. replace (a - b)%R with ((a - c) - (b - c))%R. exact Hz. ring. Qed. Theorem mul_xals : forall a b c : R, forall zi : FF, BND ((a - c) * b + c * b) zi -> BND (a * b) zi. Proof. intros a b c zi Hz. replace (a * b)%R with ((a - c) * b + c * b)%R. exact Hz. ring. Qed. Theorem mul_xars : forall a b c : R, forall zi : FF, BND (a * (b - c) + a * c) zi -> BND (a * b) zi. Proof. intros a b c zi Hz. replace (a * b)%R with (a * (b - c) + a * c)%R. exact Hz. ring. Qed. Theorem add_mibs : forall a b c d : R, forall zi : FF, BND ((a - c) + (b - d)) zi -> BND ((a + b) - (c + d)) zi. Proof. intros a b c d zi Hz. replace ((a + b) - (c + d))%R with ((a - c) + (b - d))%R. exact Hz. ring. Qed. Theorem add_fils : forall a b c : R, forall zi : FF, BND (b - c) zi -> BND ((a + b) - (a + c)) zi. Proof. intros a b c zi Hz. replace ((a + b) - (a + c))%R with (b - c)%R. exact Hz. ring. Qed. Theorem add_firs : forall a b c : R, forall zi : FF, BND (a - c) zi -> BND ((a + b) - (c + b)) zi. Proof. intros a b c zi Hz. replace ((a + b) - (c + b))%R with (a - c)%R. exact Hz. ring. Qed. Theorem add_filq' : forall a b c : R, forall zi : FF, BND ((b - c) / (a + c)) zi -> BND (((a + b) - (a + c)) / (a + c)) zi. Proof. intros a b c zi. destruct (Req_dec (a + c) 0) as [->|H]. now rewrite 2!Rdiv_0_r. intros Hz. replace (((a + b) - (a + c)) / (a + c))%R with ((b - c) / (a + c))%R. exact Hz. now field. Qed. Theorem add_filq : forall a b c : R, forall zi : FF, NZR (a + c) -> BND ((b - c) / (a + c)) zi -> BND (((a + b) - (a + c)) / (a + c)) zi. Proof. intros a b c zi _ Hz. now apply add_filq'. Qed. Theorem add_firq' : forall a b c : R, forall zi : FF, BND ((a - c) / (c + b)) zi -> BND (((a + b) - (c + b)) / (c + b)) zi. Proof. intros a b c zi. destruct (Req_dec (c + b) 0) as [->|H]. now rewrite 2!Rdiv_0_r. intros Hz. replace (((a + b) - (c + b)) / (c + b))%R with ((a - c) / (c + b))%R. exact Hz. now field. Qed. Theorem add_firq : forall a b c : R, forall zi : FF, NZR (c + b) -> BND ((a - c) / (c + b)) zi -> BND (((a + b) - (c + b)) / (c + b)) zi. Proof. intros a b c zi _ Hz. now apply add_firq'. Qed. Theorem add_xilu : forall a b : R, forall zi : FF, BND ((a + b) - b) zi -> BND a zi. Proof. intros a b zi Hz. replace a with (a + b - b)%R by ring. exact Hz. Qed. Theorem add_xiru : forall a b : R, forall zi : FF, BND ((a + b) - a) zi -> BND b zi. Proof. intros a b zi Hz. replace b with (a + b - a)%R by ring. exact Hz. Qed. Theorem add_mibm : forall a b c d e : R, forall zi : FF, LIN ((a - c) + (b - d)) e zi -> LIN ((a + b) - (c + d)) e zi. Proof. intros a b c d e zi Hz. replace ((a + b) - (c + d))%R with ((a - c) + (b - d))%R by ring. exact Hz. Qed. Theorem add_film : forall a b c d : R, forall zi : FF, LIN (b - c) d zi -> LIN ((a + b) - (a + c)) d zi. Proof. intros a b c d zi Hz. replace ((a + b) - (a + c))%R with (b - c)%R by ring. exact Hz. Qed. Theorem add_firm : forall a b c d : R, forall zi : FF, LIN (a - c) d zi -> LIN ((a + b) - (c + b)) d zi. Proof. intros a b c d zi Hz. replace ((a + b) - (c + b))%R with (a - c)%R by ring. exact Hz. Qed. Theorem sub_mibs : forall a b c d : R, forall zi : FF, BND ((a - c) + -(b - d)) zi -> BND ((a - b) - (c - d)) zi. Proof. intros a b c d zi Hz. replace ((a - b) - (c - d))%R with ((a - c) + -(b - d))%R. exact Hz. ring. Qed. Theorem sub_fils : forall a b c : R, forall zi : FF, BND (-(b - c)) zi -> BND ((a - b) - (a - c)) zi. Proof. intros a b c zi Hz. replace ((a - b) - (a - c))%R with (-(b - c))%R. exact Hz. ring. Qed. Theorem sub_firs : forall a b c : R, forall zi : FF, BND (a - c) zi -> BND ((a - b) - (c - b)) zi. Proof. intros a b c zi Hz. replace ((a - b) - (c - b))%R with (a - c)%R. exact Hz. ring. Qed. Theorem sub_filq' : forall a b c : R, forall zi : FF, BND (- ((b - c) / (a - c))) zi -> BND (((a - b) - (a - c)) / (a - c)) zi. Proof. intros a b c zi. destruct (Req_dec (a - c) 0) as [->|H]. now rewrite 2!Rdiv_0_r, Ropp_0. intros Hz. replace (((a - b) - (a - c)) / (a - c))%R with (-((b - c) / (a - c)))%R. exact Hz. now field. Qed. Theorem sub_filq : forall a b c : R, forall zi : FF, NZR (a - c) -> BND (- ((b - c) / (a - c))) zi -> BND (((a - b) - (a - c)) / (a - c)) zi. Proof. intros a b c zi _ Hz. now apply sub_filq'. Qed. Theorem sub_firq' : forall a b c : R, forall zi : FF, BND ((a - c) / (c - b)) zi -> BND (((a - b) - (c - b)) / (c - b)) zi. Proof. intros a b c zi. destruct (Req_dec (c - b) 0) as [->|H]. now rewrite 2!Rdiv_0_r. intros Hz. replace (((a - b) - (c - b)) / (c - b))%R with ((a - c) / (c - b))%R. exact Hz. now field. Qed. Theorem sub_firq : forall a b c : R, forall zi : FF, NZR (c - b) -> BND ((a - c) / (c - b)) zi -> BND (((a - b) - (c - b)) / (c - b)) zi. Proof. intros a b c zi _ Hz. now apply sub_firq'. Qed. Theorem sub_mibm : forall a b c d e : R, forall zi : FF, LIN ((a - c) - (b - d)) e zi -> LIN ((a - b) - (c - d)) e zi. Proof. intros a b c d e zi Hz. replace ((a - b) - (c - d))%R with ((a - c) + -(b - d))%R by ring. exact Hz. Qed. Theorem sub_film : forall a b c d : R, forall zi : FF, LIN (-(b - c)) d zi -> LIN ((a - b) - (a - c)) d zi. Proof. intros a b c d zi Hz. replace ((a - b) - (a - c))%R with (-(b - c))%R by ring. exact Hz. Qed. Theorem sub_firm : forall a b c d : R, forall zi : FF, LIN (a - c) d zi -> LIN ((a - b) - (c - b)) d zi. Proof. intros a b c d zi Hz. replace ((a - b) - (c - b))%R with (a - c)%R by ring. exact Hz. Qed. Theorem sub_xalm : forall a b c d : R, forall zi : FF, LIN ((b - a) + (a - c)) d zi -> LIN (b - c) d zi. Proof. intros a b c d zi Hz. replace (b - c)%R with ((b - a) + (a - c))%R by ring. exact Hz. Qed. Theorem mul_fils : forall a b c : R, forall zi : FF, BND (a * (b - c)) zi -> BND (a * b - a * c) zi. Proof. intros a b c zi Hz. replace (a * b - a * c)%R with (a * (b - c))%R. exact Hz. ring. Qed. Theorem mul_firs : forall a b c : R, forall zi : FF, BND ((a - c) * b) zi -> BND (a * b - c * b) zi. Proof. intros a b c zi Hz. replace (a * b - c * b)%R with ((a - c) * b)%R. exact Hz. ring. Qed. Theorem mul_mars : forall a b c d : R, forall zi : FF, BND (a * (b - d) + (a - c) * d) zi -> BND (a * b - c * d) zi. Proof. intros a b c d zi Hz. replace (a * b - c * d)%R with (a * (b - d) + (a - c) * d)%R. exact Hz. ring. Qed. Theorem mul_mals : forall a b c d : R, forall zi : FF, BND ((a - c) * b + c * (b - d)) zi -> BND (a * b - c * d) zi. Proof. intros a b c d zi Hz. replace (a * b - c * d)%R with ((a - c) * b + c * (b - d))%R. exact Hz. ring. Qed. Theorem mul_mabs : forall a b c d : R, forall zi : FF, BND (a * (b - d) + (a - c) * b - ((a - c) * (b - d))) zi -> BND (a * b - c * d) zi. Proof. intros a b c d zi Hz. replace (a * b - c * d)%R with (a * (b - d) + (a - c) * b - ((a - c) * (b - d)))%R. exact Hz. ring. Qed. Theorem mul_mibs : forall a b c d : R, forall zi : FF, BND (c * (b - d) + (a - c) * d + (a - c) * (b - d)) zi -> BND (a * b - c * d) zi. Proof. intros a b c d zi Hz. replace (a * b - c * d)%R with (c * (b - d) + (a - c) * d + (a - c) * (b - d))%R. exact Hz. ring. Qed. Theorem err_xalq : forall a b c : R, forall zi : FF, NZR b -> NZR c -> BND ((a - c) / c + (c - b) / b + ((a - c) / c) * ((c - b) / b)) zi -> BND ((a - b) / b) zi. Proof. intros a b c zi Hb Hc Hz. replace ((a - b) / b)%R with ((a - c) / c + (c - b) / b + ((a - c) / c) * ((c - b) / b))%R. exact Hz. field. exact (conj Hb Hc). Qed. Theorem mul_filq : forall a b c : R, forall zi : FF, REL b c zi -> REL (a * b) (a * c) zi. Proof. intros a b c zi [ze [Hz1 Hz2]]. exists ze. apply (conj Hz1). rewrite Hz2. ring. Qed. Theorem mul_firq : forall a b c : R, forall zi : FF, REL a c zi -> REL (a * b) (c * b) zi. Proof. intros a b c zi [ze [Hz1 Hz2]]. exists ze. apply (conj Hz1). rewrite Hz2. ring. Qed. Theorem mul_film : forall a b c : R, forall zi : FF, LIN b c zi -> LIN (a * b) (a * c) zi. Proof. intros a b c zi [ze [Hz1 Hz2]]. exists ze. apply (conj Hz1). rewrite Hz2. ring. Qed. Theorem mul_firm : forall a b c : R, forall zi : FF, LIN a c zi -> LIN (a * b) (c * b) zi. Proof. intros a b c zi [ze [Hz1 Hz2]]. exists ze. apply (conj Hz1). rewrite Hz2. ring. Qed. Theorem mul_fism : forall a b c : R, forall zi : FF, LIN b c zi -> LIN (a * b) (c * a) zi. Proof. intros a b c zi [ze [Hz1 Hz2]]. exists ze. apply (conj Hz1). rewrite Hz2. ring. Qed. Theorem mul_fitm : forall a b c : R, forall zi : FF, LIN a c zi -> LIN (a * b) (b * c) zi. Proof. intros a b c zi [ze [Hz1 Hz2]]. exists ze. apply (conj Hz1). rewrite Hz2. ring. Qed. Theorem mul_xilu : forall a b : R, forall zi : FF, NZR b -> BND ((a * b) / b) zi -> BND a zi. Proof. intros a b zi Hb Hz. replace a with (a * b / b)%R. exact Hz. now field. Qed. Theorem mul_xiru : forall a b : R, forall zi : FF, NZR a -> BND ((a * b) / a) zi -> BND b zi. Proof. intros a b zi Hb Hz. replace b with (a * b / a)%R. exact Hz. now field. Qed. Theorem sqrt_mibs : forall a b : R, forall ai bi zi : FF, BND a ai -> BND b bi -> BND ((a - b) / (sqrt a + sqrt b)) zi -> Fpos0 (lower ai) && Fpos0 (lower bi) = true -> BND (sqrt a - sqrt b) zi. Proof. intros a b ai bi zi Ha Hb Hz H. generalize (andb_prop _ _ H). clear H. intros (H1,H2). generalize (Fpos0_correct _ H1). clear H1. intro H1. generalize (Fpos0_correct _ H2). clear H2. intro H2. assert (H3: (0 <= sqrt a)%R). apply sqrt_positivity. apply Rle_trans with (1 := H1) (2 := proj1 Ha). assert (H4: (0 <= sqrt b)%R). apply sqrt_positivity. apply Rle_trans with (1 := H2) (2 := proj1 Hb). case (Rtotal_order (sqrt a + sqrt b) 0). intro H. elim Rlt_not_le with (1 := H). apply Rplus_le_le_0_compat ; assumption. intros [H|H] ; replace (sqrt a - sqrt b)%R with ((a - b) / (sqrt a + sqrt b))%R ; try exact Hz. assert (sqrt a = 0)%R. apply Rle_antisym. 2: exact H3. rewrite <- H. pattern (sqrt a) at 1 ; rewrite <- (Rplus_0_r (sqrt a)). apply Rplus_le_compat_l with (1 := H4). rewrite H0 in H. rewrite Rplus_0_l in H. rewrite H. rewrite H0. assert (a = 0)%R as ->. apply sqrt_eq_0 with (2 := H0). apply Rle_trans with (1 := H1) (2 := proj1 Ha). assert (b = 0)%R as ->. apply sqrt_eq_0 with (2 := H). apply Rle_trans with (1 := H2) (2 := proj1 Hb). rewrite Rminus_0_r. unfold Rdiv. apply Rmult_0_l. replace (a - b)%R with (sqrt a * sqrt a - sqrt b * sqrt b)%R. field. now apply Rgt_not_eq. repeat rewrite sqrt_def. exact (refl_equal _). apply Rle_trans with (1 := H2) (2 := proj1 Hb). apply Rle_trans with (1 := H1) (2 := proj1 Ha). Qed. Theorem sqrt_mibq : forall a b : R, forall ai bi zi : FF, BND a ai -> BND b bi -> BND (sqrt (1 + (a - b) / b) - 1) zi -> Fpos0 (lower ai) && Fpos (lower bi) = true -> BND ((sqrt a - sqrt b) / sqrt b) zi. Proof. intros a b ai bi zi Ha Hb Hz H. generalize (andb_prop _ _ H). clear H. intros (H1,H2). generalize (Fpos0_correct _ H1). clear H1. intro H1. generalize (Fpos_correct _ H2). clear H2. intro H2. replace ((sqrt a - sqrt b) / sqrt b)%R with (sqrt (1 + (a - b) / b) - 1)%R. exact Hz. replace (1 + (a - b) / b)%R with (a / b)%R. rewrite sqrt_div. field. apply Rgt_not_eq. unfold Rgt. apply sqrt_lt_R0. apply Rlt_le_trans with (1 := H2) (2 := proj1 Hb). apply Rle_trans with (1 := H1) (2 := proj1 Ha). apply Rlt_le_trans with (1 := H2) (2 := proj1 Hb). field. apply Rgt_not_eq. unfold Rgt. apply Rlt_le_trans with (1 := H2) (2 := proj1 Hb). Qed. Theorem sqrt_xibu : forall a : R, forall ai zi : FF, BND a ai -> BND (sqrt a * sqrt a) zi -> Fpos0 (lower ai) = true -> BND a zi. Proof. intros a ai zi Ha Hz H. generalize (Fpos0_correct _ H). clear H. intro H. rewrite <- (sqrt_sqrt a). exact Hz. apply Rle_trans with (1 := H). apply Ha. Qed. Theorem square_sqrt : forall a : R, forall ai : FF, BND a ai -> Fpos0 (lower ai) = true -> BND (sqrt a * sqrt a) ai. Proof. intros a ai Ha H. generalize (Fpos0_correct _ H). clear H. intro H. rewrite sqrt_def. exact Ha. apply Rle_trans with (1 := H). apply Ha. Qed. Theorem abs_mul_xx : forall a b : R, forall zi : FF, BND (Rabs a * Rabs b) zi -> BND (Rabs (a * b)) zi. Proof. intros a b zi Hz. rewrite Rabs_mult. exact Hz. Qed. Theorem val_xebs : forall a b : R, forall zi : FF, BND (b - (b - a)) zi -> BND a zi. Proof. intros a b zi Hz. replace a with (b - (b - a))%R. exact Hz. ring. Qed. Theorem val_xabs : forall a b : R, forall zi : FF, BND (a + (b - a)) zi -> BND b zi. Proof. intros a b zi Hz. replace b with (a + (b - a))%R. exact Hz. ring. Qed. Theorem val_xabm : forall a b c : R, forall zi : FF, LIN (a + (b - a)) c zi -> LIN b c zi. Proof. intros a b c zi H. replace b with (a + (b - a))%R by ring. exact H. Qed. Theorem div_mibq : forall a b c d : R, forall zi : FF, NZR b -> NZR c -> NZR d -> BND (((a - c) / c - (b - d) / d) / (1 + (b - d) / d)) zi -> BND ((a / b - c / d) / (c / d)) zi. Proof. intros a b c d zi Hb Hc Hd Hz. replace ((a / b - c / d) / (c / d))%R with (((a - c) / c - (b - d) / d) / (1 + (b - d) / d))%R. exact Hz. field. exact (conj Hd (conj Hb Hc)). Qed. Theorem div_xals' : forall a b c : R, forall zi : FF, BND ((b - a) / c + a / c) zi -> BND (b / c) zi. Proof. intros a b c zi. destruct (Req_dec c 0) as [->|H]. now rewrite 3!Rdiv_0_r, Rplus_0_l. intros Hz. replace (b / c)%R with ((b - a) / c + a / c)%R. exact Hz. now field. Qed. Theorem div_xals : forall a b c : R, forall zi : FF, NZR c -> BND ((b - a) / c + a / c) zi -> BND (b / c) zi. Proof. intros a b c zi _. now apply div_xals'. Qed. Theorem div_firs' : forall a b c : R, forall zi : FF, BND ((a - c) / b) zi -> BND (a / b - c / b) zi. Proof. intros a b c zi. destruct (Req_dec b 0) as [->|H]. now rewrite 3!Rdiv_0_r, Rminus_0_r. intros Hz. replace (a / b - c / b)%R with ((a - c) / b)%R. exact Hz. now field. Qed. Theorem div_firs : forall a b c : R, forall zi : FF, NZR b -> BND ((a - c) / b) zi -> BND (a / b - c / b) zi. Proof. intros a b c zi _. now apply div_firs'. Qed. Theorem div_firq : forall a b c : R, forall zi : FF, REL a c zi -> REL (a / b) (c / b) zi. Proof. intros a b c zi [ze [Hz1 Hz2]]. exists ze. apply (conj Hz1). rewrite Hz2. unfold Rdiv. ring. Qed. Theorem div_firm : forall a b c : R, forall zi : FF, LIN a c zi -> LIN (a / b) (c / b) zi. Proof. intros a b c zi [ze [Hz1 Hz2]]. exists ze. apply (conj Hz1). rewrite Hz2. unfold Rdiv. ring. Qed. Theorem div_fir : forall a b : R, forall zi : FF, NZR b -> BND a zi -> BND ((a * b) / b) zi. Proof. intros a b zi Hb Hz. replace ((a * b) / b)%R with a. exact Hz. field. exact Hb. Qed. Theorem div_fil : forall a b : R, forall zi : FF, NZR a -> BND b zi -> BND ((a * b) / a) zi. Proof. intros a b zi Hb Hz. replace (( a * b) / a)%R with b. exact Hz. field. exact Hb. Qed. Theorem div_xilu : forall a b : R, forall zi : FF, NZR b -> BND ((a / b) * b) zi -> BND a zi. Proof. intros a b zi Hb Hz. replace a with (a / b * b)%R. exact Hz. now field. Qed. Theorem div_xiru' : forall a b : R, forall zi : FF, NZR a -> BND (a / (a / b)) zi -> BND b zi. Proof. intros a b zi Ha. destruct (Req_dec b 0) as [->|H]. now rewrite 2!Rdiv_0_r. intros Hz. replace b with (a / (a / b))%R. exact Hz. field. now split. Qed. Theorem div_xiru : forall a b : R, forall zi : FF, NZR a -> NZR b -> BND (a / (a / b)) zi -> BND b zi. Proof. intros a b zi Ha _. now apply div_xiru'. Qed. Theorem err_xabq : forall a b : R, forall zi : FF, NZR b -> BND (1 + (a - b) / b) zi -> BND (a / b) zi. Proof. intros a b zi Hb Hz. replace (a / b)%R with (1 + (a - b) / b)%R. exact Hz. field. exact Hb. Qed. Theorem err_fabq : forall a b : R, forall zi : FF, NZR b -> BND (a / b) zi -> BND (1 + (a - b) / b) zi. Proof. intros a b zi Hb Hz. replace (1 + (a - b) / b)%R with (a / b)%R . exact Hz. field. exact Hb. Qed. Theorem addf_1 : forall a b : R, forall zi : FF, NZR a -> NZR (a + b) -> BND (1 / (1 + b / a)) zi -> BND (a / (a + b)) zi. Proof. intros a b zi Ha Hab Hz. replace (a / (a + b))%R with (1 / (1 + b / a))%R. exact Hz. field. exact (conj Hab Ha). Qed. Theorem addf_2 : forall a b : R, forall zi : FF, NZR (a + b) -> BND (1 - b / (a + b)) zi -> BND (a / (a + b)) zi. Proof. intros a b zi Hab Hz. replace (a / (a + b))%R with (1 - b / (a + b))%R. exact Hz. field. exact Hab. Qed. Theorem addf_3 : forall a b : R, forall zi : FF, NZR a -> NZR (a - b) -> BND (1 / (1 - b / a)) zi -> BND (a / (a - b)) zi. Proof. intros a b zi Ha Hab Hz. replace (a / (a - b))%R with (1 / (1 - b / a))%R. exact Hz. field. exact (conj Hab Ha). Qed. Theorem addf_4 : forall a b : R, forall zi : FF, NZR (a - b) -> BND (1 + b / (a - b)) zi -> BND (a / (a - b)) zi. Proof. intros a b zi Hab Hz. replace (a / (a - b))%R with (1 + b / (a - b))%R. exact Hz. field. exact Hab. Qed. Theorem addf_5 : forall a b : R, forall zi : FF, NZR b -> NZR (a + b) -> BND (1 / (a / b + 1)) zi -> BND (b / (a + b)) zi. Proof. intros a b zi Hb Hab Hz. replace (b / (a + b))%R with (1 / (a / b + 1))%R. exact Hz. field. exact (conj Hab Hb). Qed. Theorem addf_6 : forall a b : R, forall zi : FF, NZR (a + b) -> BND (1 - a / (a + b)) zi -> BND (b / (a + b)) zi. Proof. intros a b zi Hab Hz. replace (b / (a + b))%R with (1 - a / (a + b))%R. exact Hz. field. exact Hab. Qed. Theorem addf_7 : forall a b : R, forall zi : FF, NZR b -> NZR (a - b) -> BND (1 / (a / b - 1)) zi -> BND (b / (a - b)) zi. Proof. intros a b zi Hb Hab Hz. replace (b / (a - b))%R with (1 / (a / b - 1))%R. exact Hz. field. exact (conj Hab Hb). Qed. Theorem addf_8 : forall a b : R, forall zi : FF, NZR (a - b) -> BND (a / (a - b) - 1) zi -> BND (b / (a - b)) zi. Proof. intros a b zi Hab Hz. replace (b / (a - b))%R with (a / (a - b) - 1)%R. exact Hz. field. exact Hab. Qed. Theorem addf_9 : forall a b : R, forall zi : FF, NZR b -> NZR (a + b) -> BND (1 - 1 / (1 + a / b)) zi -> BND (a / (a + b)) zi. Proof. intros a b zi Ha Hab Hz. replace (a / (a + b))%R with (1 - 1 / (1 + a / b))%R by now field. exact Hz. Qed. Theorem addf_10 : forall a b : R, forall zi : FF, NZR a -> NZR (a + b) -> BND (1 - 1 / (1 + b / a)) zi -> BND (b / (a + b)) zi. Proof. intros a b zi Ha Hab Hz. rewrite Rplus_comm in Hab |- *. now apply addf_9. Qed. Theorem addf_11 : forall a b : R, forall zi : FF, NZR b -> NZR (a - b) -> BND (1 - 1 / (1 - a / b)) zi -> BND (a / (a - b)) zi. Proof. intros a b zi Ha Hab Hz. replace (a / (a - b))%R with (1 - 1 / (1 - a / b))%R. exact Hz. field. unfold NZR in *. lra. Qed. Theorem addf_12 : forall a b : R, forall zi : FF, NZR a -> NZR (a - b) -> BND (1 / (1 - b / a) - 1) zi -> BND (b / (a - b)) zi. Proof. intros a b zi Ha Hab Hz. replace (b / (a - b))%R with (1 / (1 - b / a) - 1)%R by now field. exact Hz. Qed. Theorem opp_fibq : forall a b : R, forall zi : FF, REL a b zi -> REL (-a) (-b) zi. Proof. intros a b zi [ze [Hz1 Hz2]]. exists ze. apply (conj Hz1). rewrite Hz2. ring. Qed. Theorem opp_fibm : forall a b : R, forall zi : FF, LIN a b zi -> LIN (-a) (-b) zi. Proof. intros a b zi [ze [Hz1 Hz2]]. exists ze. apply (conj Hz1). rewrite Hz2. ring. Qed. Theorem opp_fibe : forall a b : R, a = b -> (-a = -b)%R. Proof. intros a b H. now rewrite H. Qed. Theorem add_file : forall a b c : R, b = c -> (a + b = a + c)%R. Proof. intros a b c H. now rewrite H. Qed. Theorem add_fire : forall a b c : R, a = c -> (a + b = c + b)%R. Proof. intros a b c H. now rewrite H. Qed. Theorem sub_file : forall a b c : R, b = c -> (a - b = a - c)%R. Proof. intros a b c H. now rewrite H. Qed. Theorem sub_fire : forall a b c : R, a = c -> (a - b = c - b)%R. Proof. intros a b c H. now rewrite H. Qed. Theorem mul_file : forall a b c : R, b = c -> (a * b = a * c)%R. Proof. intros a b c H. now rewrite H. Qed. Theorem mul_fire : forall a b c : R, a = c -> (a * b = c * b)%R. Proof. intros a b c H. now rewrite H. Qed. Theorem div_file : forall a b c : R, b = c -> (a / b = a / c)%R. Proof. intros a b c H. now rewrite H. Qed. Theorem div_fire : forall a b c : R, a = c -> (a / b = c / b)%R. Proof. intros a b c H. now rewrite H. Qed. Lemma rel_of_lin : forall x y : R, forall ri : FF, LIN (x - y) y ri -> REL x y ri. Proof. intros x y ri [e [Hr H]]. exists e. apply (conj Hr). apply Rplus_eq_reg_r with (-y)%R. unfold Rminus in H. rewrite H. ring. Qed. Lemma lin_of_rel2 : forall x y : R, forall ri : FF, REL x y ri -> LIN (x - y) y ri. Proof. intros x y ri [e [Hr ->]]. exists e. apply (conj Hr). ring. Qed. coq-gappalib-coq-1.10.0-df59b68361b1efbd697b17c40f7fae4a35991c44/src/Gappa_round.v000066400000000000000000000413171517666064600257120ustar00rootroot00000000000000From Coq Require Import Decidable Bool ZArith Reals Lia. From Flocq Require Import Core Bracket Digits. Require Import Gappa_definitions. Require Import Gappa_dyadic. Require Import Gappa_round_def. Require Import Gappa_round_aux. Definition shr_aux (p : rnd_record) : rnd_record := let s := rnd_r p || rnd_s p in match (rnd_m p) with | N0 => rnd_record_mk N0 false s | Npos m1 => match m1 with | xH => rnd_record_mk N0 true s | xO m2 => rnd_record_mk (Npos m2) false s | xI m2 => rnd_record_mk (Npos m2) true s end end. Definition shr (m : positive) (d : positive) := iter_pos shr_aux d (rnd_record_mk (Npos m) false false). Definition round_pos (rdir : rnd_record -> bool) (rexp : Z -> Z) (m : positive) (e : Z) := let e' := rexp (e + Zpos (digits m))%Z in match (e' - e)%Z with | Zpos d => let r := shr m d in ((if rdir r then N.succ (rnd_m r) else rnd_m r), e') | _ => (Npos m, e) end. Definition round (rdirs : round_dir) (rexp : Z -> Z) (f : float2) := match (Fnum f) with | Z0 => Float2 Z0 Z0 | Zpos p => match (round_pos (rpos rdirs) rexp p (Fexp f)) with | (N0, _) => Float2 Z0 Z0 | (Npos q, e) => Float2 (Zpos q) e end | Zneg p => match (round_pos (rneg rdirs) rexp p (Fexp f)) with | (N0, _) => Float2 Z0 Z0 | (Npos q, e) => Float2 (Zneg q) e end end. Definition tofloat p := match p with | (m,e) => Float2 (Z_of_N m) e end. Section ZrndG. Section rndG. Lemma bracket_aux : forall x, (IZR (Zfloor x) <= x < IZR (Zfloor x) + 1)%R. Proof. split. apply Zfloor_lb. apply Zfloor_ub. Qed. Variable rdir : rnd_record -> bool. Variable good_rdir : good_rdir rdir. Definition hrndG_aux mx x := match inbetween_loc (IZR mx) (IZR mx + 1) x with | loc_Exact => (false, false) | loc_Inexact Lt => (false, true) | loc_Inexact Eq => (true, false) | loc_Inexact Gt => (true, true) end. Definition hrndG x := let mx := Zfloor x in let m := ZtoN mx in let l := inbetween_loc (IZR mx) (IZR mx + 1) x in let r := let (r, s) := hrndG_aux mx x in rnd_record_mk m r s in if rdir r then Zceil x else Zfloor x. Lemma hrndG_DN : forall x, rdir (rnd_record_mk (ZtoN (Zfloor x)) true true) = false -> hrndG x = Zfloor x. Proof. intros x Hx1. destruct (good_rdir (ZtoN (Zfloor x))) as (Hx2, (Hx3, Hx4)). rewrite Hx1 in Hx4. destruct Hx4 as [Hx4|Hx4] ; try easy. rewrite Hx4 in Hx3. destruct Hx3 as [Hx3|Hx3] ; try easy. unfold hrndG. destruct (hrndG_aux (Zfloor x) x) as ([|],[|]) ; now rewrite ?Hx1, ?Hx2, ?Hx3, ?Hx4. Qed. Lemma hrndG_UP : forall x, rdir (rnd_record_mk (ZtoN (Zfloor x)) false true) = true -> hrndG x = Zceil x. Proof. intros x Hx1. destruct (good_rdir (ZtoN (Zfloor x))) as (Hx2, (Hx3, Hx4)). rewrite Hx1 in Hx3. destruct Hx3 as [Hx3|Hx3] ; try easy. rewrite Hx3 in Hx4. destruct Hx4 as [Hx4|Hx4] ; try easy. unfold hrndG, hrndG_aux. destruct (inbetween_spec _ _ x (bracket_aux _)) as [H|l H1 H2]. rewrite Hx2. rewrite H at 2. now rewrite Zceil_IZR. now case l ; rewrite ?Hx1, ?Hx3, ?Hx4. Qed. Lemma hrndG_N : forall x, ( forall b, rdir (rnd_record_mk (ZtoN (Zfloor x)) b true) = b ) -> hrndG x = Znearest (fun x => rdir (rnd_record_mk (ZtoN x) true false)) x. Proof with auto with typeclass_instances. intros x Hx1. destruct (good_rdir (ZtoN (Zfloor x))) as (Hx2, _). unfold hrndG, hrndG_aux. destruct (inbetween_spec _ _ x (bracket_aux _)) as [Hx4|l Hx4 Hx5]. rewrite Hx2. rewrite Hx4 at 2. rewrite Zrnd_IZR... unfold Znearest. rewrite Rcompare_floor_ceil_middle with (1 := Rlt_not_eq _ _ (proj1 Hx4)). rewrite Rcompare_middle. rewrite Zceil_floor_neq with (1 := Rlt_not_eq _ _ (proj1 Hx4)). rewrite plus_IZR. rewrite Hx5. now case l ; rewrite ?Hx1, ?Hx2. Qed. Instance valid_rnd_hG : Valid_rnd hrndG. Proof with auto with typeclass_instances. split. (* monotone *) intros x y Hxy. destruct (Z.eq_dec (Zfloor x) (Zfloor y)) as [H|H]. (* *) case_eq (rdir (rnd_record_mk (ZtoN (Zfloor x)) true true)) ; intros Hb1. case_eq (rdir (rnd_record_mk (ZtoN (Zfloor x)) false true)) ; intros Hb2. (* . *) rewrite hrndG_UP with (1 := Hb2). rewrite H in Hb2. rewrite hrndG_UP with (1 := Hb2). now apply Zceil_le. (* . *) assert (Hb3: forall b, rdir (rnd_record_mk (ZtoN (Zfloor x)) b true) = b). now intros [|]. rewrite hrndG_N with (1 := Hb3). rewrite H in Hb3. rewrite hrndG_N with (1 := Hb3). apply Zrnd_le... (* . *) rewrite hrndG_DN with (1 := Hb1). rewrite H in Hb1. rewrite hrndG_DN with (1 := Hb1). now apply Zfloor_le. (* *) apply Z.le_trans with (Zceil x). unfold hrndG. case rdir. apply Z.le_refl. apply le_IZR. exact (Rle_trans _ _ _ (Zfloor_lb x) (Zceil_ub x)). apply Z.le_trans with (Zfloor y). apply Z.le_trans with (Zfloor x + 1)%Z. apply Zceil_glb. rewrite plus_IZR. apply Rlt_le. apply Zfloor_ub. generalize (Zfloor_le x y Hxy). lia. unfold hrndG. case rdir. apply le_IZR. exact (Rle_trans _ _ _ (Zfloor_lb y) (Zceil_ub y)). apply Z.le_refl. (* Z2R *) intros n. unfold hrndG. case rdir. apply Zceil_IZR. apply Zfloor_IZR. Qed. Lemma hrndG_pos : forall x, (0 <= x)%R -> (0 <= hrndG x)%Z. Proof with auto with typeclass_instances. intros x Hx. rewrite <- (Zrnd_IZR hrndG 0). apply Zrnd_le... Qed. Lemma shr_conversion : forall m d, shr m d = let (r, s) := hrndG_aux (Zfloor (IZR (Zpos m) * bpow radix2 (- Zpos d))) (IZR (Zpos m) * bpow radix2 (- Zpos d)) in rnd_record_mk (ZtoN (Zfloor (IZR (Zpos m) * bpow radix2 (- Zpos d)))) r s. Proof. intros m d. unfold shr. rewrite iter_pos_nat. rewrite (Zpos_eq_Z_of_nat_o_nat_of_P d). induction (nat_of_P d). (* *) simpl. rewrite Rmult_1_r. rewrite Zfloor_IZR. unfold hrndG_aux, inbetween_loc. now rewrite Rcompare_Eq. (* *) rewrite iter_nat_S. rewrite IHn. clear IHn. unfold hrndG_aux. set (ms := (IZR (Zpos m) * bpow radix2 (- Z_of_nat (S n)))%R). replace (IZR (Zpos m) * bpow radix2 (- Z_of_nat n))%R with (ms * 2)%R. assert (H0: (0 <= Zfloor ms)%Z). apply Zfloor_lub. unfold ms. apply Rmult_le_pos. now apply IZR_le. apply bpow_ge_0. clearbody ms. clear -H0. destruct (inbetween_spec _ _ ms (bracket_aux _)) as [H|l H1 H2]. (* . *) replace (Zfloor (ms * 2)) with (Zfloor ms * 2)%Z. unfold inbetween_loc. rewrite mult_IZR. rewrite Rcompare_Eq. destruct (Zfloor ms) as [|p|p] ; try easy. now rewrite Zmult_comm. now rewrite <- H. rewrite H at 2. rewrite <- mult_IZR. now rewrite Zfloor_IZR. (* . *) unfold inbetween_loc. assert (H3: Rcompare (ms * 2) (IZR (Zfloor ms) * 2 + 1) = l). rewrite <- (Rcompare_mult_r 2) in H2. now replace (IZR (Zfloor ms) * 2 + 1)%R with ((IZR (Zfloor ms) + (IZR (Zfloor ms) + 1)) / 2 * 2)%R by field. now apply IZR_lt. clear H2. rewrite <- H3. clear H3. case Rcompare_spec ; intros H4. elim Rlt_not_le with (1 := H4). apply Zfloor_lb. (* .. *) unfold shr_aux. simpl. rewrite H4. rewrite <- mult_IZR, <- plus_IZR. rewrite Rcompare_IZR. rewrite <- H4. replace (Zfloor (ms * 2)) with (1 + 2 * Zfloor ms)%Z. rewrite Zcompare_Eq. clear -H0. destruct (Zfloor ms) as [|p|p] ; [easy|easy|]. now elim H0. now rewrite Zmult_comm, Zplus_comm. clear -H1 H4. assert (Zfloor ms * 2 < Zfloor (ms * 2) < (Zfloor ms + 1) * 2)%Z. split ; apply lt_IZR ; rewrite <- H4 ; rewrite mult_IZR ; apply Rmult_lt_compat_r. now apply IZR_lt. apply H1. now apply IZR_lt. now rewrite plus_IZR. lia. (* .. *) set (rs := match Rcompare (ms * 2) ((IZR (Zfloor (ms * 2)) + (IZR (Zfloor (ms * 2)) + 1)) / 2) with Eq => (true, false) | Lt => (false, true) | Gt => (true, true) end). rewrite (surjective_pairing rs). unfold shr_aux. simpl. replace (fst rs || snd rs) with true. clear rs. case Rcompare_spec ; intros H2. (* ... *) replace (Zfloor (ms * 2)) with (2 * Zfloor ms)%Z. now case (Zfloor ms). apply sym_eq. rewrite Zmult_comm. apply Zfloor_imp. rewrite plus_IZR, mult_IZR. refine (conj _ H2). apply Rmult_le_compat_r. now apply IZR_le. apply Zfloor_lb. (* ... *) elim Rlt_not_le with (1 := H4). rewrite H2. rewrite <- mult_IZR, <- plus_IZR. rewrite Zfloor_IZR. apply Rle_refl. (* ... *) replace (Zfloor (ms * 2)) with (1 + 2 * Zfloor ms)%Z. revert H0. case (Zfloor ms) ; [easy|easy|]. intros p H. now elim H. apply sym_eq. apply Zfloor_imp. rewrite plus_IZR, mult_IZR. split. rewrite Rplus_comm, Rmult_comm. now apply Rlt_le. rewrite 2!plus_IZR, mult_IZR. simpl. replace (1 + 2 * IZR (Zfloor ms) + 1)%R with ((IZR (Zfloor ms) + 1) * 2)%R by ring. apply Rmult_lt_compat_r. now apply IZR_lt. apply H1. (* ... *) unfold rs. now case Rcompare. unfold ms. rewrite Rmult_assoc. change 2%R with (bpow radix2 1). rewrite <- bpow_plus. apply (f_equal (fun e => _ * bpow radix2 e)%R). rewrite inj_S. unfold Z.succ. ring. Qed. Lemma Z_of_N_ZtoN : forall n, (0 <= n)%Z -> Z_of_N (ZtoN n) = n. Proof. intros [|p|p] H ; [easy|easy|]. now elim H. Qed. Theorem hrndG_conversion : forall rexp m e, float2R (tofloat (round_pos rdir rexp m e)) = Generic_fmt.round radix2 rexp hrndG (F2R (Float radix2 (Zpos m) e)). Proof with auto with typeclass_instances. intros rexp m e. assert (He: cexp radix2 rexp (F2R (Float radix2 (Zpos m) e)) = rexp (e + Zpos (digits m))%Z). rewrite digits2_digits. rewrite Zdigits_mag. 2: easy. unfold cexp. rewrite mag_F2R. 2: easy. now rewrite Zplus_comm. unfold round_pos. case_eq (rexp (e + Zpos (digits m)) - e)%Z. (* *) intros H. apply sym_eq. apply round_generic... apply generic_format_F2R. intros _ ; simpl. rewrite He. rewrite Zminus_eq with (1 := H). apply Z.le_refl. (* *) intros p H. unfold Generic_fmt.round, scaled_mantissa. rewrite He. unfold F2R, float2R. simpl. rewrite Rmult_assoc, <- bpow_plus. assert (rexp (e + Zpos (digits m)) = e + Zpos p)%Z. lia. rewrite H0. ring_simplify (e + -(e + Zpos p))%Z. apply (f_equal (fun m => IZR m * _)%R). unfold hrndG. rewrite (shr_conversion m p). simpl. set (rs := hrndG_aux (Zfloor (IZR (Zpos m) * / IZR (Zpower_pos 2 p))) (IZR (Zpos m) * / IZR (Zpower_pos 2 p))). rewrite (surjective_pairing rs). simpl. assert (H1: rdir (rnd_record_mk (ZtoN (Zfloor (IZR (Zpos m) * / IZR (Zpower_pos 2 p)))) (fst rs) (snd rs)) = true -> (IZR (Zfloor (IZR (Zpos m) * / IZR (Zpower_pos 2 p))) <> IZR (Zpos m) * / IZR (Zpower_pos 2 p))%R). unfold rs, hrndG_aux. destruct (inbetween_spec _ _ (IZR (Zpos m) * / IZR (Zpower_pos 2 p)) (bracket_aux _)) as [H1|l H1 H2]. simpl. intros H2 _. destruct (good_rdir (ZtoN (Zfloor (IZR (Zpos m) * / IZR (Zpower_pos 2 p))))) as (H3, _). now rewrite H2 in H3. intros _. now apply Rlt_not_eq. revert H1. case rdir. intros H1. rewrite Znat.Z_of_N_succ. rewrite Z_of_N_ZtoN. apply sym_eq. apply Zceil_floor_neq. now apply H1. apply Zfloor_lub. now apply (F2R_ge_0 radix2 (Float radix2 (Zpos m) (- (Zpos p)))). intros _. rewrite Z_of_N_ZtoN. apply refl_equal. apply Zfloor_lub. now apply (F2R_ge_0 radix2 (Float radix2 (Zpos m) (- (Zpos p)))). (* *) intros p H. apply sym_eq. apply round_generic... apply generic_format_F2R. intros _ ; simpl. rewrite He. generalize (Zlt_neg_0 p). lia. Qed. End rndG. Variable rdir : round_dir. Definition rndG x := match Rcompare x 0 with | Gt => hrndG (rpos rdir) x | Lt => Z.opp (hrndG (rneg rdir) (-x)) | _ => Z0 end. Instance valid_rnd_G : Valid_rnd rndG. Proof. split. (* monotone *) intros x y Hxy. unfold rndG. destruct (Rcompare_spec x 0) as [Hx|Hx|Hx]. (* *) destruct (Rcompare_spec y 0) as [Hy|Hy|Hy]. (* . *) apply Zopp_le_cancel. rewrite 2!Z.opp_involutive. apply Zrnd_le. apply valid_rnd_hG. apply rneg_good. now apply Ropp_le_contravar. (* . *) apply Zopp_le_cancel. rewrite Z.opp_involutive. apply hrndG_pos. apply rneg_good. rewrite <- Ropp_0. apply Ropp_le_contravar. now apply Rlt_le. (* . *) apply Z.le_trans with Z0. apply Zopp_le_cancel. rewrite Z.opp_involutive. apply hrndG_pos. apply rneg_good. rewrite <- Ropp_0. apply Ropp_le_contravar. now apply Rlt_le. apply hrndG_pos. apply rpos_good. now apply Rlt_le. (* *) destruct (Rcompare_spec y 0) as [Hy|Hy|Hy]. elim Rle_not_lt with (1 := Hxy). now rewrite Hx. apply Z.le_refl. apply hrndG_pos. apply rpos_good. now apply Rlt_le. (* *) rewrite Rcompare_Gt. apply Zrnd_le. apply valid_rnd_hG. apply rpos_good. exact Hxy. now apply Rlt_le_trans with x. (* Z2R *) intros n. unfold rndG. rewrite Rcompare_IZR. rewrite <- opp_IZR. rewrite 2!Zrnd_IZR. rewrite Z.opp_involutive. now case n. apply valid_rnd_hG. apply rpos_good. apply valid_rnd_hG. apply rneg_good. Qed. Lemma rndG_conversion_aux : forall rexp f, float2R (round rdir rexp f) = Generic_fmt.round radix2 rexp rndG (float2R f). Proof with auto with typeclass_instances. intros rexp (m, e). unfold float2R. simpl. destruct m as [|m|m]. rewrite 2!F2R_0, round_0... (* *) unfold round. simpl. generalize (hrndG_conversion (rpos rdir) (rpos_good _) rexp m e). unfold Generic_fmt.round, rndG. simpl. rewrite Rcompare_Gt. intros H. rewrite <- H. case round_pos. intros [|n] z ; simpl. unfold float2R. now rewrite 2!F2R_0. apply refl_equal. unfold scaled_mantissa. apply Rmult_lt_0_compat. now apply F2R_gt_0. apply bpow_gt_0. (* *) unfold round. simpl. change (Zneg m) with (- Zpos m)%Z. rewrite F2R_Zopp. generalize (hrndG_conversion (rneg rdir) (rneg_good _) rexp m e). unfold Generic_fmt.round, rndG. simpl. rewrite Rcompare_Lt. rewrite cexp_opp. rewrite scaled_mantissa_opp. rewrite Ropp_involutive. rewrite F2R_Zopp. intros H. rewrite <- H. case round_pos. intros [|n] z ; simpl. unfold float2R. rewrite 2!F2R_0. now rewrite Ropp_0. now rewrite <- Fopp2_correct. rewrite scaled_mantissa_opp. apply Ropp_lt_gt_0_contravar. unfold scaled_mantissa. apply Rmult_lt_0_compat. now apply F2R_gt_0. apply bpow_gt_0. Qed. End ZrndG. Local Existing Instance valid_rnd_G. Record rndG_prop := { rndG_g : round_dir; rndG_f : R -> Z; rndG_eq : forall x, rndG rndG_g x = rndG_f x }. Theorem rndG_conversion : forall rdir rexp f, float2R (round (rndG_g rdir) rexp f) = Generic_fmt.round radix2 rexp (rndG_f rdir) (float2R f). Proof. intros (rf, rg, req) rexp f. simpl. rewrite rndG_conversion_aux. now apply round_ext. Qed. Local Instance valid_rnd_Gf : forall rdir, Valid_rnd (rndG_f rdir). Proof with auto with typeclass_instances. split. intros x y H. rewrite <- 2!rndG_eq. apply Zrnd_le... intros n. rewrite <- rndG_eq. apply Zrnd_IZR... Qed. Lemma roundDN_eq : forall x, rndG roundDN x = Zfloor x. Proof. intros x. simpl. unfold rndG. case Rcompare_spec ; intros H. rewrite hrndG_UP. unfold Zceil. rewrite Ropp_involutive. apply Z.opp_involutive. apply roundDN. apply refl_equal. rewrite H. apply sym_eq. apply Zfloor_IZR. rewrite hrndG_DN ; try easy. apply roundDN. Qed. Canonical Structure roundDN_cs := Build_rndG_prop _ _ roundDN_eq. Lemma roundUP_eq : forall x, rndG roundUP x = Zceil x. Proof. intros x. simpl. unfold rndG. case Rcompare_spec ; intros H. rewrite hrndG_DN ; try easy. apply roundUP. rewrite H. apply sym_eq. apply Zceil_IZR. rewrite hrndG_UP ; try easy. apply roundUP. Qed. Canonical Structure roundUP_cs := Build_rndG_prop _ _ roundUP_eq. Lemma roundZR_eq : forall x, rndG roundZR x = Ztrunc x. Proof. intros x. simpl. unfold rndG, Ztrunc. destruct (Rlt_bool_spec x 0) as [Hx|[Hx|Hx]]. rewrite Rcompare_Lt with (1 := Hx). rewrite hrndG_DN ; try easy. apply roundZR. rewrite Rcompare_Gt with (1 := Hx). rewrite hrndG_DN ; try easy. apply roundZR. rewrite <- Hx. rewrite Rcompare_Eq with (1 := refl_equal _). apply sym_eq. apply Zfloor_IZR. Qed. Canonical Structure roundZR_cs := Build_rndG_prop _ _ roundZR_eq. Lemma roundN_eq : forall r f, ( forall m, (0 <= m)%Z -> forall b c, rneg r (rnd_record_mk (ZtoN m) b c) = andb b (orb c (negb (f (- (m + 1))%Z))) ) -> ( forall m, (0 <= m)%Z -> forall b c, rpos r (rnd_record_mk (ZtoN m) b c) = andb b (orb c (f m)) ) -> forall x, rndG r x = Znearest f x. Proof with auto with typeclass_instances. intros r f Hn Hp x. simpl. destruct (Req_dec (IZR (Zfloor x)) x) as [H1|H1]. rewrite <- H1. rewrite 2!Zrnd_IZR... unfold rndG. case Rcompare_spec ; intros H2. (* *) rewrite hrndG_N. 2: apply rneg_good. rewrite Znearest_opp, Z.opp_involutive. unfold Znearest. case Rcompare ; trivial. rewrite Hn. simpl. replace (- (- (Zfloor x + 1) + 1))%Z with (Zfloor x) by ring. now rewrite negb_involutive. cut (Zfloor x < 0)%Z. lia. apply lt_IZR. apply Rle_lt_trans with (2 := H2). apply Zfloor_lb. intros b. rewrite Hn. apply andb_true_r. apply Zfloor_lub. apply Rlt_le. now apply Ropp_0_gt_lt_contravar. (* *) rewrite H2. apply sym_eq. apply Zrnd_IZR... (* *) rewrite hrndG_N. 2: apply rpos_good. unfold Znearest. case Rcompare ; trivial. rewrite Hp. apply refl_equal. apply Zfloor_lub. now apply Rlt_le. intros b. rewrite Hp. apply andb_true_r. apply Zfloor_lub. now apply Rlt_le. Qed. Lemma roundNE_eq : forall x, rndG roundNE x = rndNE x. Proof. apply roundN_eq ; intros m Hm r s ; unfold roundNE, GrndNE ; simpl ; apply (f_equal (fun v => r && (s || negb v))). rewrite Z.even_opp, Z.even_add. now destruct m as [|[m|m|]|]. now destruct m as [|[m|m|]|]. Qed. Canonical Structure roundNE_cs := Build_rndG_prop _ _ roundNE_eq. Lemma roundNA_eq : forall x, rndG roundNA x = rndNA x. Proof. apply roundN_eq ; intros m Hm r s ; simpl. rewrite Zle_bool_false. now rewrite orb_comm, andb_comm. lia. rewrite Zle_bool_true with (1 := Hm). now rewrite orb_comm, andb_comm. Qed. Canonical Structure roundNA_cs := Build_rndG_prop _ _ roundNA_eq. coq-gappalib-coq-1.10.0-df59b68361b1efbd697b17c40f7fae4a35991c44/src/Gappa_round_aux.v000066400000000000000000000051261517666064600265650ustar00rootroot00000000000000From Coq Require Import ZArith Reals. From Flocq Require Import Zaux Raux Defs Digits Float_prop Generic_fmt FIX FLX. Require Import Gappa_definitions. Require Import Gappa_dyadic. Lemma float2_shift_p1 : forall e m : Z, Float2 m (e + 1) = Float2 (m * 2) e :>R. Proof. intros e m. unfold float2R, F2R. simpl. rewrite bpow_plus. rewrite mult_IZR. change (bpow radix2 1) with 2%R. ring. Qed. Fixpoint digits (m : positive) : positive := match m with | xH => xH | xI p => Pos.succ (digits p) | xO p => Pos.succ (digits p) end. Lemma digits2_digits : forall m : positive, Zpos (digits m) = Zdigits radix2 (Zpos m). Proof. intros m. apply trans_eq with (Z_of_nat (S (digits2_Pnat m))). (* *) induction m ; simpl. now rewrite 2!Zpos_succ_morphism, IHm. now rewrite 2!Zpos_succ_morphism, IHm. easy. (* *) rewrite Zdigits_mag. 2: easy. apply sym_eq. apply mag_unique. generalize (digits2_Pnat_correct m). generalize (digits2_Pnat m). intros d H. simpl in H. replace (Z_of_nat (S d) - 1)%Z with (Z_of_nat d). rewrite <- abs_IZR. rewrite <- 2!IZR_Zpower_nat. split. now apply IZR_le. now apply IZR_lt. rewrite inj_S. apply Zpred_succ. Qed. Definition pos_of_Z (n : Z) := match n with | Zpos p => p | _ => xH end. Lemma Zpos_pos_of_Z : forall a : Z, (0 < a)%Z -> (Zpos (pos_of_Z a) = a)%Z. Proof. induction a ; intros ; compute in H ; try discriminate H. exact (refl_equal _). Qed. Lemma FIX_iff_generic : forall k x, FIX x k <-> generic_format radix2 (FIX_exp k) x. Proof. intros k x. split. intros ((m,e),(H1,H2)). rewrite <- H1. now apply generic_format_F2R. intros H. destruct (FIX_format_generic _ _ _ H) as ((m,e),H1,H2). exists (Float2 m e) ; repeat split. easy. rewrite <- H2. apply Z.le_refl. Qed. Lemma FLT_iff_generic : forall p x, FLT x p <-> generic_format radix2 (FLX_exp (Zpos p)) x. Proof. intros p x. split. intros ((m,e),(H1,H2)). apply generic_format_FLX. exists (Float radix2 m e). now apply sym_eq. exact H2. intros H. destruct (@FLX_format_generic _ (Zpos p) (refl_equal Lt) _ H) as ((m,e),H1,H2). now exists (Float2 m e) ; repeat split. Qed. Lemma fix_le : forall x : R, forall xn zn : Z, FIX x xn -> (zn <= xn)%Z -> FIX x zn. Proof. intros x xn zn (xf,(Hx1,Hx2)) H. exists xf. split. exact Hx1. apply Z.le_trans with (1 := H) (2 := Hx2). Qed. Lemma flt_le : forall x : R, forall xn zn : positive, FLT x xn -> (Zpos xn <= Zpos zn)%Z -> FLT x zn. Proof. intros x xn zn (xf,(Hx1,Hx2)) H. exists xf. split. exact Hx1. apply Z.lt_le_trans with (1 := Hx2). apply le_IZR. change (IZR (Zpower radix2 (Zpos xn)) <= IZR (Zpower radix2 (Zpos zn)))%R. apply IZR_le. now apply Zpower_le. Qed. coq-gappalib-coq-1.10.0-df59b68361b1efbd697b17c40f7fae4a35991c44/src/Gappa_round_def.v000066400000000000000000000057201517666064600265260ustar00rootroot00000000000000From Coq Require Import Bool ZArith. From Flocq Require Import Raux Generic_fmt Round_NE. Record rnd_record : Set := rnd_record_mk { rnd_m : N ; rnd_r : bool ; rnd_s : bool }. Definition is_even (n : N) := match n with | N0 => true | Npos (xO _) => true | _ => false end. Definition good_rdir (rdir: rnd_record -> bool) := forall m : N, rdir (rnd_record_mk m false false) = false /\ (rdir (rnd_record_mk m false true) = false \/ rdir (rnd_record_mk m true false) = true) /\ (rdir (rnd_record_mk m true false) = false \/ rdir (rnd_record_mk m true true) = true). Record round_dir : Set := round_dir_mk { rpos : rnd_record -> bool ; rneg : rnd_record -> bool ; rpos_good : good_rdir rpos ; rneg_good : good_rdir rneg }. Definition GrndZR (r : rnd_record) : bool := false. Lemma GrndZR_good : good_rdir GrndZR. Proof. unfold good_rdir, GrndZR. simpl. intuition. Qed. Definition GrndAW (r : rnd_record) : bool := rnd_r r || rnd_s r. Lemma GrndAW_good : good_rdir GrndAW. Proof. unfold good_rdir, GrndAW. simpl. intuition. Qed. Definition GrndNE (r : rnd_record) : bool := rnd_r r && (rnd_s r || negb (is_even (rnd_m r))). Lemma GrndNE_good : good_rdir GrndNE. Proof. unfold good_rdir, GrndNE. simpl. intuition. Qed. Definition GrndNO (r : rnd_record) : bool := rnd_r r && (rnd_s r || is_even (rnd_m r)). Lemma GrndNO_good : good_rdir GrndNO. Proof. unfold good_rdir, GrndNO. simpl. intuition. Qed. Definition GrndNZ (r : rnd_record) : bool := rnd_r r && rnd_s r. Lemma GrndNZ_good : good_rdir GrndNZ. Proof. unfold good_rdir, GrndNZ. simpl. intuition. Qed. Definition GrndNA (r : rnd_record) : bool := rnd_r r. Lemma GrndNA_good : good_rdir GrndNA. Proof. unfold good_rdir, GrndNA. simpl. intuition. Qed. Definition GrndOD (r : rnd_record) : bool := (rnd_r r || rnd_s r) && is_even (rnd_m r). Lemma GrndOD_good : good_rdir GrndOD. Proof. unfold good_rdir, GrndOD. simpl. intros. case (is_even m) ; intuition. Qed. Definition roundZR := round_dir_mk GrndZR GrndZR GrndZR_good GrndZR_good. Definition roundAW := round_dir_mk GrndAW GrndAW GrndAW_good GrndAW_good. Definition roundUP := round_dir_mk GrndAW GrndZR GrndAW_good GrndZR_good. Definition roundDN := round_dir_mk GrndZR GrndAW GrndZR_good GrndAW_good. Definition roundOD := round_dir_mk GrndOD GrndOD GrndOD_good GrndOD_good. Definition roundNE := round_dir_mk GrndNE GrndNE GrndNE_good GrndNE_good. Definition roundNO := round_dir_mk GrndNO GrndNO GrndNO_good GrndNO_good. Definition roundNZ := round_dir_mk GrndNZ GrndNZ GrndNZ_good GrndNZ_good. Definition roundNA := round_dir_mk GrndNA GrndNA GrndNA_good GrndNA_good. Definition roundNU := round_dir_mk GrndNA GrndNZ GrndNA_good GrndNZ_good. Definition roundND := round_dir_mk GrndNZ GrndNA GrndNZ_good GrndNA_good. Global Notation rndDN := Zfloor (only parsing). Global Notation rndUP := Zceil (only parsing). Global Notation rndZR := Ztrunc (only parsing). Global Notation rndAW := Zaway (only parsing). Definition rndNE := ZnearestE. Definition rndNA := ZnearestA. coq-gappalib-coq-1.10.0-df59b68361b1efbd697b17c40f7fae4a35991c44/src/Gappa_tactic.v000066400000000000000000001130731517666064600260310ustar00rootroot00000000000000From Coq Require Import ZArith Reals List Lia Lra. From Flocq Require Import Core. Require Export Gappa_library. Strategy 1000 [Generic_fmt.round]. Module Gappa_Private. (* factor an integer into odd*2^e *) Definition float2_of_pos x := let fix aux (m : positive) e { struct m } := match m with | xO p => aux p (Z.succ e) | _ => Float2 (Zpos m) e end in aux x Z0. Lemma float2_of_pos_correct : forall x, float2R (float2_of_pos x) = IZR (Zpos x). Proof. intros x. unfold float2_of_pos. rewrite <- (Rmult_1_r (IZR (Zpos x))). change (IZR (Zpos x) * 1)%R with (float2R (Float2 (Zpos x) 0%Z)). generalize 0%Z. induction x ; intros e ; try apply refl_equal. rewrite IHx. unfold float2R. simpl. replace (Zpos (xO x)) with (Zpos x * 2)%Z. exact (Gappa_round_aux.float2_shift_p1 _ _). now rewrite Zmult_comm. Qed. Definition compact_float2 m e := match m with | Z0 => Float2 0 0 | Zpos p => match float2_of_pos p with | Float2 m e1 => Float2 m (e + e1) end | Zneg p => match float2_of_pos p with | Float2 m e1 => Float2 (-m) (e + e1) end end. Lemma compact_float2_correct : forall m e, float2R (compact_float2 m e) = float2R (Float2 m e). Proof. unfold float2R, F2R. simpl. intros [|m|m] e ; simpl. now rewrite 2!Rmult_0_l. rewrite <- (float2_of_pos_correct m). destruct (float2_of_pos m) as (m1, e1). simpl. rewrite Zplus_comm. now rewrite bpow_plus, <- Rmult_assoc. change (IZR (Zneg m)) with (- IZR (Zpos m))%R. rewrite <- (float2_of_pos_correct m). destruct (float2_of_pos m) as (m1, e1). simpl. rewrite Zplus_comm. rewrite bpow_plus, <- Rmult_assoc. now rewrite opp_IZR, Ropp_mult_distr_l_reverse. Qed. Definition float10_of_pos x := let fix aux (n : nat) m e { struct n } := match n, m with | S n, xO p => let (q,r) := Z.pos_div_eucl p 5 in match r, q with | Z0, Zpos q => aux n q (Z.succ e) | _, _ => Float10 (Zpos m) e end | _, _ => Float10 (Zpos m) e end in aux (Digits.digits2_Pnat x) x Z0. Lemma float10_of_pos_correct : forall x, float10R (float10_of_pos x) = IZR (Zpos x). Proof. intros x. unfold float10_of_pos. rewrite <- (Rmult_1_r (IZR (Zpos x))). change (IZR (Zpos x) * 1)%R with (float10R (Float10 (Zpos x) 0%Z)). generalize (Digits.digits2_Pnat x) 0%Z. intros n. revert x. induction n ; intros m e. easy. destruct m as [m|m|] ; try easy. generalize (Z.pos_div_eucl_eq m 5 eq_refl). destruct Z.pos_div_eucl as [q r]. intros Hm. destruct r as [|r|r] ; try easy. destruct q as [|q|q] ; try easy. rewrite IHn. rewrite Pos2Z.pos_xO, Hm. replace (2 * (Zpos q * 5 + 0))%Z with (Zpos q * 10)%Z by ring. unfold float10R, F2R. simpl. unfold Z.succ. rewrite Zplus_comm. rewrite bpow_plus, <- Rmult_assoc. change (Zpos (q * 10)) with (Zpos q * 10)%Z. now rewrite mult_IZR. Qed. Definition compact_float10 m e := match m with | Z0 => Float10 0 0 | Zpos p => match float10_of_pos p with | Float10 m e1 => Float10 m (e + e1) end | Zneg p => match float10_of_pos p with | Float10 m e1 => Float10 (-m) (e + e1) end end. Lemma compact_float10_correct : forall m e, float10R (compact_float10 m e) = float10R (Float10 m e). Proof. unfold float10R, F2R. simpl. intros [|m|m] e ; simpl. now rewrite 2!Rmult_0_l. rewrite <- (float10_of_pos_correct m). destruct (float10_of_pos m) as [m1 e1]. simpl. rewrite Zplus_comm. now rewrite bpow_plus, <- Rmult_assoc. change (IZR (Zneg m)) with (- IZR (Zpos m))%R. rewrite <- (float10_of_pos_correct m). destruct (float10_of_pos m) as [m1 e1]. simpl. rewrite Zplus_comm. rewrite bpow_plus, <- Rmult_assoc. now rewrite opp_IZR, Ropp_mult_distr_l_reverse. Qed. Inductive UnaryOp : Set := | uoNeg | uoSqrt | uoAbs | uoInv. Inductive BinaryOp : Set := | boAdd | boSub | boMul | boDiv. Inductive Format : Set := | fFixed : Z -> Format | fFloat : Z -> Z -> Format | fFloatx : Z -> Format. Inductive Mode : Set := | mRndDN | mRndUP | mRndZR | mRndAW | mRndNE | mRndNA. (* represent an expression on real numbers *) Inductive RExpr := | reUnknown : positive -> RExpr | reInteger : Z -> RExpr | reFloat2 : Z -> Z -> RExpr | reFloat10 : Z -> Z -> RExpr | reUnary : UnaryOp -> RExpr -> RExpr | reBinary : BinaryOp -> RExpr -> RExpr -> RExpr | reBpow2 : Z -> RExpr | reBpow10 : Z -> RExpr | rePow2 : Z -> RExpr | rePow10 : Z -> RExpr | reINR : positive -> RExpr | reIZR : Z -> RExpr | reRound : Format -> Mode -> RExpr -> RExpr. Scheme Equality for positive. Scheme Equality for Z. Scheme Equality for UnaryOp. Scheme Equality for BinaryOp. Scheme Equality for Format. Scheme Equality for Mode. Scheme Equality for RExpr. (* represent an atomic proposition *) Inductive RAtom := | raBound : option RExpr -> RExpr -> option RExpr -> RAtom | raRel : RExpr -> RExpr -> RExpr -> RExpr -> RAtom | raLin : RExpr -> RExpr -> RExpr -> RExpr -> RAtom | raLe : RExpr -> RExpr -> RAtom | raEq : RExpr -> RExpr -> RAtom | raGeneric : Format -> RExpr -> RAtom | raFormat : Format -> RExpr -> RAtom. Inductive RTree := | rtTrue : RTree | rtFalse : RTree | rtAtom : RAtom -> RTree | rtNot : RTree -> RTree | rtAnd : RTree -> RTree -> RTree | rtOr : RTree -> RTree -> RTree | rtImpl : RTree -> RTree -> RTree. Section Convert. Definition convert_exp (f : Format) : Z -> Z := match f with | fFloat e p => FLT_exp e p | fFloatx p => FLX_exp p | fFixed e => FIX_exp e end. Definition convert_format (f : Format) : R -> Prop := match f with | fFloat e p => FLT_format radix2 e p | fFloatx p => FLX_format radix2 p | fFixed e => FIX_format radix2 e end. Definition convert_mode (m : Mode) : R -> Z := match m with | mRndZR => Ztrunc | mRndDN => Zfloor | mRndUP => Zceil | mRndAW => Zaway | mRndNE => rndNE | mRndNA => rndNA end. Variable unknown_values : list R. (* convert to an expression on real numbers *) Fixpoint convert_expr (t : RExpr) : R := match t with | reUnknown x => nth (nat_of_P x) (R0 :: unknown_values) R0 | reInteger x => IZR x | reFloat2 x y => float2R (Float2 x y) | reFloat10 x y => float10R (Float10 x y) | reUnary o x => match o with | uoNeg => Ropp | uoSqrt => sqrt | uoAbs => Rabs | uoInv => Rinv end (convert_expr x) | reBinary o x y => match o with | boAdd => Rplus | boSub => Rminus | boMul => Rmult | boDiv => Rdiv end (convert_expr x) (convert_expr y) | reBpow2 x => bpow radix2 x | reBpow10 x => bpow radix10 x | rePow2 x => powerRZ 2%R x | rePow10 x => powerRZ 10%R x | reINR x => INR (nat_of_P x) | reIZR x => IZR x | reRound f m x => Generic_fmt.round radix2 (convert_exp f) (convert_mode m) (convert_expr x) end. (* convert to an atomic proposition *) Definition convert_atom (a : RAtom) : Prop := match a with | raBound None _ None => True | raBound (Some l) e None => (convert_expr l <= convert_expr e)%R | raBound None e (Some u) => (convert_expr e <= convert_expr u)%R | raBound (Some l) e (Some u) => (convert_expr l <= convert_expr e <= convert_expr u)%R | raRel er ex l u => exists eps : R, (convert_expr l <= eps <= convert_expr u)%R /\ (convert_expr er = convert_expr ex * (1 + eps))%R | raLin er ex l u => exists eps : R, (convert_expr l <= eps <= convert_expr u)%R /\ (convert_expr er = convert_expr ex * eps)%R | raLe x y => (convert_expr x <= convert_expr y)%R | raEq x y => (convert_expr x = convert_expr y)%R | raGeneric f x => generic_format radix2 (convert_exp f) (convert_expr x) | raFormat f x => convert_format f (convert_expr x) end. Fixpoint convert_tree (t : RTree) : Prop := match t with | rtTrue => True | rtFalse => False | rtAtom a => convert_atom a | rtNot t => not (convert_tree t) | rtAnd t1 t2 => (convert_tree t1) /\ (convert_tree t2) | rtOr t1 t2 => (convert_tree t1) \/ (convert_tree t2) | rtImpl t1 t2 => (convert_tree t1) -> (convert_tree t2) end. Lemma decidable_atom : forall a, { convert_atom a } + { not (convert_atom a) }. Proof with auto with typeclass_instances. intros [[l|] e [u|]|x y l u|x y l u|x y|x y|fmt x|fmt x] ; simpl. - destruct (Rle_lt_dec (convert_expr l) (convert_expr e)) as [Hl|Hl]. destruct (Rle_lt_dec (convert_expr e) (convert_expr u)) as [Hu|Hu]. now left. right. lra. right. lra. - destruct (Rle_lt_dec (convert_expr l) (convert_expr e)) as [Hl|Hl]. now left. right. now apply Rlt_not_le. - destruct (Rle_lt_dec (convert_expr e) (convert_expr u)) as [Hu|Hu]. now left. right. now apply Rlt_not_le. - now left. - destruct (Req_EM_T (convert_expr y) 0) as [Zy|Zy]. destruct (Req_EM_T (convert_expr x) 0) as [Zx|Zx]. destruct (Rle_lt_dec (convert_expr l) (convert_expr u)) as [H|H]. left. exists (convert_expr l). split. lra. now rewrite Zy, Rmult_0_l. right. intros [eps [[H1 H2] _]]. lra. right. intros [eps [_ H']]. elim Zx. rewrite H', Zy. apply Rmult_0_l. destruct (Rle_lt_dec (convert_expr l) (convert_expr x / convert_expr y - 1)) as [Hl|Hl]. destruct (Rle_lt_dec (convert_expr x / convert_expr y - 1) (convert_expr u)) as [Hu|Hu]. left. exists (convert_expr x / convert_expr y - 1)%R. split. now split. now field. right. intros [eps [[_ H] H']]. apply Rlt_not_le with (1 := Hu). rewrite H'. now replace (convert_expr y * (1 + eps) / convert_expr y - 1)%R with eps by now field. right. intros [eps [[H _] H']]. apply Rlt_not_le with (1 := Hl). rewrite H'. now replace (convert_expr y * (1 + eps) / convert_expr y - 1)%R with eps by now field. - destruct (Req_EM_T (convert_expr y) 0) as [Zy|Zy]. destruct (Req_EM_T (convert_expr x) 0) as [Zx|Zx]. destruct (Rle_lt_dec (convert_expr l) (convert_expr u)) as [H|H]. left. exists (convert_expr l). split. lra. now rewrite Zy, Rmult_0_l. right. intros [eps [[H1 H2] _]]. lra. right. intros [eps [_ H']]. elim Zx. rewrite H', Zy. apply Rmult_0_l. destruct (Rle_lt_dec (convert_expr l) (convert_expr x / convert_expr y)) as [Hl|Hl]. destruct (Rle_lt_dec (convert_expr x / convert_expr y) (convert_expr u)) as [Hu|Hu]. left. exists (convert_expr x / convert_expr y)%R. split. now split. now field. right. intros [eps [[_ H] H']]. apply Rlt_not_le with (1 := Hu). rewrite H'. now replace (convert_expr y * eps / convert_expr y)%R with eps by now field. right. intros [eps [[H _] H']]. apply Rlt_not_le with (1 := Hl). rewrite H'. now replace (convert_expr y * eps / convert_expr y)%R with eps by now field. - destruct (Rle_lt_dec (convert_expr x) (convert_expr y)) as [H|H]. now left. right. now apply Rlt_not_le. - apply Req_EM_T. - apply Req_EM_T. - destruct fmt as [e|e p|p]. simpl. destruct (Req_EM_T (convert_expr x) (round radix2 (FIX_exp e) rndZR (convert_expr x))) as [H|H]. left. apply FIX_format_generic. rewrite H. apply generic_format_round... right. contradict H. apply sym_eq, round_generic... now apply generic_format_FIX. destruct (Z_lt_le_dec 0 p) as [Hp|Hp]. destruct (Req_EM_T (convert_expr x) (round radix2 (FLT_exp e p) rndZR (convert_expr x))) as [H|H]. left. apply FLT_format_generic. apply Hp. rewrite H. apply generic_format_round... right. contradict H. apply sym_eq, round_generic... now apply generic_format_FLT. destruct p. 2: easy. destruct (Req_EM_T (convert_expr x) 0) as [H|H]. left. rewrite H. exists (Float radix2 0 e). apply sym_eq, F2R_0. apply eq_refl. apply Z.le_refl. right. intros [[xm xe] H1 H2 H3]. simpl in H2. assert (xm = Z0). clear -H2 ; zify ; lia. elim H. rewrite H1, H0. apply F2R_0. right. intros [[xm xe] H1 H2 H3]. apply Zlt_not_le with (1 := H2). apply Zabs_pos. destruct (Z_lt_le_dec 0 p) as [Hp|Hp]. destruct (Req_EM_T (convert_expr x) (round radix2 (FLX_exp p) rndZR (convert_expr x))) as [H|H]. left. apply FLX_format_generic. apply Hp. rewrite H. apply generic_format_round... right. contradict H. apply sym_eq, round_generic... now apply generic_format_FLX. destruct p. 2: easy. destruct (Req_EM_T (convert_expr x) 0) as [H|H]. left. rewrite H. exists (Float radix2 0 0). apply sym_eq, F2R_0. apply eq_refl. right. intros [[xm xe] H1 H2]. simpl in H2. assert (xm = Z0). clear -H2 ; zify ; lia. elim H. rewrite H1, H0. apply F2R_0. right. intros [[xm xe] H1 H2]. apply Zlt_not_le with (1 := H2). apply Zabs_pos. Qed. Lemma decidable_tree : forall t, { convert_tree t } + { not (convert_tree t) }. Proof. induction t as [| |a|t Ht|t1 Ht1 t2 Ht2|t1 Ht1 t2 Ht2|t1 Ht1 t2 Ht2]. now left. now right. apply decidable_atom. destruct Ht as [Ht|Ht]. now right. now left. destruct Ht1 as [Ht1|Ht1]. destruct Ht2 as [Ht2|Ht2]. now left ; split. right. now intros (_,H). right. now intros (H,_). destruct Ht1 as [Ht1|Ht1]. left. now left. destruct Ht2 as [Ht2|Ht2]. left. now right. right. now intros [H|H]. destruct Ht2 as [Ht2|Ht2]. left. now intros _. destruct Ht1 as [Ht1|Ht1]. right. contradict Ht2. now apply Ht2. left. now intros H. Qed. Fixpoint normalize_tree (t : RTree) (pos : bool) := match t with | rtTrue => if pos then rtTrue else rtFalse | rtFalse => if pos then rtFalse else rtTrue | rtAtom a => if pos then t else rtNot t | rtNot t => normalize_tree t (negb pos) | rtImpl t1 t2 => (if pos then rtOr else rtAnd) (normalize_tree t1 (negb pos)) (normalize_tree t2 pos) | rtOr t1 t2 => (if pos then rtOr else rtAnd) (normalize_tree t1 pos) (normalize_tree t2 pos) | rtAnd t1 t2 => (if pos then rtAnd else rtOr) (normalize_tree t1 pos) (normalize_tree t2 pos) end. Theorem normalize_tree_correct : forall t pos, convert_tree (normalize_tree t pos) <-> if pos then convert_tree t else not (convert_tree t). Proof. induction t as [| |a|t Ht|t1 Ht1 t2 Ht2|t1 Ht1 t2 Ht2|t1 Ht1 t2 Ht2] ; destruct pos ; split ; simpl ; try easy. try (intros H ; now apply H). apply (Ht false). apply (Ht false). intros H. intros H'. apply H'. now apply (Ht true). intros H. apply (Ht true). now destruct (decidable_tree t) as [H'|H']. intros (H1,H2). split. now apply (Ht1 true). now apply (Ht2 true). intros (H1,H2). split. now apply (Ht1 true). now apply (Ht2 true). intros [H|H] (H1,H2). now apply (Ht1 false). now apply (Ht2 false). specialize (Ht1 false). specialize (Ht2 false). intros H. destruct (decidable_tree t1) as [H'|H']. right. apply Ht2. contradict H. now split. left. now apply Ht1. intros [H|H]. left. now apply (Ht1 true). right. now apply (Ht2 true). intros [H|H]. left. now apply (Ht1 true). right. now apply (Ht2 true). intros (H1,H2) [H|H]. now apply (Ht1 false). now apply (Ht2 false). intros H. split. apply (Ht1 false). contradict H. now left. apply (Ht2 false). contradict H. now right. intros [H|H] H'. now apply (Ht1 false) in H. now apply (Ht2 true). intros H. destruct (decidable_tree t1) as [H'|H']. right. apply (Ht2 true). now apply H. left. now apply (Ht1 false). intros (H1,H2) H'. apply (Ht1 true) in H1. apply H' in H1. now apply (Ht2 false). intros H. split. destruct (decidable_tree t1) as [H'|H']. now apply (Ht1 true). now elim H. apply (Ht2 false). now contradict H. Qed. Fixpoint simplify_tree (t : RTree) := match t with | rtNot rtTrue => rtFalse | rtNot rtFalse => rtTrue | rtAnd t1 t2 => match simplify_tree t1, simplify_tree t2 with | rtTrue, t => t | rtFalse, _ => rtFalse | t, rtTrue => t | _, rtFalse => rtFalse | t1, t2 => rtAnd t1 t2 end | rtOr t1 t2 => match simplify_tree t1, simplify_tree t2 with | rtTrue, _ => rtTrue | rtFalse, t => t | _, rtTrue => rtTrue | t, rtFalse => t | t1, t2 => rtOr t1 t2 end | _ => t end. Theorem simplify_tree_correct : forall t, convert_tree t -> convert_tree (simplify_tree t). Proof. induction t as [| |a|t Ht|t1 Ht1 t2 Ht2|t1 Ht1 t2 Ht2|t1 Ht1 t2 Ht2] ; try easy. destruct t ; try easy. intros H. now apply H. intros (H1,H2). specialize (Ht1 H1). specialize (Ht2 H2). simpl. destruct (simplify_tree t1) ; try easy ; destruct (simplify_tree t2) ; try easy ; split ; easy. intros [H|H]. specialize (Ht1 H). simpl. destruct (simplify_tree t1) ; try easy ; destruct (simplify_tree t2) ; try easy ; left ; easy. specialize (Ht2 H). simpl. destruct (simplify_tree t1) ; try easy ; destruct (simplify_tree t2) ; try easy ; right ; easy. Qed. Section StableExpr. Definition stable_expr f := forall t, convert_expr (f t) = convert_expr t. Variable chg_expr : RExpr -> RExpr. (* apply a function recursively, starting from the leafs of an expression *) Fixpoint transform_expr (t : RExpr) := chg_expr match t with | reUnary o x => reUnary o (transform_expr x) | reBinary o x y => reBinary o (transform_expr x) (transform_expr y) | reRound f m x => reRound f m (transform_expr x) | _ => t end. Theorem transform_expr_correct : stable_expr chg_expr -> stable_expr transform_expr. Proof. unfold stable_expr. intros Hf t. induction t ; simpl ; rewrite Hf ; simpl ; try easy. now rewrite IHt. now rewrite IHt1, IHt2. now rewrite IHt. Qed. End StableExpr. Definition stable_atom f := forall a, convert_atom (f a) <-> convert_atom a. Definition transform_atom_bound f a := match a with | raBound (Some l) e (Some u) => raBound (Some (f l)) e (Some (f u)) | raBound (Some l) e None => raBound (Some (f l)) e None | raBound None e (Some u) => raBound None e (Some (f u)) | raRel er ex l u => raRel er ex (f l) (f u) | raLin er ex l u => raLin er ex (f l) (f u) | _ => a end. Theorem transform_atom_bound_correct : forall f, stable_expr f -> stable_atom (transform_atom_bound (transform_expr f)). Proof. now intros f Hf [[l|] e [u|]|x y l u|x y l u|x y|x y|fmt x|fmt x] ; simpl ; split ; repeat rewrite (transform_expr_correct _ Hf). Qed. Definition transform_atom_expr f a := match a with | raBound l e u => raBound l (f e) u | raRel er ex l u => raRel (f er) (f ex) l u | raLin er ex l u => raLin (f er) (f ex) l u | raEq ex ey => raEq (f ex) (f ey) | raLe ex ey => raLe (f ex) (f ey) | raGeneric fmt e => raGeneric fmt (f e) | raFormat fmt e => raFormat fmt (f e) end. Theorem transform_atom_expr_correct : forall f, stable_expr f -> stable_atom (transform_atom_expr (transform_expr f)). Proof. now intros f Hf [l e u|x y l u|x y l u|x y|x y|fmt x|fmt x] ; simpl ; split ; repeat rewrite (transform_expr_correct _ Hf). Qed. Definition stable_tree f := forall t, convert_tree (f t) <-> convert_tree t. Section StableTree. Variable chg_atom : RAtom -> RAtom. Fixpoint transform_tree_atom (t : RTree) : RTree := match t with | rtTrue => rtTrue | rtFalse => rtFalse | rtAtom a => rtAtom (chg_atom a) | rtNot t => rtNot (transform_tree_atom t) | rtAnd t1 t2 => rtAnd (transform_tree_atom t1) (transform_tree_atom t2) | rtOr t1 t2 => rtOr (transform_tree_atom t1) (transform_tree_atom t2) | rtImpl t1 t2 => rtImpl (transform_tree_atom t1) (transform_tree_atom t2) end. Theorem transform_tree_atom_correct : stable_atom chg_atom -> stable_tree transform_tree_atom. Proof. intros Hs t. induction t as [| |a|t Ht|t1 Ht1 t2 Ht2|t1 Ht1 t2 Ht2|t1 Ht1 t2 Ht2] ; simpl ; intuition. now apply Hs. now apply Hs. Qed. End StableTree. Definition stable_atom_tree f := forall a (pos : bool), (if pos then convert_atom a else not (convert_atom a)) -> convert_tree (f pos a). Section StableTree'. Variable chg_atom : bool -> RAtom -> RTree. Fixpoint transform_tree_atom' (t : RTree) : RTree := match t with | rtTrue => rtTrue | rtFalse => rtFalse | rtAtom a => chg_atom true a | rtNot (rtAtom a) => chg_atom false a | rtAnd t1 t2 => rtAnd (transform_tree_atom' t1) (transform_tree_atom' t2) | rtOr t1 t2 => rtOr (transform_tree_atom' t1) (transform_tree_atom' t2) | _ => t end. Theorem transform_tree_atom'_correct : stable_atom_tree chg_atom -> forall t, convert_tree t -> convert_tree (transform_tree_atom' t). Proof. intros Hs t. induction t as [| |a|t Ht|t1 Ht1 t2 Ht2|t1 Ht1 t2 Ht2|t1 Ht1 t2 Ht2] ; simpl ; intuition. destruct t ; intuition. Qed. End StableTree'. Definition compact_posfloat2 m e := match compact_float2 m e with | Float2 m1 0 => reInteger m1 | Float2 m1 e1 => match m1 with | Zneg m1 => reUnary uoNeg (reFloat2 (Zpos m1) e1) | _ => reFloat2 m1 e1 end end. Lemma compact_posfloat2_correct : forall m e, convert_expr (compact_posfloat2 m e) = (IZR m * bpow radix2 e)%R. Proof. intros m e. unfold compact_posfloat2. generalize (compact_float2_correct m e). destruct compact_float2 as [m' e']. destruct e'. unfold float2R, F2R. simpl. now rewrite Rmult_1_r. destruct m' as [|m'|m'] ; try easy. simpl. now rewrite <- Gappa_dyadic.Fopp2_correct. destruct m' as [|m'|m'] ; try easy. simpl. now rewrite <- Gappa_dyadic.Fopp2_correct. Qed. Definition compact_posfloat10 m e := match compact_float10 m e with | Float10 m1 0 => reInteger m1 | Float10 m1 e1 => match m1 with | Zneg m1 => reUnary uoNeg (reFloat10 (Zpos m1) e1) | _ => reFloat10 m1 e1 end end. Lemma compact_posfloat10_correct : forall m e, convert_expr (compact_posfloat10 m e) = (IZR m * bpow radix10 e)%R. Proof. intros m e. unfold compact_posfloat10. generalize (compact_float10_correct m e). destruct compact_float10 as [m' e']. destruct e'. unfold float10R, F2R. simpl. now rewrite Rmult_1_r. destruct m' as [|m'|m'] ; try easy. simpl. unfold float10R, F2R. simpl. now rewrite Ropp_mult_distr_l. destruct m' as [|m'|m'] ; try easy. simpl. unfold float10R, F2R. simpl. now rewrite Ropp_mult_distr_l. Qed. (* transform INR and IZR into real integers, change a/b and a*2^b into floats *) Definition gen_float_func t := match t with | reUnary uoNeg (reInteger (Zpos x)) => reInteger (Zneg x) | reBinary boDiv (reInteger x) (reInteger (Zpos y)) => match float2_of_pos y with | Float2 1 (Zpos y') => compact_posfloat2 x (Zneg y') | _ => t end | reBinary boMul (reInteger x) (reBpow2 y) => compact_posfloat2 x y | reBinary boMul (reInteger x) (reBpow10 y) => compact_posfloat10 x y | reBinary boMul (reInteger x) (rePow2 y) => compact_posfloat2 x y | reBinary boMul (reInteger x) (rePow10 y) => compact_posfloat10 x y | reINR x => reInteger (Zpos x) | reIZR x => reInteger x | _ => t end. Lemma gen_float_prop : stable_expr gen_float_func. Proof. intros [x|x|x y|x y|o x|o x y|x|x|x|x|x|x|f m x] ; try apply refl_equal. (* unary ops *) destruct o ; try apply refl_equal. destruct x ; try apply refl_equal. destruct z ; apply refl_equal. (* binary ops *) destruct o ; try apply refl_equal ; destruct x ; try apply refl_equal ; destruct y ; try apply refl_equal. (* . x * 2^y *) apply compact_posfloat2_correct. (* . x * 10^y *) apply compact_posfloat10_correct. (* . x * 2^y *) simpl. rewrite <- (bpow_powerRZ radix2). apply compact_posfloat2_correct. (* . x * 10^y *) simpl. rewrite <- (bpow_powerRZ radix10). apply compact_posfloat10_correct. (* . x / 2*2*2*2 *) destruct z0 ; try apply refl_equal. generalize (float2_of_pos_correct p). simpl. destruct (float2_of_pos p) as ([|[m|m|]|m], [|e|e]) ; intros H ; try apply refl_equal. rewrite compact_posfloat2_correct. rewrite <- H. unfold float2R, F2R. simpl. now rewrite Rmult_1_l. (* INR *) simpl. rewrite <- positive_nat_Z. apply sym_eq, INR_IZR_INZ. Qed. (* remove pending powerRZ *) Definition clean_pow_func t := match t with | reBpow2 x => reFloat2 1 x | reBpow10 x => reFloat10 1 x | rePow2 x => reFloat2 1 x | rePow10 x => reFloat10 1 x | _ => t end. Lemma clean_pow_prop : stable_expr clean_pow_func. Proof. intros [x|x|x y|x y|o x|o x y|x|x|x|x|x|x|f m x] ; try apply refl_equal. apply (F2R_bpow radix2 x). apply (F2R_bpow radix10 x). simpl. unfold float2R. rewrite F2R_bpow. apply bpow_powerRZ. simpl. unfold float10R. rewrite F2R_bpow. apply bpow_powerRZ. Qed. (* compute on constant terms, so that they are hopefully represented by a single float *) Definition merge_float2_aux m e := match compact_float2 m e with | Float2 m1 e1 => reFloat2 m1 e1 end. Definition merge_float2_func t := match t with | reInteger x => merge_float2_aux x 0 | reUnary uoNeg (reFloat2 x y) => merge_float2_aux (- x) y | reBinary boMul (reFloat2 x1 y1) (reFloat2 x2 y2) => merge_float2_aux (x1 * x2) (y1 + y2) | reFloat2 x y => merge_float2_aux x y | _ => t end. Lemma merge_float2_prop : stable_expr merge_float2_func. Proof. assert (forall m e, convert_expr (merge_float2_aux m e) = convert_expr (reFloat2 m e)). intros. unfold merge_float2_aux. generalize (compact_float2_correct m e). now destruct (compact_float2 m e). (* . *) intros [x|x|x y|x y|o x|o x y|x|x|x|x|x|x|f m x] ; try apply refl_equal ; try exact (H x _). (* integer *) simpl. unfold merge_float2_aux. generalize (compact_float2_correct x 0). rewrite <- (Rmult_1_r (IZR x)). now destruct (compact_float2 x 0). (* unary ops *) destruct o ; try apply refl_equal. destruct x ; try apply refl_equal. simpl. rewrite H. now rewrite <- Gappa_dyadic.Fopp2_correct. (* binary ops *) destruct o ; try apply refl_equal. destruct x ; try apply refl_equal. destruct y ; try apply refl_equal. simpl. rewrite H. now rewrite <- Gappa_dyadic.Fmult2_correct. Qed. (* change /a into 1/a *) Definition remove_inv_func t := match t with | reUnary uoInv x => reBinary boDiv (reInteger 1) x | _ => t end. Lemma remove_inv_prop : stable_expr remove_inv_func. Proof. intros [x|x|x y|x y|o x|o x y|x|x|x|x|x|x|f m x] ; try apply refl_equal. destruct o ; try apply refl_equal. exact (Rmult_1_l _). Qed. Definition get_float2_bound b := transform_expr merge_float2_func (transform_expr clean_pow_func (transform_expr gen_float_func (transform_expr remove_inv_func b))). Lemma get_float2_bound_correct : stable_expr get_float2_bound. Proof. intros b. unfold get_float2_bound. rewrite (transform_expr_correct _ merge_float2_prop). rewrite (transform_expr_correct _ clean_pow_prop). rewrite (transform_expr_correct _ gen_float_prop). now rewrite (transform_expr_correct _ remove_inv_prop). Qed. Definition change_abs_func a := match a with | raLe (reUnary uoAbs u as u') v => raBound (Some (reFloat2 0 0)) u' (Some v) | _ => a end. Lemma change_abs_prop : stable_atom change_abs_func. Proof. intros [l v u|x y l u|x y l u|v w|v w|f x|f x] ; try easy. destruct v as [x|x|x y|x y|o x|o x y|x|x|x|x|x|x|f m x] ; try easy. destruct o ; try easy. split. now intros (_,H). split. replace (convert_expr (reFloat2 0 0)) with R0. apply Rabs_pos. apply eq_sym, Rmult_0_l. exact H. Qed. Definition change_le_func a := match a with | raLe x y => match get_float2_bound x with | reFloat2 _ _ as x => raBound (Some x) y None | _ => match get_float2_bound y with | reFloat2 _ _ as y => raBound None x (Some y) | _ => a end end | _ => a end. Lemma change_le_prop : stable_atom change_le_func. Proof. intros [l v u|x y l u|x y l u|v w|v w|f x|f x] ; try easy. simpl. assert (Hv := get_float2_bound_correct v). assert (Hw := get_float2_bound_correct w). destruct (get_float2_bound v) as [x|x|x y|x y|o x|o x y|x|x|x|x|x|x|f m x] ; destruct (get_float2_bound w) as [x'|x'|x' y'|x' y'|o' x'|o' x' y'|x'|x'|x'|x'|x'|x'|f' m' x'] ; try easy ; try (now rewrite <- Hw) ; now rewrite <- Hv. Qed. Lemma change_lin_aux: forall x y b, (0 <= b /\ Rabs x <= b * Rabs y)%R <-> (exists eps, -b <= eps <= b /\ x = y * eps)%R. Proof. intros x y b. split. - intros [H1 H2]. destruct (Req_dec y 0) as [Hy|Hy]. + exists 0%R. split. lra. rewrite Rmult_0_r. apply Rabs_eq_R0. apply Rle_antisym. 2: apply Rabs_pos. apply Rle_trans with (1 := H2). rewrite Hy, Rabs_R0, Rmult_0_r. apply Rle_refl. + exists (x / y)%R. split. 2: now field. apply Rabs_def2b. apply Rmult_le_reg_l with (Rabs y). now apply Rabs_pos_lt. rewrite <- Rabs_mult. replace (y * (x / y))%R with x by now field. now rewrite Rmult_comm. - intros [eps [H1 H2]]. split. lra. rewrite H2, Rabs_mult, Rmult_comm. apply Rmult_le_compat_r. apply Rabs_pos. now apply Rabs_le. Qed. Definition change_lin_func a := match a with | raLe (reUnary uoAbs er) (reBinary boMul u (reUnary uoAbs ex)) => match get_float2_bound u with | reFloat2 (Zpos m) e => raLin er ex (reFloat2 (Zneg m) e) (reFloat2 (Zpos m) e) | _ => a end | _ => a end. Lemma change_lin_prop : stable_atom change_lin_func. Proof. unfold change_lin_func. intros [l v u|x y l u|x y l u|v w|v w|f x|f x] ; try easy. destruct v as [x|x|x y|x y|o x|o x y|x|x|x|x|x|x|f m x] ; try easy. destruct o ; try easy. destruct w as [u|u|u v|u v|o u|o u v|u|u|u|u|u|u|f m u] ; try easy. destruct o ; try easy. destruct v as [v|v|v w|v w|o v|o v w|v|v|v|v|v|v|f m v] ; try easy. destruct o ; try easy. assert (H := get_float2_bound_correct u). destruct (get_float2_bound u) as [u1|u1|m e|u1 u2|o u1|o u1 u2|u1|u1|u1|u1|u1|u1|f u1] ; try easy. destruct m as [|m|m] ; try easy. simpl in H |- *. change (Float2 (Zneg m) e) with (Gappa_dyadic.Fopp2 (Float2 (Zpos m) e)). rewrite Gappa_dyadic.Fopp2_correct. rewrite H. split ; intro H'. now apply <- change_lin_aux. apply -> change_lin_aux. split. rewrite <- H. now apply (Gappa_dyadic.Fpos0_correct (Float2 (Zpos m) e)). exact H'. Qed. Lemma change_rel_aux: forall x y b, (0 <= b /\ Rabs (x - y) <= b * Rabs y)%R <-> (exists eps, -b <= eps <= b /\ x = y * (1 + eps))%R. Proof. intros x y b. generalize (change_lin_aux (x - y) y b). intros [H1 H2]. split ; intros H. - specialize (H1 H). destruct H1 as [eps [H3 H4]]. exists eps. apply (conj H3). rewrite Rmult_plus_distr_l, <- H4. ring. - apply H2. destruct H as [eps [H3 H4]]. exists eps. apply (conj H3). rewrite H4. ring. Qed. Definition change_rel_func a := match a with | raLe (reUnary uoAbs (reBinary boSub er ex)) (reBinary boMul u (reUnary uoAbs ex')) => if RExpr_beq ex ex' then match get_float2_bound u with | reFloat2 (Zpos m) e => raRel er ex (reFloat2 (Zneg m) e) (reFloat2 (Zpos m) e) | _ => a end else a | _ => a end. Lemma change_rel_prop : stable_atom change_rel_func. Proof. unfold change_rel_func. intros [l v u|x y l u|x y l u|v w|v w|f x|f x] ; try easy. destruct v as [x|x|x y|x y|o x|o x y|x|x|x|x|x|x|f m x] ; try easy. destruct o ; try easy. destruct x as [x|x|x y|x y|o x|o x y|x|x|x|x|x|x|f m x] ; try easy. destruct o ; try easy. destruct w as [u|u|u v|u v|o u|o u v|u|u|u|u|u|u|f m u] ; try easy. destruct o ; try easy. destruct v as [v|v|v w|v w|o v|o v w|v|v|v|v|v|v|f m v] ; try easy. destruct o ; try easy. case_eq (RExpr_beq y v) ; try easy. intros Hb. rewrite <- internal_RExpr_dec_bl with (1 := Hb). assert (H := get_float2_bound_correct u). destruct (get_float2_bound u) as [u1|u1|m e|u1 u2|o u1|o u1 u2|u1|u1|u1|u1|u1|u1|f u1] ; try easy. destruct m as [|m|m] ; try easy. simpl in H |- *. change (Float2 (Zneg m) e) with (Gappa_dyadic.Fopp2 (Float2 (Zpos m) e)). rewrite Gappa_dyadic.Fopp2_correct. rewrite H. split ; intro H'. now apply <- change_rel_aux. apply -> change_rel_aux. split. rewrite <- H. now apply (Gappa_dyadic.Fpos0_correct (Float2 (Zpos m) e)). exact H'. Qed. Definition change_format_func (pos : bool) a := let a' := match a with | raGeneric (fFixed _ as fmt) x => if pos then raEq x (reRound fmt mRndNE x) else raEq (reRound fmt mRndNE x) x | raGeneric (fFloat _ (Zpos _) as fmt) x => if pos then raEq x (reRound fmt mRndNE x) else raEq (reRound fmt mRndNE x) x | raGeneric (fFloatx (Zpos _) as fmt) x => if pos then raEq x (reRound fmt mRndNE x) else raEq (reRound fmt mRndNE x) x | raFormat (fFixed _ as fmt) x => if pos then raEq x (reRound fmt mRndNE x) else raEq (reRound fmt mRndNE x) x | raFormat (fFloat _ (Zpos _) as fmt) x => if pos then raEq x (reRound fmt mRndNE x) else raEq (reRound fmt mRndNE x) x | raFormat (fFloatx (Zpos _) as fmt) x => if pos then raEq x (reRound fmt mRndNE x) else raEq (reRound fmt mRndNE x) x | _ => a end in if pos then rtAtom a' else rtNot (rtAtom a'). Lemma change_format_prop : stable_atom_tree change_format_func. Proof. unfold change_format_func. intros [l v u|x y l u|x y l u|v w|v w|[em|em [|p|p]|[|p|p]] x|[em|em [|p|p]|[|p|p]] x] pos ; try (case pos ; easy) ; simpl ; intros H. destruct pos ; simpl. apply sym_eq, round_generic. apply valid_rnd_N. exact H. contradict H. rewrite <- H. apply generic_format_round. apply FIX_exp_valid. apply valid_rnd_N. destruct pos ; simpl. apply sym_eq, round_generic. apply valid_rnd_N. exact H. contradict H. rewrite <- H. apply generic_format_round. now apply FLT_exp_valid. apply valid_rnd_N. destruct pos ; simpl. apply sym_eq, round_generic. apply valid_rnd_N. exact H. contradict H. rewrite <- H. apply generic_format_round. now apply FLX_exp_valid. apply valid_rnd_N. destruct pos ; simpl. apply sym_eq, round_generic. apply valid_rnd_N. now apply generic_format_FIX. contradict H. rewrite <- H. apply FIX_format_generic. apply generic_format_round. apply FIX_exp_valid. apply valid_rnd_N. destruct pos ; simpl. apply sym_eq, round_generic. apply valid_rnd_N. apply generic_format_FLT. exact H. contradict H. rewrite <- H. apply FLT_format_generic. easy. apply generic_format_round. now apply FLT_exp_valid. apply valid_rnd_N. destruct pos ; simpl. apply sym_eq, round_generic. apply valid_rnd_N. apply generic_format_FLX. exact H. contradict H. rewrite <- H. apply FLX_format_generic. easy. apply generic_format_round. now apply FLX_exp_valid. apply valid_rnd_N. Qed. Definition remove_unknown_func (pos : bool) a := match a with | raBound l _ u => match l with | Some (reFloat2 _ _) | None => match u with | Some (reFloat2 _ _) | None => if pos then rtAtom a else rtNot (rtAtom a) | _ => rtTrue end | _ => rtTrue end | raRel _ _ (reFloat2 _ _) (reFloat2 _ _) => if pos then rtAtom a else rtNot (rtAtom a) | raLin _ _ (reFloat2 _ _) (reFloat2 _ _) => if pos then rtAtom a else rtNot (rtAtom a) | raEq _ _ => if pos then rtAtom a else rtNot (rtAtom a) | _ => rtTrue end. Lemma remove_unknown_prop : stable_atom_tree remove_unknown_func. Proof. intros [[l|] v [u|]|x y l u|x y l u|v w|v w|f x|f x] pos ; try (case pos ; easy) ; simpl ; intros H. destruct l as [xl|xl|xl yl|xl yl|ol xl|ol xl yl|xl|xl|xl|xl|xl|xl|fl xl] ; try easy. destruct u as [xu|xu|xu yu|xu yu|ou xu|ou xu yu|xu|xu|xu|xu|xu|xu|fu xu] ; try easy. now destruct pos. destruct l as [l|l|l l'|l l'|o l|o l l'|l|l|l|l|l|l|f l] ; try easy. now destruct pos. destruct u as [u|u|u u'|u u'|o u|o u u'|u|u|u|u|u|u|f u] ; try easy. now destruct pos. destruct l as [l|l|l l'|l l'|o l|o l l'|l|l|l|l|l|l|f l] ; try easy. destruct u as [u|u|u u'|u u'|o u|o u u'|u|u|u|u|u|u|f u] ; try easy. now destruct pos. destruct l as [l|l|l l'|l l'|o l|o l l'|l|l|l|l|l|l|f l] ; try easy. destruct u as [u|u|u u'|u u'|o u|o u u'|u|u|u|u|u|u|f u] ; try easy. now destruct pos. Qed. End Convert. Inductive Transform := | trAtom (f : RAtom -> RAtom) : (forall uv, stable_atom uv f) -> Transform | trLeaf (f : bool -> RAtom -> RTree) : (forall uv, stable_atom_tree uv f) -> Transform | trBound (f : RExpr -> RExpr) : (forall uv, stable_expr uv f) -> Transform | trExpr (f : RExpr -> RExpr) : (forall uv, stable_expr uv f) -> Transform | trTree (f : RTree -> RTree) : (forall uv t, convert_tree uv t -> convert_tree uv (f t)) -> Transform. Definition transform_once tr t := match tr with | trAtom f _ => transform_tree_atom f t | trLeaf f _ => transform_tree_atom' f t | trBound f _ => transform_tree_atom (transform_atom_bound (transform_expr f)) t | trExpr f _ => transform_tree_atom (transform_atom_expr (transform_expr f)) t | trTree f _ => f t end. Theorem transform_once_correct : forall uv tr t, convert_tree uv t -> convert_tree uv (transform_once tr t). Proof. intros uv [f Hf|f Hf|f Hf|f Hf|f Hf] t Ht ; simpl. now apply transform_tree_atom_correct. now apply transform_tree_atom'_correct. apply transform_tree_atom_correct with (2 := Ht). now apply transform_atom_bound_correct. apply transform_tree_atom_correct with (2 := Ht). now apply transform_atom_expr_correct. now apply Hf. Qed. Definition transform := fold_left (fun v t => transform_once t v). Theorem transform_correct : forall l uv t, convert_tree uv t -> convert_tree uv (transform l t). Proof. intros l uv t Ht. rewrite <- (rev_involutive l). induction (rev l) as [|h l' Hl] ; simpl. easy. unfold transform. rewrite fold_left_app. simpl. apply transform_once_correct. apply Hl. Qed. Definition trans := trAtom change_rel_func change_rel_prop :: trAtom change_lin_func change_lin_prop :: trAtom change_abs_func change_abs_prop :: trBound remove_inv_func remove_inv_prop :: trBound gen_float_func gen_float_prop :: trBound clean_pow_func clean_pow_prop :: trBound merge_float2_func merge_float2_prop :: trExpr remove_inv_func remove_inv_prop :: trExpr gen_float_func gen_float_prop :: trExpr clean_pow_func clean_pow_prop :: trAtom change_le_func change_le_prop :: trLeaf change_format_func change_format_prop :: trLeaf remove_unknown_func remove_unknown_prop :: trTree simplify_tree simplify_tree_correct :: nil. Theorem prepare_goal : forall uv t, convert_tree uv (rtNot (transform trans (normalize_tree t false))) -> convert_tree uv t. Proof. intros uv t. change (not (convert_tree uv (transform trans (normalize_tree t false))) -> convert_tree uv t). intros H. destruct (decidable_tree uv t) as [H'|H']. easy. contradict H. apply transform_correct. now apply normalize_tree_correct. Qed. End Gappa_Private. Import Gappa_Private. Declare ML Module "coq-gappa.tactic". Ltac gappa_prepare := intros ; fold rndNE rndNA in * ; gappa_quote ; let convert_apply t := match goal with | |- (convert_tree ?uv ?g) => t uv g end in let rec generalize_all m n l := match l with | List.nil => clear | List.cons ?h ?q => match n with | O => generalize h ; clear ; intro ; convert_apply ltac:(fun uv _ => generalize_all (S m) (S m) uv) | S ?n => generalize_all m n q end end in convert_apply ltac:(fun uv _ => generalize_all O O uv) ; convert_apply ltac:(fun uv g => refine (prepare_goal uv g _)) ; convert_apply ltac:(fun uv g => let g := eval vm_compute in g in change (convert_tree uv g)). Ltac gappa := abstract (gappa_prepare ; gappa_internal). coq-gappalib-coq-1.10.0-df59b68361b1efbd697b17c40f7fae4a35991c44/src/Gappa_tree.v000066400000000000000000000352371517666064600255260ustar00rootroot00000000000000From Coq Require Import Reals List Bool. Require Import Gappa_common. Local Notation index := nat (only parsing). Definition realmap := list R. Definition get rm n := nth n rm R0. Fixpoint index_eq x y := match x, y with | O, O => true | S x, S y => index_eq x y | _, _ => false end. Lemma index_eq_correct : forall x y, index_eq x y = true -> x = y. Proof. induction x. now destruct y. destruct y. easy. intro H. now rewrite (IHx y). Qed. Inductive pos_atom := | Abnd : index -> FF -> pos_atom | Aleq : index -> float2 -> pos_atom | Ageq : index -> float2 -> pos_atom | Aabs : index -> FF -> pos_atom | Arel : index -> index -> FF -> pos_atom | Alin : index -> index -> FF -> pos_atom | Afix : index -> Z -> pos_atom | Aflt : index -> positive -> pos_atom | Anzr : index -> pos_atom | Aeql : index -> index -> pos_atom. Definition interp_pos_atom a rm := match a with | Abnd x xi => BND (get rm x) xi | Aleq x xu => Rle (get rm x) xu | Ageq x xl => Rle xl (get rm x) | Aabs x xi => ABS (get rm x) xi | Arel x y xi => REL (get rm x) (get rm y) xi | Alin x y xi => LIN (get rm x) (get rm y) xi | Afix x xc => FIX (get rm x) xc | Aflt x xc => FLT (get rm x) xc | Anzr x => NZR (get rm x) | Aeql x y => get rm x = get rm y end. Definition interp_atom a (pos : bool) rm := let p := interp_pos_atom a rm in if pos then p else not p. Inductive tree := | Ttrue | Tfalse | Ttree : bool -> tree -> tree -> tree | Tatom : bool -> pos_atom -> tree. Fixpoint interp_tree t rm := match t with | Ttrue => True | Tfalse => False | Ttree cnj l r => (if cnj then and else or) (interp_tree l rm) (interp_tree r rm) | Tatom pos a => interp_atom a pos rm end. Inductive atom_relation := | ARimply | ARcontradict | ARunknown. Definition subset (xi yi : FF) := if Fle2 (lower yi) (lower xi) then Fle2 (upper xi) (upper yi) else false. Definition empty_inter (xi yi : FF) := if Flt2 (upper xi) (lower yi) then true else Flt2 (upper yi) (lower xi). Definition compare xi yi := if subset xi yi then ARimply else if empty_inter xi yi then ARcontradict else ARunknown. Lemma compare_correct : forall xi yi, forall x, BND x xi -> match compare xi yi with | ARimply => BND x yi | ARcontradict => not (BND x yi) | ARunknown => True end. Proof. intros (xl,xu) (yl,yu) x ; unfold compare, subset, empty_inter, BND ; simpl. intros (Hx1,Hx2). generalize (Fle2_correct yl xl) (Fle2_correct xu yu) (Flt2_correct xu yl) (Flt2_correct yu xl). case Fle2. case Fle2. intros H1 H2 _ _. split. apply Rle_trans with (2 := Hx1). now apply H1. apply Rle_trans with (1 := Hx2). now apply H2. case Flt2. intros H1 _ H2 _. apply False_rec. apply (Rlt_irrefl yl). apply Rle_lt_trans with (1 := H1 eq_refl). apply Rle_lt_trans with (1 := Hx1). apply Rle_lt_trans with (1 := Hx2). now apply H2. case Flt2 ; try easy. intros _ _ _ H. intros (_,Hy). apply (Rlt_irrefl x). apply Rle_lt_trans with (1 := Hy). apply Rlt_le_trans with (2 := Hx1). now apply H. case Flt2. intros _ _ H _. intros (Hy,_). apply (Rlt_irrefl x). apply Rle_lt_trans with (1 := Hx2). apply Rlt_le_trans with (2 := Hy). now apply H. case Flt2 ; try easy. intros _ _ _ H. intros (_,Hy). apply (Rlt_irrefl x). apply Rle_lt_trans with (1 := Hy). apply Rlt_le_trans with (2 := Hx1). now apply H. Qed. Definition relate' (p : pos_atom) (q : pos_atom) : atom_relation := match p, q with | Abnd px pi, Abnd qx qi => if index_eq px qx then compare pi qi else ARunknown | Abnd px pi, Aleq qx qu => if index_eq px qx then if Fle2 (upper pi) qu then ARimply else if Flt2 qu (lower pi) then ARcontradict else ARunknown else ARunknown | Abnd px pi, Ageq qx ql => if index_eq px qx then if Fle2 ql (lower pi) then ARimply else if Flt2 (upper pi) ql then ARcontradict else ARunknown else ARunknown | Aabs px pi, Aabs qx qi => if index_eq px qx then if Fpos0 (lower qi) then compare pi qi else ARunknown else ARunknown | Arel px py pi, Arel qx qy qi => if index_eq px qx then if index_eq py qy then if subset pi qi then ARimply else ARunknown else ARunknown else ARunknown | Alin px py pi, Alin qx qy qi => if index_eq px qx then if index_eq py qy then if subset pi qi then ARimply else ARunknown else ARunknown else ARunknown | Afix px pc, Afix qx qc => if index_eq px qx then if Zle_bool qc pc then ARimply else ARunknown else ARunknown | Aflt px pc, Aflt qx qc => if index_eq px qx then if Zle_bool (Zpos pc) (Zpos qc) then ARimply else ARunknown else ARunknown | Anzr px, Anzr qx => if index_eq px qx then ARimply else ARunknown | Aeql px py, Aeql qx qy => if index_eq px qx then if index_eq py qy then ARimply else ARunknown else ARunknown | Aleq px pu, Abnd qx qi => if index_eq px qx then if Flt2 pu (lower qi) then ARcontradict else ARunknown else ARunknown | Aleq px pu, Aleq qx qu => if index_eq px qx then if Fle2 pu qu then ARimply else ARunknown else ARunknown | Aleq px pu, Ageq qx ql => if index_eq px qx then if Flt2 pu ql then ARcontradict else ARunknown else ARunknown | Ageq px pl, Abnd qx qi => if index_eq px qx then if Flt2 (upper qi) pl then ARcontradict else ARunknown else ARunknown | Ageq px pl, Aleq qx qu => if index_eq px qx then if Flt2 qu pl then ARcontradict else ARunknown else ARunknown | Ageq px pl, Ageq qx ql => if index_eq px qx then if Fle2 ql pl then ARimply else ARunknown else ARunknown | _, _ => ARunknown end. Theorem relate'_correct : forall p q rm, interp_pos_atom p rm -> match relate' p q with | ARimply => interp_pos_atom q rm | ARcontradict => not (interp_pos_atom q rm) | ARunknown => True end. Proof. intros [px pi|px pu|px pl|px pi|px py pi|px py pi|px pc|px pc|px|px py] [qx qi|qx qu|qx ql|qx qi|qx qy qi|qx qy qi|qx qc|qx qc|qx|qx qy] rm Hp ; try exact I ; simpl. (* Abnd, Abnd *) generalize (index_eq_correct px qx). case index_eq ; try easy. intros H. rewrite H in Hp by easy. generalize (compare_correct pi qi _ Hp). now case compare. (* Abnd, Aleq *) generalize (index_eq_correct px qx). case index_eq ; try easy. intros H. rewrite H in Hp by easy. generalize (Fle2_correct (upper pi) qu). case Fle2. intros H'. apply Rle_trans with (1 := proj2 Hp). now apply H'. intros _. generalize (Flt2_correct qu (lower pi)). case Flt2 ; try easy. intros H' H''. apply Rlt_not_le with (1 := H' eq_refl). now apply Rle_trans with (1 := proj1 Hp). (* Abnd, Ageq *) generalize (index_eq_correct px qx). case index_eq ; try easy. intros H. rewrite H in Hp by easy. generalize (Fle2_correct ql (lower pi)). case Fle2. intros H'. apply Rle_trans with (2 := proj1 Hp). now apply H'. intros _. generalize (Flt2_correct (upper pi) ql). case Flt2 ; try easy. intros H' H''. apply Rlt_not_le with (1 := H' eq_refl). now apply Rle_trans with (2 := proj2 Hp). (* Aleq, Abnd *) generalize (index_eq_correct px qx). case index_eq ; try easy. intros H. rewrite H in Hp by easy. generalize (Flt2_correct pu (lower qi)). case Flt2 ; try easy. intros H' H''. apply (Rlt_not_le _ _ (H' eq_refl)). apply Rle_trans with (2 := Hp). apply H''. (* Aleq, Aleq *) generalize (index_eq_correct px qx). case index_eq ; try easy. intros H. rewrite H in Hp by easy. generalize (Fle2_correct pu qu). case Fle2 ; try easy. intros H'. apply Rle_trans with (1 := Hp). now apply H'. (* Aleq, Ageq *) generalize (index_eq_correct px qx). case index_eq ; try easy. intros H. rewrite H in Hp by easy. generalize (Flt2_correct pu ql). case Flt2 ; try easy. intros H'. apply Rlt_not_le. apply Rle_lt_trans with (1 := Hp). now apply H'. (* Ageq, Abnd *) generalize (index_eq_correct px qx). case index_eq ; try easy. intros H. rewrite H in Hp by easy. generalize (Flt2_correct (upper qi) pl). case Flt2 ; try easy. intros H' H''. apply (Rlt_not_le _ _ (H' eq_refl)). apply Rle_trans with (1 := Hp). apply H''. (* Ageq, Aleq *) generalize (index_eq_correct px qx). case index_eq ; try easy. intros H. rewrite H in Hp by easy. generalize (Flt2_correct qu pl). case Flt2 ; try easy. intros H'. apply Rlt_not_le. apply Rlt_le_trans with (2 := Hp). now apply H'. (* Ageq, Abnd *) generalize (index_eq_correct px qx). case index_eq ; try easy. intros H. rewrite H in Hp by easy. generalize (Fle2_correct ql pl). case Fle2 ; try easy. intros H'. apply Rle_trans with (2 := Hp). now apply H'. (* Aabs, Abs *) generalize (index_eq_correct px qx). case index_eq ; try easy. intros H. rewrite H in Hp by easy. generalize (Fpos0_correct (lower qi)). case Fpos0 ; try easy. intros H'. specialize (H' eq_refl). generalize (compare_correct pi qi _ (proj2 Hp)). case compare ; try easy. try now split. intros H''. contradict H''. apply H''. (* Arel, Arel *) generalize (index_eq_correct px qx). case index_eq ; try easy. intros H. rewrite H in Hp by easy. clear H. generalize (index_eq_correct py qy). case index_eq ; try easy. intros H. rewrite H in Hp by easy. clear H. unfold interp_pos_atom in Hp. unfold subset. generalize (Fle2_correct (lower qi) (lower pi)). case Fle2 ; try easy. intros Hl. generalize (Fle2_correct (upper pi) (upper qi)). case Fle2 ; try easy. intros Hu. destruct Hp as (e,(He,Hp)). exists e. split. split. now apply Rle_trans with (1 := Hl eq_refl). now apply Rle_trans with (2 := Hu eq_refl). exact Hp. (* Alin, Alin *) generalize (index_eq_correct px qx). case index_eq ; try easy. intros H. rewrite H in Hp by easy. clear H. generalize (index_eq_correct py qy). case index_eq ; try easy. intros H. rewrite H in Hp by easy. clear H. unfold interp_pos_atom in Hp. unfold subset. generalize (Fle2_correct (lower qi) (lower pi)). case Fle2 ; try easy. intros Hl. generalize (Fle2_correct (upper pi) (upper qi)). case Fle2 ; try easy. intros Hu. destruct Hp as (e,(He,Hp)). exists e. split. split. now apply Rle_trans with (1 := Hl eq_refl). now apply Rle_trans with (2 := Hu eq_refl). exact Hp. (* Afix, Afix *) generalize (index_eq_correct px qx). case index_eq ; try easy. intros H. rewrite H in Hp by easy. clear H. generalize (Zle_cases qc pc). case (Zle_bool qc pc) ; try easy. intros H. destruct Hp as ((m,e),(Hm,He)). exists (Float2 m e). split. exact Hm. now apply Z.le_trans with (1 := H). (* Aflt, Aflt *) generalize (index_eq_correct px qx). case index_eq ; try easy. intros H. rewrite H in Hp by easy. clear H. generalize (Zle_cases (Zpos pc) (Zpos qc)). case Zle_bool ; try easy. intros H. destruct Hp as ((m,e),(Hm,He)). exists (Float2 m e). split. exact Hm. apply Z.lt_le_trans with (1 := He). apply le_IZR. change (IZR (Zpower radix2 (Zpos pc)) <= IZR (Zpower radix2 (Zpos qc)))%R. apply IZR_le. now apply Zpower_le. (* Anzr, Anzr *) generalize (index_eq_correct px qx). case index_eq ; try easy. intros H. now rewrite <- H. (* Aeql, Aeql *) generalize (index_eq_correct px qx). case index_eq ; try easy. intros H. rewrite H in Hp by easy. clear H. generalize (index_eq_correct py qy). case index_eq ; try easy. intros H. now rewrite <- H. Qed. Definition relate (p : pos_atom) (q : pos_atom) (qpos : bool) : atom_relation := if qpos then relate' p q else match relate' p q with | ARimply => ARcontradict | ARcontradict => ARimply | ARunknown => ARunknown end. Theorem relate_correct : forall p q qpos rm, interp_pos_atom p rm -> match relate p q qpos with | ARimply => interp_atom q qpos rm | ARcontradict => not (interp_atom q qpos rm) | ARunknown => True end. Proof. intros p q qpos rm Hp. unfold relate. generalize (relate'_correct p q rm Hp). now destruct relate' ; case qpos. Qed. Fixpoint simplify' t p := match t with | Ttrue => Ttrue | Tfalse => Tfalse | Ttree cnj l r => match simplify' l p, cnj, simplify' r p with | Ttrue, true, r => r | Ttrue, false, _ => Ttrue | Tfalse, true, _ => Tfalse | Tfalse, false, r => r | l, true, Ttrue => l | _, true, Tfalse => Tfalse | l, true, r => Ttree true l r | _, false, Ttrue => Ttrue | l, false, Tfalse => l | l, false, r => Ttree false l r end | Tatom pos a => match relate p a pos with | ARimply => Ttrue | ARcontradict => Tfalse | ARunknown => t end end. Lemma iff_True : forall P : Prop, P <-> (P <-> True). Proof. split. now split. intros (_,H). now apply H. Qed. Lemma iff_False : forall P : Prop, not P <-> (P <-> False). Proof. split. now split. now intros (H,_). Qed. Theorem simplify'_correct : forall t p rm, interp_pos_atom p rm -> (interp_tree t rm <-> interp_tree (simplify' t p) rm). Proof. intros t p rm Hp. induction t as [| |cnj l Hl r Hr|a pos] ; try easy. simpl. destruct (simplify' l p) as [| |cnj' l' r'|a' pos']. simpl in Hl. apply <- iff_True in Hl. case cnj. intuition. apply -> iff_True. now left. apply <- iff_False in Hl. case cnj. apply -> iff_False. now intros (H,_). intuition. destruct (simplify' r p) as [| |cnj'' l'' r''|a'' pos'']. apply <- iff_True in Hr. case cnj. intuition. apply -> iff_True. now right. apply <- iff_False in Hr. case cnj. apply -> iff_False. now intros (_,H). intuition. replace (interp_tree (if cnj then Ttree true (Ttree cnj' l' r') (Ttree cnj'' l'' r'') else Ttree false (Ttree cnj' l' r') (Ttree cnj'' l'' r'')) rm) with ((if cnj then and else or) (interp_tree (Ttree cnj' l' r') rm) (interp_tree (Ttree cnj'' l'' r'') rm)) by now case cnj. case cnj ; intuition. replace (interp_tree (if cnj then Ttree true (Ttree cnj' l' r') (Tatom a'' pos'') else Ttree false (Ttree cnj' l' r') (Tatom a'' pos'')) rm) with ((if cnj then and else or) (interp_tree (Ttree cnj' l' r') rm) (interp_tree (Tatom a'' pos'') rm)) by now case cnj. case cnj ; intuition. destruct (simplify' r p) as [| |cnj'' l'' r''|a'' pos'']. apply <- iff_True in Hr. case cnj. intuition. apply -> iff_True. now right. apply <- iff_False in Hr. case cnj. apply -> iff_False. now intros (_,H). intuition. replace (interp_tree (if cnj then Ttree true (Tatom a' pos') (Ttree cnj'' l'' r'') else Ttree false (Tatom a' pos') (Ttree cnj'' l'' r'')) rm) with ((if cnj then and else or) (interp_tree (Tatom a' pos') rm) (interp_tree (Ttree cnj'' l'' r'') rm)) by now case cnj. case cnj ; intuition. replace (interp_tree (if cnj then Ttree true (Tatom a' pos') (Tatom a'' pos'') else Ttree false (Tatom a' pos') (Tatom a'' pos'')) rm) with ((if cnj then and else or) (interp_tree (Tatom a' pos') rm) (interp_tree (Tatom a'' pos'') rm)) by now case cnj. case cnj ; intuition. (* *) simpl. generalize (relate_correct p pos a rm Hp). case relate ; intros H. now apply -> iff_True. now apply -> iff_False. easy. Qed. Scheme Equality for positive. Scheme Equality for Z. Scheme Equality for nat. Scheme Equality for float2. Scheme Equality for FF. Scheme Equality for pos_atom. Scheme Equality for tree. Theorem simplify : forall t t' p rm, interp_pos_atom p rm -> interp_tree t rm -> tree_beq (simplify' t p) t' = true -> interp_tree t' rm. Proof. intros t t' p rm Hp Ht Hs. rewrite <- (internal_tree_dec_bl _ _ Hs). generalize (proj1 (simplify'_correct t p rm Hp)). intuition. Qed. coq-gappalib-coq-1.10.0-df59b68361b1efbd697b17c40f7fae4a35991c44/src/Gappa_user.v000066400000000000000000000065321517666064600255410ustar00rootroot00000000000000From Flocq Require Import Defs. Require Import Gappa_common. Require Import Gappa_pred_bnd. Definition rewrite_ne_helper (xi : FF) (n : Z) := Flt2 (upper xi) (Float2 n 0) || Flt2 (Float2 n 0) (lower xi). Lemma rewrite_ne : forall x xi n, BND x xi -> rewrite_ne_helper xi n = true -> (x <> Float1 n)%R. Proof. intros x xi n Hx Hb. rewrite <- (Rmult_1_r (Float1 n)). change (x <> F2R (Float radix2 n 0)). unfold Float1. destruct (orb_prop _ _ Hb) as [H|H] ; clear Hb. generalize (Flt2_correct _ _ H). clear H. intro H. apply Rlt_not_eq. apply Rle_lt_trans with (1 := proj2 Hx). exact H. generalize (Flt2_correct _ _ H). clear H. intro H. apply Rgt_not_eq. unfold Rgt. apply Rlt_le_trans with (2 := proj1 Hx). exact H. Qed. Definition rewrite_lt_helper (xi : FF) (n : Z) := Flt2 (upper xi) (Float2 n 0). Lemma rewrite_lt : forall x xi n, BND x xi -> rewrite_lt_helper xi n = true -> (x < Float1 n)%R. Proof. intros x xi n Hx Hb. rewrite <- (Rmult_1_r (Float1 n)). generalize (Flt2_correct _ _ Hb). clear Hb. intro H. apply Rle_lt_trans with (1 := proj2 Hx). exact H. Qed. Definition rewrite_le_helper (xi : FF) (n : Z) := Fle2 (upper xi) (Float2 n 0). Lemma rewrite_le : forall x xi n, BND x xi -> rewrite_le_helper xi n = true -> (x <= Float1 n)%R. Proof. intros x xi n Hx Hb. rewrite <- (Rmult_1_r (Float1 n)). generalize (Fle2_correct _ _ Hb). clear Hb. intro H. apply Rle_trans with (1 := proj2 Hx). exact H. Qed. Definition rewrite_gt_helper (xi : FF) (n : Z) := Flt2 (Float2 n 0) (lower xi). Lemma rewrite_gt : forall x xi n, BND x xi -> rewrite_gt_helper xi n = true -> (x > Float1 n)%R. Proof. intros x xi n Hx Hb. rewrite <- (Rmult_1_r (Float1 n)). generalize (Flt2_correct _ _ Hb). clear Hb. intro H. unfold Rgt. apply Rlt_le_trans with (2 := proj1 Hx). exact H. Qed. Definition rewrite_ge_helper (xi : FF) (n : Z) := Fle2 (Float2 n 0) (lower xi). Lemma rewrite_ge : forall x xi n, BND x xi -> rewrite_ge_helper xi n = true -> (x >= Float1 n)%R. Proof. intros x xi n Hx Hb. rewrite <- (Rmult_1_r (Float1 n)). generalize (Fle2_correct _ _ Hb). clear Hb. intro H. apply Rle_ge. apply Rle_trans with (2 := proj1 Hx). exact H. Qed. Definition rewrite_lt0_helper (xi : FF) := Fneg (upper xi). Lemma rewrite_lt0 : forall x : R, forall xi : FF, BND x xi -> rewrite_lt0_helper xi = true -> (x < 0)%R. Proof. intros x xi Hx Hb. generalize (Fneg_correct _ Hb). clear Hb. intro H. apply Rle_lt_trans with (1 := proj2 Hx). exact H. Qed. Definition rewrite_le0_helper (xi : FF) := Fneg0 (upper xi). Lemma rewrite_le0 : forall x : R, forall xi : FF, BND x xi -> rewrite_le0_helper xi = true -> (x <= 0)%R. Proof. intros x xi Hx Hb. generalize (Fneg0_correct _ Hb). clear Hb. intro H. apply Rle_trans with (1 := proj2 Hx). exact H. Qed. Definition rewrite_gt0_helper (xi : FF) := Fpos (lower xi). Lemma rewrite_gt0 : forall x : R, forall xi : FF, BND x xi -> rewrite_gt0_helper xi = true -> (x > 0)%R. Proof. intros x xi Hx Hb. generalize (Fpos_correct _ Hb). clear Hb. intro H. unfold Rgt. apply Rlt_le_trans with (2 := proj1 Hx). exact H. Qed. Definition rewrite_ge0_helper (xi : FF) := Fpos0 (lower xi). Lemma rewrite_ge0 : forall x : R, forall xi : FF, BND x xi -> rewrite_ge0_helper xi = true -> (x >= 0)%R. Proof. intros x xi Hx Hb. generalize (Fpos0_correct _ Hb). clear Hb. intro H. apply Rle_ge. apply Rle_trans with (2 := proj1 Hx). exact H. Qed. coq-gappalib-coq-1.10.0-df59b68361b1efbd697b17c40f7fae4a35991c44/src/META.coq-gappa000066400000000000000000000003771517666064600256050ustar00rootroot00000000000000package "tactic" ( directory = "." description = "Coq Gappa" requires = "coq-core.plugins.ltac" archive(byte) = "gappatac.cma" archive(native) = "gappatac.cmxa" plugin(byte) = "gappatac.cma" plugin(native) = "gappatac.cmxs" ) directory = "."coq-gappalib-coq-1.10.0-df59b68361b1efbd697b17c40f7fae4a35991c44/src/gappatac.c000066400000000000000000000742431517666064600252140ustar00rootroot00000000000000(********************************************************) (* Copyright 2008 Jean-Christophe Filliâtre *) (* Copyright 2008-2020 Guillaume Melquiond *) (* *) (* This file is distributed under the terms of the *) (* GNU Lesser General Public License Version 3 or later *) (********************************************************) open Format open Util open Pp open Term open Tacmach open Gramlib open Names open Coqlib open Libnames open Evarutil let global_env = ref Environ.empty_env let global_evd = ref Evd.empty let existential_type evd ex = Evd.existential_type evd ex open Vars open Globnames open CErrors #if COQVERSION >= 81900 let generalize = Generalize.generalize #else let generalize = Tactics.generalize #endif open Ltac_plugin open EConstr let is_global = isRefX #if COQVERSION >= 81800 let is_global t1 t2 = is_global !global_env t1 t2 #else let is_global t1 t2 = is_global !global_evd t1 t2 #endif let kind_of_term t = kind !global_evd t #if COQVERSION >= 81800 let decompose_app t = decompose_app_list !global_evd t #else let decompose_app t = decompose_app !global_evd t #endif #if COQVERSION >= 81800 let decompose_lam = decompose_lambda #endif let closed0 t = Vars.closed0 !global_evd t let eq_constr t1 t2 = eq_constr !global_evd t1 t2 let pr_constr t = Printer.pr_econstr_env !global_env !global_evd t let constr_of_global gr = UnivGen.constr_of_monomorphic_global (Global.env ()) gr let binder_name = Context.binder_name #if COQVERSION >= 81700 let refine_no_check = Tactics.exact_no_check #else let refine_no_check t = Logic.refiner ~check:false (EConstr.Unsafe.to_constr t) #endif let map_constr f t = EConstr.map !global_evd f t let convert_concl_no_check a = Tactics.convert_concl ~cast:false ~check:false a Constr.DEFAULTcast let parse_entry e s = Pcoq.Entry.parse e (Pcoq.Parsable.make s) let find_reference dir = let dp = DirPath.make (List.rev_map Id.of_string dir) in fun s -> lazy ( let sp = Libnames.make_path dp (Id.of_string s) in let qid = Libnames.qualid_of_path sp in let r = Smartlocate.global_with_alias qid in of_constr (constr_of_global r)) let is_global c t = eq_constr (Lazy.force c) t let constr_of_global f = Lazy.force f let __coq_plugin_name = "coq-gappa.tactic" #if COQVERSION >= 90200 #else let _ = Mltop.add_known_module __coq_plugin_name #endif let debug = ref false open Big_int_Z (* 1. gappa syntax trees and output *) module Constant = struct type t = { mantissa : big_int; base : int; exp : big_int } let create (b, m, e) = { mantissa = m; base = b; exp = e } let of_int x = { mantissa = x; base = 1; exp = zero_big_int } let print fmt x = match x.base with | 1 -> fprintf fmt "%s" (string_of_big_int x.mantissa) | 2 -> fprintf fmt "%sb%s" (string_of_big_int x.mantissa) (string_of_big_int x.exp) | 10 -> fprintf fmt "%se%s" (string_of_big_int x.mantissa) (string_of_big_int x.exp) | _ -> assert false end type binop = Bminus | Bplus | Bmult | Bdiv type unop = Usqrt | Uabs | Uopp type rounding_mode = string type term = | Tconst of Constant.t | Tvar of string | Tbinop of binop * term * term | Tunop of unop * term | Tround of rounding_mode * term type atom = | Ain of term * Constant.t option * Constant.t option | Arel of term * term * Constant.t * Constant.t | Alin of term * term * Constant.t * Constant.t | Aeq of term * term type pred = | Patom of atom | Pand of pred * pred | Por of pred * pred | Pnot of pred (** {1 Symbols needed by the tactics} *) let coq_Logic = find_reference ["Coq"; "Init"; "Logic"] let coq_False = coq_Logic "False" let coq_True = coq_Logic "True" let coq_eq = coq_Logic "eq" let coq_eq_refl = coq_Logic "eq_refl" let coq_not = coq_Logic "not" let coq_and = coq_Logic "and" let coq_or = coq_Logic "or" let coq_ref_Datatypes = find_reference ["Coq"; "Init"; "Datatypes"] let coq_Some = coq_ref_Datatypes "Some" let coq_cons = coq_ref_Datatypes "cons" let coq_nil = coq_ref_Datatypes "nil" let coq_bool = coq_ref_Datatypes "bool" let coq_true = coq_ref_Datatypes "true" 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_R = coq_ref_Rdefinitions "R" let coq_R0 = coq_ref_Rdefinitions "R0" let coq_R1 = coq_ref_Rdefinitions "R1" let coq_Rle = coq_ref_Rdefinitions "Rle" let coq_Rplus = coq_ref_Rdefinitions "Rplus" let coq_Ropp = coq_ref_Rdefinitions "Ropp" let coq_Rminus = coq_ref_Rdefinitions "Rminus" let coq_Rmult = coq_ref_Rdefinitions "Rmult" let coq_Rinv = coq_ref_Rdefinitions "Rinv" let coq_Rdiv = coq_ref_Rdefinitions "Rdiv" let coq_IZR = coq_ref_Rdefinitions "IZR" let coq_Rabs = find_reference ["Coq"; "Reals"; "Rbasic_fun"] "Rabs" let coq_sqrt = find_reference ["Coq"; "Reals"; "R_sqrt"] "sqrt" let coq_powerRZ = find_reference ["Coq"; "Reals"; "Rfunctions"] "powerRZ" let coq_radix_val = find_reference ["Flocq"; "Core"; "Zaux"] "radix_val" let coq_ref_Gappa_Private = find_reference ["Gappa"; "Gappa_tactic"; "Gappa_Private"] let coq_convert_tree = coq_ref_Gappa_Private "convert_tree" let coq_RTree = coq_ref_Gappa_Private "RTree" let coq_rtTrue = coq_ref_Gappa_Private "rtTrue" let coq_rtFalse = coq_ref_Gappa_Private "rtFalse" let coq_rtAtom = coq_ref_Gappa_Private "rtAtom" let coq_rtNot = coq_ref_Gappa_Private "rtNot" let coq_rtAnd = coq_ref_Gappa_Private "rtAnd" let coq_rtOr = coq_ref_Gappa_Private "rtOr" let coq_rtImpl = coq_ref_Gappa_Private "rtImpl" let coq_RAtom = coq_ref_Gappa_Private "RAtom" let coq_raBound = coq_ref_Gappa_Private "raBound" let coq_raRel = coq_ref_Gappa_Private "raRel" let coq_raLin = coq_ref_Gappa_Private "raLin" let coq_raEq = coq_ref_Gappa_Private "raEq" let coq_raLe = coq_ref_Gappa_Private "raLe" let coq_raGeneric = coq_ref_Gappa_Private "raGeneric" let coq_raFormat = coq_ref_Gappa_Private "raFormat" let coq_RExpr = coq_ref_Gappa_Private "RExpr" let coq_reUnknown = coq_ref_Gappa_Private "reUnknown" let coq_reFloat2 = coq_ref_Gappa_Private "reFloat2" let coq_reFloat10 = coq_ref_Gappa_Private "reFloat10" let coq_reBpow2 = coq_ref_Gappa_Private "reBpow2" let coq_reBpow10 = coq_ref_Gappa_Private "reBpow10" let coq_rePow2 = coq_ref_Gappa_Private "rePow2" let coq_rePow10 = coq_ref_Gappa_Private "rePow10" let coq_reInteger = coq_ref_Gappa_Private "reInteger" let coq_reBinary = coq_ref_Gappa_Private "reBinary" let coq_reUnary = coq_ref_Gappa_Private "reUnary" let coq_reRound = coq_ref_Gappa_Private "reRound" let coq_mRndDN = coq_ref_Gappa_Private "mRndDN" let coq_mRndNA = coq_ref_Gappa_Private "mRndNA" let coq_mRndNE = coq_ref_Gappa_Private "mRndNE" let coq_mRndUP = coq_ref_Gappa_Private "mRndUP" let coq_mRndZR = coq_ref_Gappa_Private "mRndZR" let coq_mRndAW = coq_ref_Gappa_Private "mRndAW" let coq_fFloat = coq_ref_Gappa_Private "fFloat" let coq_fFloatx = coq_ref_Gappa_Private "fFloatx" let coq_fFixed = coq_ref_Gappa_Private "fFixed" let coq_boAdd = coq_ref_Gappa_Private "boAdd" let coq_boSub = coq_ref_Gappa_Private "boSub" let coq_boMul = coq_ref_Gappa_Private "boMul" let coq_boDiv = coq_ref_Gappa_Private "boDiv" let coq_uoAbs = coq_ref_Gappa_Private "uoAbs" let coq_uoNeg = coq_ref_Gappa_Private "uoNeg" let coq_uoInv = coq_ref_Gappa_Private "uoInv" let coq_uoSqrt = coq_ref_Gappa_Private "uoSqrt" let coq_ref_Fcore_Raux = find_reference ["Flocq"; "Core"; "Raux"] let coq_bpow = coq_ref_Fcore_Raux "bpow" let coq_rndDN = coq_ref_Fcore_Raux "Zfloor" let coq_rndUP = coq_ref_Fcore_Raux "Zceil" let coq_rndZR = coq_ref_Fcore_Raux "Ztrunc" let coq_rndAW = coq_ref_Fcore_Raux "Zaway" let coq_ref_Gappa_round_def = find_reference ["Gappa"; "Gappa_round_def"] let coq_rndNE = coq_ref_Gappa_round_def "rndNE" let coq_rndNA = coq_ref_Gappa_round_def "rndNA" let coq_ref_Fcore_generic_fmt = find_reference ["Flocq"; "Core"; "Generic_fmt"] let coq_round = coq_ref_Fcore_generic_fmt "round" let coq_generic_format = coq_ref_Fcore_generic_fmt "generic_format" let coq_ref_Fcore_FLT = find_reference ["Flocq"; "Core"; "FLT"] let coq_FLT_format = coq_ref_Fcore_FLT "FLT_format" let coq_FLT_exp = coq_ref_Fcore_FLT "FLT_exp" let coq_ref_Fcore_FLX = find_reference ["Flocq"; "Core"; "FLX"] let coq_FLX_format = coq_ref_Fcore_FLX "FLX_format" let coq_FLX_exp = coq_ref_Fcore_FLX "FLX_exp" let coq_ref_Fcore_FIX = find_reference ["Flocq"; "Core"; "FIX"] let coq_FIX_format = coq_ref_Fcore_FIX "FIX_format" let coq_FIX_exp = coq_ref_Fcore_FIX "FIX_exp" (** {1 Reification from Coq user goal: the [gappa_quote] tactic} *) exception NotGappa of constr let var_terms = Hashtbl.create 17 let var_names = Hashtbl.create 17 let var_list = ref [] let mkLApp f v = mkApp (constr_of_global f, v) let mkList t = List.fold_left (fun acc v -> mkLApp coq_cons [|t; v; acc|]) (mkLApp coq_nil [|t|]) let rec mk_pos n = if n = 1 then constr_of_global coq_xH else if n land 1 = 0 then mkLApp coq_xO [|mk_pos (n / 2)|] else mkLApp coq_xI [|mk_pos (n / 2)|] type int_type = It_1 | It_2 | It_even of constr | It_int of constr | It_none of constr type int_type_partial = Itp_1 | Itp_2 | Itp_even of int | Itp_int of int (** translate a closed Coq term [p:positive] into [int] *) let rec tr_positive p = match kind_of_term p with | Constr.Construct _ when is_global coq_xH p -> 1 | Constr.App (f, [|a|]) when is_global coq_xI f -> 2 * (tr_positive a) + 1 | Constr.App (f, [|a|]) when is_global coq_xO f -> 2 * (tr_positive a) | Constr.Cast (p, _, _) -> tr_positive p | _ -> raise (NotGappa p) (** translate a closed Coq term [t:Z] into [int] *) let rec tr_arith_constant t = match kind_of_term t with | Constr.Construct _ when is_global coq_Z0 t -> 0 | Constr.App (f, [|a|]) when is_global coq_Zpos f -> tr_positive a | Constr.App (f, [|a|]) when is_global coq_Zneg f -> - (tr_positive a) | Constr.Cast (t, _, _) -> tr_arith_constant t | _ -> raise (NotGappa t) (** translate a closed Coq term [t:R] into [int] *) let tr_real_constant t = let rec aux t = match decompose_app t with | c, [] when is_global coq_R1 c -> Itp_1 | c, [a] when is_global coq_IZR c -> Itp_int (tr_arith_constant a) | c, [a;b] -> if is_global coq_Rplus c then if aux a = Itp_1 then match aux b with | Itp_1 -> Itp_2 | Itp_2 -> Itp_int 3 | Itp_even n -> Itp_int (2 * n + 1) | _ -> raise (NotGappa t) else raise (NotGappa t) else if is_global coq_Rmult c then if aux a = Itp_2 then match aux b with | Itp_2 -> Itp_even 2 | Itp_even n -> Itp_even (2 * n) | Itp_int n -> Itp_even n | _ -> raise (NotGappa t) else raise (NotGappa t) else raise (NotGappa t) | _ -> raise (NotGappa t) in match aux t with | Itp_1 -> 1 | Itp_2 -> 2 | Itp_even n -> 2 * n | Itp_int n -> n (** create a term of type [Z] from a quoted real (supposedly constant) *) let plain_of_int = let wrap t = mkLApp coq_reInteger [|mkLApp coq_Zpos [|t|]|] in function | It_1 -> wrap (constr_of_global coq_xH) | It_2 -> wrap (mkLApp coq_xO [|constr_of_global coq_xH|]) | It_even n -> wrap (mkLApp coq_xO [|n|]) | It_int n -> wrap n | It_none n -> n (** reify a format [Z->Z] *) let qt_fmt f = match decompose_app f with | c, [e;p] when is_global coq_FLT_exp c -> mkLApp coq_fFloat [|e;p|] | c, [p] when is_global coq_FLX_exp c -> mkLApp coq_fFloatx [|p|] | c, [e] when is_global coq_FIX_exp c -> mkLApp coq_fFixed [|e|] | _ -> raise (NotGappa f) (** reify a Coq term [t:R] *) let rec qt_term t = plain_of_int (qt_Rint t) and qt_Rint t = match decompose_app t with | c, [] when is_global coq_R1 c -> It_1 | c, [a;b] -> if is_global coq_Rplus c then let a = qt_Rint a in if a = It_1 then match qt_Rint b with | It_1 -> It_2 | It_2 -> It_int (mkLApp coq_xI [|constr_of_global coq_xH|]) | It_even n -> It_int (mkLApp coq_xI [|n|]) | (It_int n) as b -> It_none (mkLApp coq_reBinary [|constr_of_global coq_boAdd; plain_of_int a; plain_of_int b|]) | It_none e -> It_none (mkLApp coq_reBinary [|constr_of_global coq_boAdd; plain_of_int a; e|]) else It_none (mkLApp coq_reBinary [|constr_of_global coq_boAdd; plain_of_int a; qt_term b|]) else if is_global coq_Rmult c then let a = qt_Rint a in if a = It_2 then match qt_Rint b with | It_2 -> It_even (mkLApp coq_xO [|constr_of_global coq_xH|]) | It_even n -> It_even (mkLApp coq_xO [|n|]) | It_int n -> It_even n | _ as b -> It_none (mkLApp coq_reBinary [|constr_of_global coq_boMul; plain_of_int a; plain_of_int b|]) else It_none (mkLApp coq_reBinary [|constr_of_global coq_boMul; plain_of_int a; qt_term b|]) else It_none (qt_no_Rint t) | _ -> It_none (qt_no_Rint t) and qt_no_Rint t = try match decompose_app t with | c, [] when is_global coq_R0 c -> mkLApp coq_reInteger [|constr_of_global coq_Z0|] | c, [a] when is_global coq_IZR c -> ignore (tr_arith_constant a); mkLApp coq_reInteger [|a|] | c, [a] -> begin let gen_un f = mkLApp coq_reUnary [|constr_of_global f; qt_term a|] in if is_global coq_Ropp c then gen_un coq_uoNeg else if is_global coq_Rinv c then gen_un coq_uoInv else if is_global coq_Rabs c then gen_un coq_uoAbs else if is_global coq_sqrt c then gen_un coq_uoSqrt else raise (NotGappa t) end | c, [_;v;w;b] when is_global coq_round c -> (* TODO: check radix *) let mode = match decompose_app w with | c, [] when is_global coq_rndDN c -> coq_mRndDN | c, [] when is_global coq_rndNA c -> coq_mRndNA | c, [] when is_global coq_rndNE c -> coq_mRndNE | c, [] when is_global coq_rndUP c -> coq_mRndUP | c, [] when is_global coq_rndZR c -> coq_mRndZR | c, [] when is_global coq_rndAW c -> coq_mRndAW | _ -> raise (NotGappa w) in mkLApp coq_reRound [|qt_fmt v; constr_of_global mode; qt_term b|] | c, [a;b] -> let gen_bin f = mkLApp coq_reBinary [|constr_of_global f; qt_term a; qt_term b|] in if is_global coq_Rminus c then gen_bin coq_boSub else if is_global coq_Rdiv c then gen_bin coq_boDiv else if is_global coq_powerRZ c then let p = match tr_real_constant a with | 2 -> coq_rePow2 | 10 -> coq_rePow10 | _ -> raise (NotGappa t) in mkLApp p [|(ignore (tr_arith_constant b); b)|] else if is_global coq_bpow c then let p = match tr_arith_constant (Tacred.compute !global_env !global_evd (mkLApp coq_radix_val [|a|])) with | 2 -> coq_reBpow2 | 10 -> coq_reBpow10 | _ -> raise (NotGappa t) in mkLApp p [|(ignore (tr_arith_constant b); b)|] else raise (NotGappa t) | _ -> raise (NotGappa t) with NotGappa _ -> try Hashtbl.find var_terms t with Not_found -> let e = mkLApp coq_reUnknown [|mk_pos (Hashtbl.length var_terms + 1)|] in Hashtbl.add var_terms t e; var_list := t :: !var_list; e (** reify a Coq term [p:Prop] *) let rec qt_pred p = match kind_of_term p with | Constr.Prod (_,a,b) -> if not (closed0 b) then raise (NotGappa p); mkLApp coq_rtImpl [|qt_pred a; qt_pred b|] | _ -> match decompose_app p with | c, [] when is_global coq_True c -> constr_of_global coq_rtTrue | c, [] when is_global coq_False c -> constr_of_global coq_rtFalse | c, [a] when is_global coq_not c -> mkLApp coq_rtNot [|qt_pred a|] | c, [a;b] when is_global coq_and c -> begin match decompose_app a, decompose_app b with | (c1, [a1;b1]), (c2, [a2;b2]) when is_global coq_Rle c1 && is_global coq_Rle c2 && eq_constr b1 a2 -> mkLApp coq_rtAtom [|mkLApp coq_raBound [|mkLApp coq_Some [|constr_of_global coq_RExpr; qt_term a1|]; qt_term b1; mkLApp coq_Some [|constr_of_global coq_RExpr; qt_term b2|]|]|] | _ -> mkLApp coq_rtAnd [|qt_pred a; qt_pred b|] end | c, [a;b] when is_global coq_or c -> mkLApp coq_rtOr [|qt_pred a; qt_pred b|] | c, [a;b] when is_global coq_Rle c -> mkLApp coq_rtAtom [|mkLApp coq_raLe [|qt_term a; qt_term b|]|] | c, [t;a;b] when is_global coq_eq c && is_global coq_R t -> mkLApp coq_rtAtom [|mkLApp coq_raEq [|qt_term a; qt_term b|]|] | c, [_;e;x] when is_global coq_FIX_format c -> let fmt = mkLApp coq_fFixed [|e|] in mkLApp coq_rtAtom [|mkLApp coq_raFormat [|fmt; qt_term x|]|] | c, [_;e;p;x] when is_global coq_FLT_format c -> let fmt = mkLApp coq_fFloat [|e;p|] in mkLApp coq_rtAtom [|mkLApp coq_raFormat [|fmt; qt_term x|]|] | c, [_;p;x] when is_global coq_FLX_format c -> let fmt = mkLApp coq_fFloatx [|p|] in mkLApp coq_rtAtom [|mkLApp coq_raFormat [|fmt; qt_term x|]|] | c, [_;f;x] when is_global coq_generic_format c -> mkLApp coq_rtAtom [|mkLApp coq_raGeneric [|qt_fmt f; qt_term x|]|] | _ -> raise (NotGappa p) (** reify hypotheses *) let qt_hyps = List.fold_left (fun acc (n, h) -> let old_var_list = !var_list in try (n, qt_pred h) :: acc with NotGappa _ -> while not (!var_list == old_var_list) do match !var_list with | h :: q -> Hashtbl.remove var_terms h; var_list := q | [] -> assert false done; acc) [] (** the [gappa_quote] tactic *) let gappa_quote = Proofview.Goal.enter begin fun gl -> try global_env := pf_env gl; global_evd := project gl; let l = qt_hyps (pf_hyps_types gl) in let _R = constr_of_global coq_R in let g = List.fold_left (fun acc (_, h) -> mkLApp coq_rtImpl [|h; acc|]) (qt_pred (pf_concl gl)) l in let uv = mkList _R !var_list in let e = mkLApp coq_convert_tree [|uv; g|] in (*Pp.msgerrnl (pr_constr e);*) Hashtbl.clear var_terms; var_list := []; Tacticals.tclTHEN (Tacticals.tclTHEN (generalize (List.map (fun (n, _) -> mkVar n) (List.rev l))) (Tactics.keep [])) (convert_concl_no_check e) with | NotGappa t -> Hashtbl.clear var_terms; var_list := []; anomaly ~label:"gappa_quote" (Pp.str "something wrong happened with term " ++ pr_constr t) end (** {1 Goal parsing, call to Gappa, and proof building: the [gappa_internal] tactic} *) (** translate a closed Coq term [p:positive] into [bigint] *) let rec tr_bigpositive p = match kind_of_term p with | Constr.Construct _ when is_global coq_xH p -> unit_big_int | Constr.App (f, [|a|]) when is_global coq_xI f -> add_int_big_int 1 (shift_left_big_int (tr_bigpositive a) 1) | Constr.App (f, [|a|]) when is_global coq_xO f -> shift_left_big_int (tr_bigpositive a) 1 | Constr.Cast (p, _, _) -> tr_bigpositive p | _ -> raise (NotGappa p) (** translate a closed Coq term [t:Z] into [bigint] *) let rec tr_arith_bigconstant t = match kind_of_term t with | Constr.Construct _ when is_global coq_Z0 t -> zero_big_int | Constr.App (f, [|a|]) when is_global coq_Zpos f -> tr_bigpositive a | Constr.App (f, [|a|]) when is_global coq_Zneg f -> minus_big_int (tr_bigpositive a) | Constr.Cast (t, _, _) -> tr_arith_bigconstant t | _ -> raise (NotGappa t) let tr_float b m e = (b, tr_arith_bigconstant m, tr_arith_bigconstant e) let tr_binop c = match decompose_app c with | c, [] when is_global coq_boAdd c -> Bplus | c, [] when is_global coq_boSub c -> Bminus | c, [] when is_global coq_boMul c -> Bmult | c, [] when is_global coq_boDiv c -> Bdiv | _ -> assert false let tr_unop c = match decompose_app c with | c, [] when is_global coq_uoNeg c -> Uopp | c, [] when is_global coq_uoSqrt c -> Usqrt | c, [] when is_global coq_uoAbs c -> Uabs | _ -> raise (NotGappa c) (** translate a Coq term [c:RExpr] into [term] *) let rec tr_term uv t = match decompose_app t with | c, [a] when is_global coq_reUnknown c -> let n = tr_positive a - 1 in if (n < Array.length uv) then Tvar uv.(n) else raise (NotGappa t) | c, [a; b] when is_global coq_reFloat2 c -> Tconst (Constant.create (tr_float 2 a b)) | c, [a; b] when is_global coq_reFloat10 c -> Tconst (Constant.create (tr_float 10 a b)) | c, [a] when is_global coq_reInteger c -> Tconst (Constant.create (1, tr_arith_bigconstant a, zero_big_int)) | c, [op;a;b] when is_global coq_reBinary c -> Tbinop (tr_binop op, tr_term uv a, tr_term uv b) | c, [op;a] when is_global coq_reUnary c -> Tunop (tr_unop op, tr_term uv a) | c, [fmt;mode;a] when is_global coq_reRound c -> let mode = match decompose_app mode with | c, [] when is_global coq_mRndDN c -> "dn" | c, [] when is_global coq_mRndNA c -> "na" | c, [] when is_global coq_mRndNE c -> "ne" | c, [] when is_global coq_mRndUP c -> "up" | c, [] when is_global coq_mRndZR c -> "zr" | _ -> raise (NotGappa mode) in let rnd = match decompose_app fmt with | c, [e;p] when is_global coq_fFloat c -> let e = tr_arith_constant e in let p = tr_arith_constant p in sprintf "float<%d,%d,%s>" p e mode | c, [p] when is_global coq_fFloatx c -> let p = tr_arith_constant p in sprintf "float<%d,%s>" p mode | c, [e] when is_global coq_fFixed c -> let e = tr_arith_constant e in sprintf "fixed<%d,%s>" e mode | _ -> raise (NotGappa fmt) in Tround (rnd, tr_term uv a) | _ -> raise (NotGappa t) let tr_const c = match tr_term [||] c with | Tconst v -> v | _ -> raise (NotGappa c) (** translate a Coq term [t:RAtom] into [pred] *) let tr_atom uv t = match decompose_app t with | c, [l;e;u] when is_global coq_raBound c -> let l = match decompose_app l with | (_, [_;l]) -> Some (tr_const l) | (_, [_]) -> None | _ -> assert false in let u = match decompose_app u with | (_, [_;u]) -> Some (tr_const u) | (_, [_]) -> None | _ -> assert false in if l = None && u = None then raise (NotGappa t); Ain (tr_term uv e, l, u) | c, [er;ex;l;u] when is_global coq_raRel c -> Arel (tr_term uv er, tr_term uv ex, tr_const l, tr_const u) | c, [er;ex;l;u] when is_global coq_raLin c -> Alin (tr_term uv er, tr_term uv ex, tr_const l, tr_const u) | c, [er;ex] when is_global coq_raEq c -> Aeq (tr_term uv er, tr_term uv ex) | _ -> raise (NotGappa t) (** translate a Coq term [t:RTree] into [pred] *) let rec tr_pred uv t = match decompose_app t with | c, [a] when is_global coq_rtAtom c -> Patom (tr_atom uv a) | c, [a] when is_global coq_rtNot c -> Pnot (tr_pred uv a) | c, [a;b] when is_global coq_rtAnd c -> Pand (tr_pred uv a, tr_pred uv b) | c, [a;b] when is_global coq_rtOr c -> Por (tr_pred uv a, tr_pred uv b) | _ -> raise (NotGappa t) let tr_var c = match kind_of_term c with | Constr.Var x -> let s = Id.to_string x in let l = String.length s in let s = Bytes.init l (fun i -> let c = s.[i] in if ('A' <= c && c <= 'Z') || ('a' <= c && c <= 'z') || ('0' <= c && c <= '9') || c == '_' then c else '_'; ) in if Bytes.get s 0 = '_' then Bytes.set s 0 'G'; let b = Buffer.create l in Buffer.add_bytes b s; begin try while true do ignore (Hashtbl.find var_names (Buffer.contents b)); Buffer.add_string b "_"; done; assert false with Not_found -> let s = Buffer.contents b in Hashtbl.add var_names s c; s end | _ -> raise (NotGappa c) (** translate a Coq term [t:list] into [list] by applying [f] to each element *) let tr_list f = let rec aux c = match decompose_app c with | _, [_;h;t] -> f h :: aux t | _, [_] -> [] | _ -> raise (NotGappa c) in aux (** translate a Coq term [c] of kind [convert_tree ...] *) let tr_goal c = match decompose_app c with | c, [uv;e] when is_global coq_convert_tree c -> let uv = Array.of_list (tr_list tr_var uv) in tr_pred uv e | _ -> raise (NotGappa c) (** print a Gappa term *) let rec print_term fmt = function | Tconst c -> Constant.print fmt c | Tvar s -> pp_print_string fmt s | Tbinop (op, t1, t2) -> let op = match op with | Bplus -> "+" | Bminus -> "-" | Bmult -> "*" | Bdiv -> "/" in fprintf fmt "(%a %s %a)" print_term t1 op print_term t2 | Tunop (Uabs, t) -> fprintf fmt "|%a|" print_term t | Tunop (Uopp | Usqrt as op, t) -> let s = match op with | Uopp -> "-" | Usqrt -> "sqrt" | _ -> assert false in fprintf fmt "(%s(%a))" s print_term t | Tround (m, t) -> fprintf fmt "(%s(%a))" m print_term t (** print a Gappa predicate *) let print_atom fmt = function | Ain (t, Some c1, Some c2) -> fprintf fmt "%a in [%a, %a]" print_term t Constant.print c1 Constant.print c2 | Ain (t, Some c, None) -> fprintf fmt "%a >= %a" print_term t Constant.print c | Ain (t, None, Some c) -> fprintf fmt "%a <= %a" print_term t Constant.print c | Ain (_, None, None) -> assert false | Arel (t1, t2, c1, c2) -> fprintf fmt "%a -/ %a in [%a,%a]" print_term t1 print_term t2 Constant.print c1 Constant.print c2 | Alin (t1, t2, c1, c2) -> fprintf fmt "%a // %a in [%a,%a]" print_term t1 print_term t2 Constant.print c1 Constant.print c2 | Aeq (t1, t2) -> fprintf fmt "%a = %a" print_term t1 print_term t2 let rec print_pred fmt = function | Patom a -> print_atom fmt a | Pnot t -> fprintf fmt "not (%a)" print_pred t | Pand (t1, t2) -> fprintf fmt "(%a) /\\ (%a)" print_pred t1 print_pred t2 | Por (t1, t2) -> fprintf fmt "(%a) \\/ (%a)" print_pred t1 print_pred t2 let temp_file f = if !debug then f else Filename.temp_file f "" let remove_file f = if not !debug then try Sys.remove f with _ -> () exception GappaFailed of string (** print a Gappa goal from [p] and call Gappa on it, build a Coq term by calling [c_of_s] *) let call_gappa c_of_s p = let gappa_in = temp_file "gappa_inp" in let c = open_out gappa_in in let fmt = formatter_of_out_channel c in fprintf fmt "@[{ %a }@]@." print_pred p; close_out c; let gappa_out = temp_file "gappa_out" in let gappa_err = temp_file "gappa_err" in let cmd = sprintf "gappa -Bcoq-lambda %s > %s 2> %s" gappa_in gappa_out gappa_err in let out = Sys.command cmd in if out <> 0 then begin let c = open_in_bin gappa_err in let len = in_channel_length c in let buf = Bytes.create len in ignore (input c buf 0 len); close_in c; raise (GappaFailed (Bytes.unsafe_to_string buf)) end; remove_file gappa_err; let cin = open_in gappa_out in let constr = c_of_s (Stream.of_channel cin) in close_in cin; remove_file gappa_in; remove_file gappa_out; constr (** execute [f] after disabling globalization *) let no_glob f = Dumpglob.pause (); let res = try f () with e -> Dumpglob.continue (); raise e in Dumpglob.continue (); res (** replace all evars of any type [ty] by [(refl_equal true : ty)] *) let evars_to_vmcast env emap c = let emap = nf_evar_map emap in let change_exist evar = let ty = Reductionops.nf_betaiota env emap (existential_type emap evar) in mkCast (mkLApp coq_eq_refl [|constr_of_global coq_bool; constr_of_global coq_true|], Constr.VMcast, ty) in let rec replace c = match kind_of_term c with | Constr.Evar ev -> change_exist ev | _ -> map_constr replace c in replace c let constr_of_stream env evd s = no_glob (fun () -> Constrintern.interp_open_constr env evd (parse_entry Pcoq.Constr.constr s)) let var_name = function | Name id -> let s = Id.to_string id in let s = String.sub s 1 (String.length s - 1) in Hashtbl.find var_names s | Anonymous -> assert false (** apply to the proof term [c] all the needed variables from the context and as many metas as needed to match hypotheses *) let build_proof_term evd c = let bl, _ = decompose_lam evd c in List.fold_right (fun (x,t) pf -> mkApp (pf, [| var_name (binder_name x) |])) bl c (** the [gappa_internal] tactic *) let gappa_internal = Proofview.Goal.enter begin fun gl -> try global_env := pf_env gl; global_evd := project gl; Hashtbl.clear var_names; List.iter (let dummy = mkVar (Id.of_string "dummy") in fun n -> Hashtbl.add var_names n dummy) ["fma"; "sqrt"; "not"; "in"; "float"; "fixed"; "int"; "homogen80x"; "homogen80x_init"; "float80x"; "add_rel"; "sub_rel"; "mul_rel"; "fma_rel" ]; let g = tr_goal (pf_concl gl) in let (emap, pf) = call_gappa (constr_of_stream !global_env !global_evd) g in global_evd := emap; let pf = evars_to_vmcast !global_env emap pf in let pf = build_proof_term emap pf in refine_no_check pf with | NotGappa t -> user_err ~hdr:"gappa_internal" (Pp.str "translation to Gappa failed (not a reduced constant?): " ++ pr_constr t) | GappaFailed s -> user_err ~hdr:"gappa_internal" (Pp.str "execution of Gappa failed:" ++ Pp.fnl () ++ Pp.str s) end let () = Tacentries.tactic_extend __coq_plugin_name "gappatac_gappa_internal" ~level:0 [Tacentries.TyML (Tacentries.TyIdent ("gappa_internal", Tacentries.TyNil), (fun ist -> gappa_internal))] let () = Tacentries.tactic_extend __coq_plugin_name "gappatac_gappa_quote" ~level:0 [Tacentries.TyML (Tacentries.TyIdent ("gappa_quote", Tacentries.TyNil), (fun ist -> gappa_quote))] coq-gappalib-coq-1.10.0-df59b68361b1efbd697b17c40f7fae4a35991c44/testsuite/000077500000000000000000000000001517666064600245205ustar00rootroot00000000000000coq-gappalib-coq-1.10.0-df59b68361b1efbd697b17c40f7fae4a35991c44/testsuite/bug-20091016.v000066400000000000000000000004521517666064600263650ustar00rootroot00000000000000Require Import Reals. Require Import Flocq.Core.Core. Require Import Gappa_tactic. Definition rnd := rounding_float rndNE 53 (-1074). Goal forall a_ b_ a b : R, a = rnd a_ -> b = rnd b_ -> (Rabs (rnd (a + b) - (a + b)) <= powerRZ 2 (-50) * Rabs (a + b))%R. Proof. unfold rnd. gappa. Qed. coq-gappalib-coq-1.10.0-df59b68361b1efbd697b17c40f7fae4a35991c44/testsuite/bug-20091019.v000066400000000000000000000003651517666064600263730ustar00rootroot00000000000000Require Import Reals. Require Import Gappa_tactic. Goal forall a1 a2 b1 b2 : R, (Rabs (a1 - a2) <= 1/16 * Rabs a2)%R -> (Rabs (b1 - b2) <= 1/16 * Rabs b2)%R -> (Rabs (a1 * b1 - a2 * b2) <= 33/256 * Rabs (a2 * b2))%R. Proof. gappa. Qed. coq-gappalib-coq-1.10.0-df59b68361b1efbd697b17c40f7fae4a35991c44/testsuite/bug-20121219.v000066400000000000000000000027731517666064600263740ustar00rootroot00000000000000Require Import Reals. Require Import Flocq.Core.Core. Require Import Gappa_tactic. Coercion F2R : float >-> R. Lemma glo : forall x_0 y : float radix2, (Rabs (x_0 * y) <= 22471164185778948846616314884862809170224712236778832159178760144716584475687620391588559665300942002640014234983924169707348721101802077811605928829934265547220986678108185659537777450155761764931635369010625721104768835292807860184239138817603404645418813835573287279993405742309964538104419541203028017152)%R -> (Rabs (round radix2 (FLT_exp (-1074) 26) ZnearestE x_0 * round radix2 (FLT_exp (-1074) 26) ZnearestE y - x_0 * y) <= powerRZ 2 2000)%R -> (1 <= Rabs x_0 <= 334846439745708537796382827831250565800439003657979252326171996365734703476542538279124493379904955664873335286735358382870982901778848138624518049209330462622955242963257218294408581408199098183686068192282702343236935664606211486223923248314908216080349889927704442739388432239144512088662677127168)%R -> (1 <= Rabs y <= 334846439745708537796382827831250565800439003657979252326171996365734703476542538279124493379904955664873335286735358382870982901778848138624518049209330462622955242963257218294408581408199098183686068192282702343236935664606211486223923248314908216080349889927704442739388432239144512088662677127168)%R -> (Rabs (round radix2 (FLT_exp (-1074) 53) ZnearestE (round radix2 (FLT_exp (-1074) 26) ZnearestE x_0 * round radix2 (FLT_exp (-1074) 26) ZnearestE y)) <= 9007199254740991 * powerRZ 2 971)%R. Proof. intros. gappa. Qed. coq-gappalib-coq-1.10.0-df59b68361b1efbd697b17c40f7fae4a35991c44/testsuite/bug-20130220.v000066400000000000000000000002701517666064600263520ustar00rootroot00000000000000Require Import Gappa_tactic. Lemma truc : forall b, (Rabs b <= 1 -> Rabs b <= 2)%R. Proof. gappa. Qed. Lemma truc' : forall b, (Rabs b <= 1 -> Rabs b <= 1)%R. Proof. gappa. Qed. coq-gappalib-coq-1.10.0-df59b68361b1efbd697b17c40f7fae4a35991c44/testsuite/bug-20130708.v000066400000000000000000000001471517666064600263700ustar00rootroot00000000000000Require Import Gappa_tactic. Goal forall x, (x <= 4 /\ 3 <= x -> x - 2 <= 2)%R. intros. gappa. Qed. coq-gappalib-coq-1.10.0-df59b68361b1efbd697b17c40f7fae4a35991c44/testsuite/bug-20130713.v000066400000000000000000000001501517666064600263560ustar00rootroot00000000000000Require Import Gappa_tactic. Goal forall x, (1/4 <= x <= 3/4 -> 0 <= x /\ not (1 <= x))%R. gappa. Qed. coq-gappalib-coq-1.10.0-df59b68361b1efbd697b17c40f7fae4a35991c44/testsuite/bug-20130716.v000066400000000000000000000002711517666064600263650ustar00rootroot00000000000000Require Import Gappa_tactic. Open Scope R_scope. Goal forall fma x' x_ éà, fma = 1 -> x' = 2 -> x_ = 3 -> éà = 4 -> 10 <= fma + x' + x_ + éà <= 10. Proof. gappa. Qed. coq-gappalib-coq-1.10.0-df59b68361b1efbd697b17c40f7fae4a35991c44/testsuite/bug-20180309.v000066400000000000000000000001351517666064600263670ustar00rootroot00000000000000Require Import Reals Gappa_tactic. Goal forall x, (IZR x - IZR x = 0)%R. Proof. gappa. Qed. coq-gappalib-coq-1.10.0-df59b68361b1efbd697b17c40f7fae4a35991c44/testsuite/bug-20200404.v000066400000000000000000000007351517666064600263620ustar00rootroot00000000000000Require Import Reals Gappa_tactic. Open Scope R_scope. Goal -10 <= 12 * powerRZ 2 (-3) <= 10. Proof. gappa. Qed. Goal -10 <= 150 * powerRZ 10 (-2) <= 10. Proof. gappa. Qed. Goal -10 <= 24 * powerRZ 2 (-3) <= 10. Proof. gappa. Qed. Goal -10 <= 0 * powerRZ 10 (-3) <= 10. Proof. gappa. Qed. Goal -10 <= -300 * powerRZ 10 (-2) <= 10. Proof. gappa. Qed. Goal -10 <= -12 * powerRZ 2 (-3) <= 10. Proof. gappa. Qed. Goal -10 <= -150 * powerRZ 10 (-2) <= 10. Proof. gappa. Qed. coq-gappalib-coq-1.10.0-df59b68361b1efbd697b17c40f7fae4a35991c44/testsuite/dichotomy-20130707.v000066400000000000000000000002041517666064600276030ustar00rootroot00000000000000Require Import Gappa_tactic. Goal forall x, (1 <= x <= 5 -> 3 <= x <= 4 \/ 4 <= x <= 6 \/ 1 <= x + 1 <= 4)%R. Proof. gappa. Qed. coq-gappalib-coq-1.10.0-df59b68361b1efbd697b17c40f7fae4a35991c44/testsuite/dichotomy-20160718.v000066400000000000000000000006551517666064600276220ustar00rootroot00000000000000Require Import Reals Gappa_tactic. Open Scope R_scope. Goal forall a b, not (0 <= a) /\ 1 <= a -> 1 <= b <= 1. Proof. intros a b. gappa. Qed. Goal forall a b, -2 <= a -> (not (0 <= a) -> 1 <= b <= 1) -> (-1 <= a -> 1 <= b <= 1) -> 1 <= b <= 1. Proof. intros a b. gappa. Qed. Goal forall a b, a <= 2 -> (not (0 <= a) -> 1 <= b <= 1) -> (-1 <= a -> 1 <= b <= 1) -> 1 <= b <= 1. Proof. intros a b. gappa. Qed. coq-gappalib-coq-1.10.0-df59b68361b1efbd697b17c40f7fae4a35991c44/testsuite/example-20080417.v000066400000000000000000000007251517666064600272510ustar00rootroot00000000000000From Coq Require Import Reals. From Flocq Require Import Core. From Gappa Require Import Gappa_tactic. Open Scope R_scope. Goal forall x y : R, 3/4 <= x <= 3 -> 0 <= sqrt x <= 1775 * powerRZ 2 (-10). Proof. gappa. Qed. Definition rnd := rounding_float rndZR 53 (-1074). Goal forall a_ b_ a b : R, a = rnd a_ -> b = rnd b_ -> 52 / 16 <= a <= 53 / 16 -> 22 / 16 <= b <= 30 / 16 -> 0 <= rnd (a - b) - (a - b) <= 0. Proof. unfold rnd ; gappa. Qed. coq-gappalib-coq-1.10.0-df59b68361b1efbd697b17c40f7fae4a35991c44/testsuite/example-20090706.v000066400000000000000000000004371517666064600272530ustar00rootroot00000000000000From Coq Require Import Reals. From Flocq Require Import Core. From Gappa Require Import Gappa_tactic. Open Scope R_scope. Definition floor := rounding_fixed rndDN 0. Goal forall x y, floor x = floor y -> 2 <= sqrt (4 + Rsqr (x - y)) <= 9/4. Proof. unfold floor, Rsqr. gappa. Qed. coq-gappalib-coq-1.10.0-df59b68361b1efbd697b17c40f7fae4a35991c44/testsuite/example-20101018.v000066400000000000000000000005421517666064600272350ustar00rootroot00000000000000From Coq Require Import Reals. From Flocq Require Import Core. From Gappa Require Import Gappa_tactic. Open Scope R_scope. Definition format := generic_format radix2 (FLT_exp (-1074) 53). Goal forall a b : R, format a -> format b -> 52 / 16 <= a <= 53 / 16 -> 22 / 16 <= b <= 30 / 16 -> format (a - b). Proof. unfold format ; gappa. Qed. coq-gappalib-coq-1.10.0-df59b68361b1efbd697b17c40f7fae4a35991c44/testsuite/example-20250218.v000066400000000000000000000010421517666064600272400ustar00rootroot00000000000000From Coq Require Import Reals. From Flocq Require Import Core. From Gappa Require Import Gappa_tactic. Open Scope R_scope. Definition format := generic_format radix2 (FLT_exp (-1074) 53). Definition rnd := round radix2 (FLT_exp (-1074) 53) ZnearestE. Goal forall a b : R, format a -> format b -> (-2 <= a / b <= -1/2)%R -> format (a + b). Proof. unfold format; gappa. Qed. Goal forall a b : R, format a -> format b -> Rabs (-(rnd (a + b) - (a + b))) <= bpow radix2 (-53) * Rabs (a + b). Proof. unfold format, rnd ; gappa. Qed. coq-gappalib-coq-1.10.0-df59b68361b1efbd697b17c40f7fae4a35991c44/tools/000077500000000000000000000000001517666064600236275ustar00rootroot00000000000000coq-gappalib-coq-1.10.0-df59b68361b1efbd697b17c40f7fae4a35991c44/tools/remake.cpp000066400000000000000000002424161517666064600256100ustar00rootroot00000000000000/* -*- 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); } /** @} */ coq-gappalib-coq-1.10.0-df59b68361b1efbd697b17c40f7fae4a35991c44/tools/vdep.mll000066400000000000000000000106041517666064600252740ustar00rootroot00000000000000{ let backtrack lexbuf = let open Lexing in lexbuf.lex_curr_pos <- lexbuf.lex_start_pos; lexbuf.lex_curr_p <- lexbuf.lex_start_p exception Syntax_error of int * int let syntax_error lexbuf = raise (Syntax_error (Lexing.lexeme_start lexbuf, Lexing.lexeme_end lexbuf)) let rec normalize_path = function | ("" | ".") :: t -> normalize_path t | h :: t -> h :: normalize_path t | [] -> [] let rec concat_path = function | [] -> "." | [f] -> f | h::t -> h ^ "/" ^ concat_path t let files = ref (Hashtbl.create 17) let rec scan_files root path preflen logical = let d = Sys.readdir path in let scan f = let l = String.length f in let file = path ^ "/" ^ f in if Sys.is_directory file then scan_files root file preflen (f :: logical) else if l >= 3 && String.get f (l - 2) = '.' && String.get f (l - 1) = 'v' then let name = String.sub f 0 (l - 2) in let l = match Hashtbl.find_opt !files name with | Some l -> l | None -> [] in Hashtbl.replace !files name ((root, preflen, List.rev logical) :: l) in Array.iter scan d let scan_files path logical = scan_files path (concat_path path) (List.length logical) (List.rev logical) let rec drop n l = if n > 0 then drop (n - 1) (List.tl l) else l let rec drop_last = function | [] -> assert false | [h] -> [] | h::t -> h :: drop_last t let rec is_prefix l1 l2 = match l1, l2 with | [], _ -> true | _, [] -> false | h1::t1, h2::t2 -> h1 = h2 && is_prefix t1 t2 let rec last = function | [] -> assert false | [x] -> x | h::t -> last t let locate prefix suffix = let lp = List.length prefix in let ls = List.length suffix in let rec find = function | (root, _, logical) as h :: t -> let l = List.length logical in if lp + ls <= l + 1 && is_prefix prefix logical && is_prefix (drop (l - ls + 1) logical) suffix then h else find t | [] -> raise Not_found in let f = last suffix in let rl = Hashtbl.find !files f in let (root, preflen, logical) = find rl in let p = List.flatten [root; drop preflen logical; [f ^ ".vo"]] in concat_path p } let space = [' ' '\t' '\n' '\r']+ let ident = ['A'-'Z' 'a'-'z'] ['A'-'Z' 'a'-'z' '0'-'9' '_']* let qualid = ident ('.' ident)* rule parse_vernac = parse | "(*" { skip_comment lexbuf; parse_vernac lexbuf } | "Require" space+ { let r = do_require [] lexbuf in r :: parse_vernac lexbuf } | "From" space+ (qualid as q) space+ "Require" space+ { let r = do_require (String.split_on_char '.' q) lexbuf in r :: parse_vernac lexbuf } | eof { [] } | _ { skip_vernac lexbuf; parse_vernac lexbuf } and do_require prefix = parse | "Import" space+ { really_do_require prefix lexbuf } | "Export" space+ { really_do_require prefix lexbuf } | _ { backtrack lexbuf; really_do_require prefix lexbuf } and really_do_require prefix = parse | (qualid as q) space* { match locate prefix (String.split_on_char '.' q) with | f -> f :: really_do_require prefix lexbuf | exception Not_found -> really_do_require prefix lexbuf } | '.' (space+ | eof) { [] } and skip_vernac = parse | "(*" { skip_comment lexbuf; skip_vernac lexbuf } | '.' (space+ | eof) { () } | _ { skip_vernac lexbuf } and skip_comment = parse | "*)" space* { () } | "(*" { skip_comment lexbuf; skip_comment lexbuf } | eof { () } | _ { skip_comment lexbuf } { let rec parse_args paths files = function | ("-R" | "-Q") :: p :: l :: args -> let p = normalize_path (String.split_on_char '/' p) in scan_files p (String.split_on_char '.' l); parse_args ((p, l) :: paths) files args | f :: args -> if String.length f < 3 || f.[0] = '-' then raise (Invalid_argument ("unrecognized command-line option " ^ f)); let f = normalize_path (String.split_on_char '/' f) in parse_args paths (f :: files) args | [] -> (List.rev paths, List.rev files) let handle_file paths f = let f = concat_path f in let ch = open_in f in let lexbuf = Lexing.from_channel ch in let r = parse_vernac lexbuf in close_in ch; print_string f; print_string "o:"; List.iter (fun d -> print_char ' '; print_string d) (List.flatten r); print_newline () let () = let args = drop 1 (Array.to_list Sys.argv) in let (paths, files) = parse_args [] [] args in List.iter (fun f -> handle_file paths f) files }