From 3afadb31da2cc3a45b5af5b32fa32d2692f7b24b Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Fran=C3=A7ois=20Bobot?= <francois.bobot@cea.fr>
Date: Thu, 2 Jun 2022 06:40:47 +0200
Subject: [PATCH] [Farith] Use external farith version
---
.gitlab-ci.yml | 10 +-
dune-project | 4 -
farith2.opam | 24 -
farith2/.gitignore | 45 --
farith2/.ocamlformat | 0
farith2/Makefile | 13 -
farith2/Readme.md | 18 -
farith2/_CoqProject | 1 -
farith2/doc/coq2html.js | 25 -
farith2/dune | 10 -
farith2/extract/dune | 6 -
farith2/extract/extraction.v | 272 -------
farith2/extract/farith_Big.ml | 267 -------
farith2/extracted/Assert.ml | 19 -
farith2/extracted/Assert.mli | 15 -
farith2/extracted/BinInt.ml | 83 --
farith2/extracted/BinInt.mli | 17 -
farith2/extracted/BinNums.ml | 2 -
farith2/extracted/BinNums.mli | 2 -
farith2/extracted/BinPos.ml | 174 ----
farith2/extracted/BinPos.mli | 41 -
farith2/extracted/BinPosDef.ml | 8 -
farith2/extracted/BinPosDef.mli | 8 -
farith2/extracted/Binary.ml | 21 -
farith2/extracted/Binary.mli | 15 -
farith2/extracted/BinarySingleNaN.ml | 413 ----------
farith2/extracted/BinarySingleNaN.mli | 110 ---
farith2/extracted/Bits.ml | 103 ---
farith2/extracted/Bits.mli | 22 -
farith2/extracted/Bool.ml | 5 -
farith2/extracted/Bool.mli | 2 -
farith2/extracted/Datatypes.ml | 17 -
farith2/extracted/Datatypes.mli | 9 -
farith2/extracted/Defs.ml | 2 -
farith2/extracted/Defs.mli | 2 -
farith2/extracted/GenericFloat.ml | 434 ----------
farith2/extracted/GenericFloat.mli | 176 -----
farith2/extracted/Interval.ml | 137 ----
farith2/extracted/Interval.mli | 52 --
farith2/extracted/Op.ml | 54 --
farith2/extracted/Op.mli | 14 -
farith2/extracted/Operations.ml | 30 -
farith2/extracted/Operations.mli | 11 -
farith2/extracted/Qextended.ml | 22 -
farith2/extracted/Qextended.mli | 10 -
farith2/extracted/Round.ml | 28 -
farith2/extracted/Round.mli | 10 -
farith2/extracted/SpecFloat.ml | 290 -------
farith2/extracted/SpecFloat.mli | 70 --
farith2/extracted/Specif.ml | 5 -
farith2/extracted/Specif.mli | 5 -
farith2/extracted/Utils.ml | 19 -
farith2/extracted/Utils.mli | 9 -
farith2/extracted/Version.ml | 9 -
farith2/extracted/Version.mli | 2 -
farith2/extracted/Zaux.ml | 16 -
farith2/extracted/Zaux.mli | 10 -
farith2/extracted/Zbool.ml | 2 -
farith2/extracted/Zbool.mli | 2 -
farith2/extracted/Zpower.ml | 7 -
farith2/extracted/Zpower.mli | 4 -
farith2/extracted/dune | 48 --
farith2/farith2.ml | 292 -------
farith2/farith2.mli | 399 ----------
farith2/tests/issue_005.expected | 1 -
farith2/tests/issue_005.ml | 11 -
farith2/tests/mode.expected | 61 --
farith2/tests/mode.ml | 43 -
farith2/tests/subnormal.expected | 7 -
farith2/tests/subnormal.ml | 39 -
farith2/tests/test.expected | 18 -
farith2/tests/test.ml | 26 -
farith2/tests/tie.expected | 22 -
farith2/tests/tie.ml | 34 -
farith2/thry/All.v | 27 -
farith2/thry/Assert.v | 26 -
farith2/thry/B32.v | 133 ----
farith2/thry/Correction_thms.v | 195 -----
farith2/thry/Fle0.v | 733 -----------------
farith2/thry/GenericFloat.v | 482 ------------
farith2/thry/Interval.v | 512 ------------
farith2/thry/Intv32.v | 185 -----
farith2/thry/Op.v | 289 -------
farith2/thry/Qextended.v | 68 --
farith2/thry/Rextended.v | 741 ------------------
farith2/thry/Tactics.v | 2 -
farith2/thry/Utils.v | 705 -----------------
farith2/thry/dune | 7 -
qcheck | 1 -
.../tests/solve/colibri/sat/scale_1.smt2 | 2 +-
src_colibri2/theories/FP/dom_interval.ml | 4 +-
src_colibri2/theories/FP/dune | 2 +-
src_colibri2/theories/FP/fp_value.ml | 10 +-
src_colibri2/theories/FP/fp_value.mli | 2 +-
src_colibri2/theories/FP/rounding_mode.ml | 121 ++-
src_colibri2/theories/FP/rounding_mode.mli | 2 +-
96 files changed, 68 insertions(+), 8395 deletions(-)
delete mode 100644 farith2.opam
delete mode 100644 farith2/.gitignore
delete mode 100644 farith2/.ocamlformat
delete mode 100644 farith2/Makefile
delete mode 100644 farith2/Readme.md
delete mode 100644 farith2/_CoqProject
delete mode 100644 farith2/doc/coq2html.js
delete mode 100644 farith2/dune
delete mode 100644 farith2/extract/dune
delete mode 100644 farith2/extract/extraction.v
delete mode 100644 farith2/extract/farith_Big.ml
delete mode 100644 farith2/extracted/Assert.ml
delete mode 100644 farith2/extracted/Assert.mli
delete mode 100644 farith2/extracted/BinInt.ml
delete mode 100644 farith2/extracted/BinInt.mli
delete mode 100644 farith2/extracted/BinNums.ml
delete mode 100644 farith2/extracted/BinNums.mli
delete mode 100644 farith2/extracted/BinPos.ml
delete mode 100644 farith2/extracted/BinPos.mli
delete mode 100644 farith2/extracted/BinPosDef.ml
delete mode 100644 farith2/extracted/BinPosDef.mli
delete mode 100644 farith2/extracted/Binary.ml
delete mode 100644 farith2/extracted/Binary.mli
delete mode 100644 farith2/extracted/BinarySingleNaN.ml
delete mode 100644 farith2/extracted/BinarySingleNaN.mli
delete mode 100644 farith2/extracted/Bits.ml
delete mode 100644 farith2/extracted/Bits.mli
delete mode 100644 farith2/extracted/Bool.ml
delete mode 100644 farith2/extracted/Bool.mli
delete mode 100644 farith2/extracted/Datatypes.ml
delete mode 100644 farith2/extracted/Datatypes.mli
delete mode 100644 farith2/extracted/Defs.ml
delete mode 100644 farith2/extracted/Defs.mli
delete mode 100644 farith2/extracted/GenericFloat.ml
delete mode 100644 farith2/extracted/GenericFloat.mli
delete mode 100644 farith2/extracted/Interval.ml
delete mode 100644 farith2/extracted/Interval.mli
delete mode 100644 farith2/extracted/Op.ml
delete mode 100644 farith2/extracted/Op.mli
delete mode 100644 farith2/extracted/Operations.ml
delete mode 100644 farith2/extracted/Operations.mli
delete mode 100644 farith2/extracted/Qextended.ml
delete mode 100644 farith2/extracted/Qextended.mli
delete mode 100644 farith2/extracted/Round.ml
delete mode 100644 farith2/extracted/Round.mli
delete mode 100644 farith2/extracted/SpecFloat.ml
delete mode 100644 farith2/extracted/SpecFloat.mli
delete mode 100644 farith2/extracted/Specif.ml
delete mode 100644 farith2/extracted/Specif.mli
delete mode 100644 farith2/extracted/Utils.ml
delete mode 100644 farith2/extracted/Utils.mli
delete mode 100644 farith2/extracted/Version.ml
delete mode 100644 farith2/extracted/Version.mli
delete mode 100644 farith2/extracted/Zaux.ml
delete mode 100644 farith2/extracted/Zaux.mli
delete mode 100644 farith2/extracted/Zbool.ml
delete mode 100644 farith2/extracted/Zbool.mli
delete mode 100644 farith2/extracted/Zpower.ml
delete mode 100644 farith2/extracted/Zpower.mli
delete mode 100644 farith2/extracted/dune
delete mode 100644 farith2/farith2.ml
delete mode 100644 farith2/farith2.mli
delete mode 100644 farith2/tests/issue_005.expected
delete mode 100644 farith2/tests/issue_005.ml
delete mode 100644 farith2/tests/mode.expected
delete mode 100644 farith2/tests/mode.ml
delete mode 100644 farith2/tests/subnormal.expected
delete mode 100644 farith2/tests/subnormal.ml
delete mode 100644 farith2/tests/test.expected
delete mode 100644 farith2/tests/test.ml
delete mode 100644 farith2/tests/tie.expected
delete mode 100644 farith2/tests/tie.ml
delete mode 100644 farith2/thry/All.v
delete mode 100644 farith2/thry/Assert.v
delete mode 100644 farith2/thry/B32.v
delete mode 100644 farith2/thry/Correction_thms.v
delete mode 100644 farith2/thry/Fle0.v
delete mode 100644 farith2/thry/GenericFloat.v
delete mode 100644 farith2/thry/Interval.v
delete mode 100644 farith2/thry/Intv32.v
delete mode 100644 farith2/thry/Op.v
delete mode 100644 farith2/thry/Qextended.v
delete mode 100644 farith2/thry/Rextended.v
delete mode 100644 farith2/thry/Tactics.v
delete mode 100644 farith2/thry/Utils.v
delete mode 100644 farith2/thry/dune
delete mode 160000 qcheck
diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml
index e66770ddd..82aad0f50 100644
--- a/.gitlab-ci.yml
+++ b/.gitlab-ci.yml
@@ -40,11 +40,10 @@ tests:
- eval `opam config env`
- sudo apt-get update
- opam pin remove --yes dolmen dolmen_loop dolmen_type || true
- - opam install . --deps-only --with-test --with-doc --yes colibri2 colibrics farith
+ - opam install . --deps-only --with-test --with-doc --yes colibri2 colibrics
- opam repo add coq-released https://coq.inria.fr/opam/released
- opam install --yes why3 core jingoo yojson logs core coq-flocq pp_loc # For generation not done in release mode
- opam install --yes ounit2 # For tests move to opam file?
- - make -C farith2
- make
- make test
tags:
@@ -68,16 +67,12 @@ generate-static:
- sed -e "s/; FOR STATIC//" -i src_colibri2/bin/dune
- opam install depext --yes
- opam pin --no-action --yes .
- - opam depext --yes colibri2 colibrics farith
+ - opam depext --yes colibri2 colibrics
- opam install . --dry-run --deps-only --locked --with-test --with-doc --yes | awk '/-> installed/{print $3}' | xargs opam depext --yes
- opam install . --deps-only --locked --with-test --with-doc --yes
- opam repo add coq-released https://coq.inria.fr/opam/released
- opam depext --yes --install why3 core jingoo yojson logs core coq-flocq coq-coq2html pp_loc # For generation not done in release mode
- opam depext --yes --install ounit2 # For tests move to opam file?
- - echo -e "\e[31mCompile Farith2\e[0m"
- - make -C farith2
- - make -C farith2 doc
- - tar -cvf farith2_doc.tar.gz farith2/doc/
- echo -e "\e[31mCompile Colibri2 static\e[0m"
- make
- make test
@@ -98,5 +93,4 @@ generate-static:
artifacts:
paths:
- bin/colibri2
- - farith2_doc.tar.gz
- colibri2_starexec_$CI_COMMIT_SHORT_SHA.tar.gz
diff --git a/dune-project b/dune-project
index aeebd5a47..cc9626ada 100644
--- a/dune-project
+++ b/dune-project
@@ -59,7 +59,3 @@
"ocplib-simplex"
)
)
-
-(package
- (name farith2)
- (synopsis "formaly verified floating-points valuations based on Flocq"))
diff --git a/farith2.opam b/farith2.opam
deleted file mode 100644
index 67728566a..000000000
--- a/farith2.opam
+++ /dev/null
@@ -1,24 +0,0 @@
-# This file is generated by dune, edit dune-project instead
-opam-version: "2.0"
-synopsis: "formaly verified floating-points valuations based on Flocq"
-homepage: "https://git.frama-c.com/bobot/colibrics"
-bug-reports: "https://git.frama-c.com/bobot/colibrics/issues"
-depends: [
- "dune" {>= "3.0"}
- "odoc" {with-doc}
-]
-build: [
- ["dune" "subst"] {dev}
- [
- "dune"
- "build"
- "-p"
- name
- "-j"
- jobs
- "@install"
- "@runtest" {with-test}
- "@doc" {with-doc}
- ]
-]
-dev-repo: "git+https://git.frama-c.com/bobot/colibrics.git"
diff --git a/farith2/.gitignore b/farith2/.gitignore
deleted file mode 100644
index a7d81f76f..000000000
--- a/farith2/.gitignore
+++ /dev/null
@@ -1,45 +0,0 @@
-.*.aux
-.*.d
-*.a
-*.cma
-*.cmi
-*.cmo
-*.cmx
-*.cmxa
-*.cmxs
-*.glob
-*.ml.d
-*.ml4.d
-*.mlg.d
-*.mli.d
-*.mllib.d
-*.mlpack.d
-*.native
-*.o
-*.v.d
-*.vio
-*.vo
-*.vok
-*.vos
-.coq-native
-.csdp.cache
-.lia.cache
-.nia.cache
-.nlia.cache
-.nra.cache
-csdp.cache
-lia.cache
-nia.cache
-nlia.cache
-nra.cache
-native_compute_profile_*.data
-
-# generated timing files
-*.timing.diff
-*.v.after-timing
-*.v.before-timing
-*.v.timing
-time-of-build-after.log
-time-of-build-before.log
-time-of-build-both.log
-time-of-build-pretty.log
\ No newline at end of file
diff --git a/farith2/.ocamlformat b/farith2/.ocamlformat
deleted file mode 100644
index e69de29bb..000000000
diff --git a/farith2/Makefile b/farith2/Makefile
deleted file mode 100644
index a0ebd3b0e..000000000
--- a/farith2/Makefile
+++ /dev/null
@@ -1,13 +0,0 @@
-include CoqMakefile
-
-CoqMakefile:
- @ coq_makefile -f _CoqProject -o CoqMakefile
-
-.PHONY: cleandoc doc
-
-cleandoc:
- @ rm -rf doc/
-
-doc:
- @ mkdir -p doc
- @ cd thry && coq2html -base F -d ../doc *.v *.glob
\ No newline at end of file
diff --git a/farith2/Readme.md b/farith2/Readme.md
deleted file mode 100644
index 602106b02..000000000
--- a/farith2/Readme.md
+++ /dev/null
@@ -1,18 +0,0 @@
-# Farith2
-
-Farith2 is an *under construction* Coq module formalizing floating points abstract domains based on [Flocq](http://flocq.gforge.inria.fr/).
-
-## Structure
-
-The structure of the sources may vary a lot over time. For now the structure is as follows :
-
-+ the folder `thry` contains all Coq modules
-+ the folder `farith_big` contains OCaml modules used to provide a compatibility layer with Zarith for efficient extraction
-+ the `extract.v` file drives the extraction to OCaml
-+ the root contains `.ml(i)` files generated by extraction
-
-## Compilation
-
-The compilation of the Coq sources is handled with CoqMakefile. To compile everything, simply type `make` at Farith2's root.
-
-To generate the documentation, it is first required to build the sources using `make` and then `make doc` should fill the `doc` folder with the html documentation formatted using [coq2html](https://github.com/xavierleroy/coq2html).
\ No newline at end of file
diff --git a/farith2/_CoqProject b/farith2/_CoqProject
deleted file mode 100644
index 75c988dd7..000000000
--- a/farith2/_CoqProject
+++ /dev/null
@@ -1 +0,0 @@
--R ../_build/default/farith2/thry Farith2
diff --git a/farith2/doc/coq2html.js b/farith2/doc/coq2html.js
deleted file mode 100644
index d869b602b..000000000
--- a/farith2/doc/coq2html.js
+++ /dev/null
@@ -1,25 +0,0 @@
-
-function toggleDisplay(id)
-{
- var elt = document.getElementById(id);
- if (elt.style.display == 'none') {
- elt.style.display = 'block';
- } else {
- elt.style.display = 'none';
- }
-}
-
-function hideAll(cls)
-{
- var testClass = new RegExp("(^|s)" + cls + "(s|$)");
- var tag = tag || "*";
- var elements = document.getElementsByTagName("div");
- var current;
- var length = elements.length;
- for(var i=0; i<length; i++){
- current = elements[i];
- if(testClass.test(current.className)) {
- current.style.display = 'none';
- }
- }
-}
diff --git a/farith2/dune b/farith2/dune
deleted file mode 100644
index 8d6039c48..000000000
--- a/farith2/dune
+++ /dev/null
@@ -1,10 +0,0 @@
-(library
- (name farith2)
- (public_name farith2)
- (libraries zarith base)
- (preprocess
- (pps ppx_deriving.std ppx_hash))
- (flags "-w" "-33"))
-
-(copy_files# extracted/*.ml*)
-(copy_files# extract/farith_Big.ml)
diff --git a/farith2/extract/dune b/farith2/extract/dune
deleted file mode 100644
index 15f3d6abc..000000000
--- a/farith2/extract/dune
+++ /dev/null
@@ -1,6 +0,0 @@
-(coq.extraction
- (prelude extraction)
- (extracted_modules BinNums Bool Qextended Utils Binary BinPosDef Datatypes Round Zaux BinarySingleNaN
- BinPos Interval SpecFloat Zbool BinInt Bits Specif Zpower Assert GenericFloat Version
- Defs Operations Op)
- (theories Farith2))
diff --git a/farith2/extract/extraction.v b/farith2/extract/extraction.v
deleted file mode 100644
index 0a05276a5..000000000
--- a/farith2/extract/extraction.v
+++ /dev/null
@@ -1,272 +0,0 @@
-From Flocq Require Import Core.Zaux IEEE754.BinarySingleNaN IEEE754.Bits Version.
-From Farith2 Require Import Qextended GenericFloat.
-From Coq Require Import Extraction Lia Arith.Wf_nat ZArith.
-
-(* Goal (Beqb (B32.add mode_NE (B32.of_q mode_NE Qx_half) (B32.of_q mode_NE Qx_half)) (B32.of_q mode_NE Qx_one) = true). *)
-(* Proof. *)
-(* cbn. *)
-(* reflexivity. *)
-(* Qed. *)
-
-(* Goal (Beqb (B32.div mode_NE (B32.of_q mode_NE Qx_one) (B32.of_q mode_NE Qx_two)) (B32.of_q mode_NE Qx_half) = true). *)
-(* Proof. *)
-(* cbn. *)
-(* reflexivity. *)
-(* Qed. *)
-
-Require Import Sumbool.
-
-Extract Inlined Constant bool_of_sumbool => "Farith_Big.identity".
-Extract Inlined Constant sumbool_of_bool => "Farith_Big.identity".
-
-
-(** From ExtrOcamlNatBigInt of coq archive *)
-
-Require Import Arith Even Div2 EqNat Euclid.
-Require Import ExtrOcamlBasic.
-
-Extract Inlined Constant Datatypes.negb => "Pervasives.not".
-Extract Inlined Constant Datatypes.fst => "Pervasives.fst".
-Extract Inlined Constant Datatypes.snd => "Pervasives.snd".
-
-
-(** NB: The extracted code should be linked with [nums.cm(x)a]
- from ocaml's stdlib and with the wrapper [big.ml] that
- simplifies the use of [Big_int] (it can be found in the sources
- of Coq). *)
-
-(** Disclaimer: trying to obtain efficient certified programs
- by extracting [nat] into [big_int] isn't necessarily a good idea.
- See comments in [ExtrOcamlNatInt.v].
-*)
-
-
-(** Mapping of [nat] into [big_int]. The last string corresponds to
- a [nat_case], see documentation of [Extract Inductive]. *)
-
-Extract Inductive nat => "Farith_Big.big_int" [ "Farith_Big.zero" "Farith_Big.succ" ]
- "Farith_Big.nat_case".
-
-(** Efficient (but uncertified) versions for usual [nat] functions *)
-
-Extract Inlined Constant plus => "Farith_Big.add".
-Extract Inlined Constant mult => "Farith_Big.mult".
-Extract Constant pred => "fun n -> Farith_Big.max Farith_Big.zero (Farith_Big.pred n)".
-Extract Constant minus => "fun n m -> Farith_Big.max Farith_Big.zero (Farith_Big.sub n m)".
-Extract Inlined Constant max => "Farith_Big.max".
-Extract Inlined Constant min => "Farith_Big.min".
-(*Extract Constant nat_beq => "Farith_Big.eq".*)
-Extract Constant EqNat.beq_nat => "Farith_Big.eq".
-Extract Constant EqNat.eq_nat_decide => "Farith_Big.eq".
-
-Extract Constant Peano_dec.eq_nat_dec => "Farith_Big.eq".
-
-(* Extract Constant Compare_dec.nat_compare =>
- "Farith_Big.compare_case Eq Lt Gt".
-
-Extract Constant Compare_dec.leb => "Farith_Big.le".
-Extract Constant Compare_dec.le_lt_dec => "Farith_Big.le".
-Extract Constant Compare_dec.lt_eq_lt_dec =>
- "Farith_Big.compare_case (Some false) (Some true) None". *)
-
-Extract Constant Even.even_odd_dec =>
- "fun n -> Farith_Big.sign (Farith_Big.mod n Farith_Big.two) = 0".
-Extract Constant Div2.div2 => "fun n -> Farith_Big.div n Farith_Big.two".
-
-Extract Inductive Euclid.diveucl => "(Farith_Big.big_int * Farith_Big.big_int)" [""].
-Extract Constant Euclid.eucl_dev => "fun n m -> Farith_Big.quomod m n".
-Extract Constant Euclid.quotient => "fun n m -> Farith_Big.div m n".
-Extract Constant Euclid.modulo => "fun n m -> Farith_Big.modulo m n".
-
-
-(** From ExtrOcamlZBigInt of coq archive *)
-
-Require Import ZArith NArith.
-Require Import ExtrOcamlBasic.
-
-(** NB: The extracted code should be linked with [nums.cm(x)a]
- from ocaml's stdlib and with the wrapper [big.ml] that
- simplifies the use of [Big_int] (it can be found in the sources
- of Coq). *)
-
-(** Disclaimer: trying to obtain efficient certified programs
- by extracting [Z] into [big_int] isn't necessarily a good idea.
- See the Disclaimer in [ExtrOcamlNatInt]. *)
-
-(** Mapping of [positive], [Z], [N] into [big_int]. The last strings
- emulate the matching, see documentation of [Extract Inductive]. *)
-
-Extract Inductive positive => "Farith_Big.big_int"
- [ "Farith_Big.succ_double" "Farith_Big.double" "Farith_Big.one" ] "Farith_Big.positive_case".
-
-Extract Inductive Z => "Farith_Big.big_int"
- [ "Farith_Big.zero" "" "Farith_Big.opp" ] "Farith_Big.z_case".
-
-Extract Inductive N => "Farith_Big.big_int"
- [ "Farith_Big.zero" "" ] "Farith_Big.n_case".
-
-(** Nota: the "" above is used as an identity function "(fun p->p)" *)
-
-(** Efficient (but uncertified) versions for usual functions *)
-
-Extract Inlined Constant Pos.add => "Farith_Big.add".
-Extract Inlined Constant Pos.succ => "Farith_Big.succ".
-Extract Constant Pos.pred => "fun n -> Farith_Big.max Farith_Big.one (Farith_Big.pred n)".
-Extract Constant Pos.sub => "fun n m -> Farith_Big.max Farith_Big.one (Farith_Big.sub n m)".
-Extract Inlined Constant Pos.pred_double => "Farith_Big.pred_double".
-Extract Inlined Constant Pos.mul => "Farith_Big.mult".
-Extract Inlined Constant Pos.min => "Farith_Big.min".
-Extract Inlined Constant Pos.max => "Farith_Big.max".
-Extract Inlined Constant Pos.compare => "(Farith_Big.compare_case Eq Lt Gt)".
-Extract Constant Pos.compare_cont =>
- "fun c x y -> Farith_Big.compare_case c Lt Gt x y".
-Extract Inlined Constant Pos.eqb => "Farith_Big.eq".
-Extract Inlined Constant Pos.leb => "Farith_Big.le".
-Extract Inlined Constant Pos.ltb => "Farith_Big.lt".
-Extract Inlined Constant Pos.to_nat => "Farith_Big.identity".
-Extract Inlined Constant Pos.of_nat => "Farith_Big.identity".
-Extract Inlined Constant Pos.of_succ_nat => "Farith_Big.succ".
-Extract Constant Pos.add_carry => "fun p q -> Farith_Big.succ (Farith_Big.add p q)".
-Extract Inlined Constant Pos.sqrt => "Farith_Big.Z.sqrt".
-Extract Inlined Constant Pos.square => "Farith_Big.square".
-Extract Inlined Constant Pos.eq_dec => "Farith_Big.Z.equal".
-Extract Inlined Constant Pos.pow => "Farith_Big.pow_pos".
-Extract Inlined Constant Pos.gcd => "Farith_Big.Z.gcd".
-Extract Inlined Constant Pos.lor => "Farith_Big.Z.logor".
-Extract Inlined Constant Pos.land => "Farith_Big.Z.logand".
-Extract Inlined Constant Pos.lxor => "Farith_Big.Z.logxor".
-Extract Inlined Constant Pos.ldiff => "Farith_Big.ldiff".
-Extract Inlined Constant Pos.shiftl_nat => "Farith_Big.shiftl".
-Extract Inlined Constant Pos.shiftr_nat => "Farith_Big.shiftr".
-Extract Inlined Constant Pos.shiftl => "Farith_Big.shiftl".
-Extract Inlined Constant Pos.shiftr => "Farith_Big.shiftr".
-
-Extract Inlined Constant BinPos.Pos.compare_cont => "(fun c x y -> Farith_Big.compare_case c Lt Gt x y)".
-
-
-Extract Inlined Constant N.add => "Farith_Big.add".
-Extract Inlined Constant N.succ => "Farith_Big.succ".
-Extract Constant N.pred => "fun n -> Farith_Big.max Farith_Big.zero (Farith_Big.pred n)".
-Extract Constant N.sub => "fun n m -> Farith_Big.max Farith_Big.zero (Farith_Big.sub n m)".
-Extract Inlined Constant N.mul => "Farith_Big.mult".
-Extract Inlined Constant N.min => "Farith_Big.min".
-Extract Inlined Constant N.max => "Farith_Big.max".
-Extract Constant N.div =>
- "fun a b -> if Farith_Big.eq b Farith_Big.zero then Farith_Big.zero else Farith_Big.div a b".
-Extract Constant N.modulo =>
- "fun a b -> if Farith_Big.eq b Farith_Big.zero then Farith_Big.zero else Farith_Big.modulo a b".
-Extract Constant N.compare => "Farith_Big.compare_case Eq Lt Gt".
-Extract Inlined Constant N.succ_double => "Farith_Big.succ_double".
-Extract Inlined Constant N.double => "Farith_Big.double".
-Extract Inlined Constant Pos.Nsucc_double => "Farith_Big.succ_double".
-Extract Inlined Constant Pos.Ndouble => "Farith_Big.double".
-
-Extract Inlined Constant Z.add => "Farith_Big.add".
-Extract Inlined Constant Z.succ => "Farith_Big.succ".
-Extract Inlined Constant Z.pred => "Farith_Big.pred".
-Extract Inlined Constant Z.sub => "Farith_Big.sub".
-Extract Inlined Constant Z.mul => "Farith_Big.mult".
-Extract Inlined Constant Z.opp => "Farith_Big.opp".
-Extract Inlined Constant Z.abs => "Farith_Big.abs".
-Extract Inlined Constant Z.min => "Farith_Big.min".
-Extract Inlined Constant Z.max => "Farith_Big.max".
-Extract Inlined Constant Z.eqb => "Farith_Big.eq".
-Extract Inlined Constant Z.leb => "Farith_Big.le".
-Extract Inlined Constant Z.ltb => "Farith_Big.lt".
-Extract Inlined Constant Z.geb => "Farith_Big.ge".
-Extract Inlined Constant Z.gtb => "Farith_Big.gt".
-Extract Inlined Constant Z.compare => "(Farith_Big.compare_case Eq Lt Gt)".
-Extract Inlined Constant Z.double => "Farith_Big.double".
-Extract Inlined Constant Z.succ_double => "Farith_Big.succ_double".
-Extract Inlined Constant Z.pred_double => "Farith_Big.pred_double".
-Extract Inlined Constant Z.pos_sub => "Farith_Big.sub".
-Extract Inlined Constant Z.gcd => "Farith_Big.Z.gcd".
-Extract Inlined Constant Z.sqrt => "Farith_Big.Z.sqrt".
-Extract Inlined Constant Z.sqrtrem => "Farith_Big.Z.sqrt_rem".
-Extract Inlined Constant Z.square => "Farith_Big.square".
-Extract Inlined Constant Z.lnot => "Farith_Big.Z.lognot".
-Extract Inlined Constant Z.lor => "Farith_Big.Z.logor".
-Extract Inlined Constant Z.land => "Farith_Big.Z.logand".
-Extract Inlined Constant Z.lxor => "Farith_Big.Z.logxor".
-Extract Inlined Constant Z.ldiff => "Farith_Big.ldiff".
-Extract Inlined Constant Z.eq_dec => "Farith_Big.Z.equal".
-Extract Inlined Constant Z.shiftr => "Farith_Big.shiftr".
-Extract Inlined Constant Z.shiftl => "Farith_Big.shiftl".
-Extract Inlined Constant Z.sgn => "Farith_Big.sgn".
-
-Extract Inlined Constant Z.of_N => "Farith_Big.identity".
-Extract Inlined Constant Z.of_nat => "Farith_Big.identity".
-
-Extract Inlined Constant Z.abs_N => "Farith_Big.abs".
-Extract Inlined Constant Z.abs_nat => "Farith_Big.abs".
-
-Extract Inlined Constant Zeq_bool => "Farith_Big.eq".
-
-(** trunc convention *)
-Extract Inlined Constant Z.rem => "Farith_Big.Z.rem".
-Extract Inlined Constant Z.quot => "Farith_Big.Z.div".
-Extract Inlined Constant Z.quot2 => "Farith_Big.div2_trunc".
-Extract Inlined Constant Z.quotrem => "Farith_Big.Z.div_rem".
-
-(** floor convention *)
-Extract Inlined Constant Z.modulo => "Farith_Big.mod_floor".
-Extract Inlined Constant Z.div => "Farith_Big.div_floor".
-Extract Inlined Constant Z.div_eucl => "Farith_Big.div_mod_floor".
-Extract Inlined Constant Z.div2 => "Farith_Big.div2_floor".
-
-(** euclid convention *)
-Require Import Zeuclid.
-Extract Inlined Constant ZEuclid.modulo => "Farith_Big.Z.erem".
-Extract Inlined Constant ZEuclid.div => "Farith_Big.Z.ediv".
-
-Extract Inlined Constant Z.pow_pos => "Farith_Big.pow_pos".
-
-
-
-Require Import Flocq.Core.Zaux.
-Require Coq.Arith.Wf_nat.
-(* Extract Inlined Constant shiftl_pos => "Farith_Big.shiftl_pos". *)
-Extract Inlined Constant Core.Zaux.iter_nat => "Farith_Big.iter_nat".
-Extract Inlined Constant nat_rect => "Farith_Big.nat_rect".
-
-
-(** Some proofs used in function realization *)
-
-Definition div_mod_floor a b :=
- let (q,r) := Z.quotrem a b in
- if orb (Z.lxor (Z.sgn a) (Z.sgn b) >=? 0)%Z (r =? 0)%Z
- then (q,r)
- else (Z.pred q,b+r)%Z.
-
-Lemma Floor_of_Trunc:
- forall a b, (b <> 0)%Z -> Z.div_eucl a b = div_mod_floor a b.
-Proof.
- intros a' b' Hb.
- unfold div_mod_floor.
- assert (Lmod := Z.rem_mod a' b' Hb).
- assert (Ldiv := Z.quot_div a' b' Hb).
- replace (Z.quotrem a' b') with ((Z.quot a' b',Z.rem a' b')) by
- (compute [Z.quot Z.rem]; destruct (Z.quotrem a' b'); trivial).
- replace (Z.pred (Z.quot a' b'))%Z with (-(Z.opp (Z.quot a' b')+1))%Z by lia.
- rewrite Lmod. rewrite Ldiv.
- pose (a := a'). pose (b := b').
- destruct a'; destruct b'; unfold Z.modulo, Z.div; simpl; trivial; try destruct (Hb (refl_equal 0%Z));
- destruct (Z.pos_div_eucl p (Z.pos p0)) as [[|pq|nq] [|pr|nr]]; trivial.
-Qed.
-
-(* Avoid name clashes *)
-Extraction Blacklist Big List String Int Z Q.
-
-Extract Inductive Qextended.Qx => "Q.t" [ "Farith_Big.q_mk" ] "Farith_Big.q_case".
-Extract Inlined Constant Qextended.den => "Farith_Big.q_den".
-Extract Inlined Constant Qextended.num => "Farith_Big.q_num".
-Extract Inlined Constant Qextended.Qx_classify => "Q.classify".
-
-Extract Inductive Qx_kind => "Q.kind" [ "Q.INF" "Q.MINF" "Q.UNDEF" "Q.ZERO" "Q.NZERO" ].
-Extract Inlined Constant Qx_classify => "Q.classify".
-
-Extract Inductive mode => "Farith_Big.mode" [
- "Farith_Big.NE" "Farith_Big.ZR" "Farith_Big.DN" "Farith_Big.UP" "Farith_Big.NA"
-].
-
-Separate Extraction GenericFloat GenericInterval Flocq.Version.
diff --git a/farith2/extract/farith_Big.ml b/farith2/extract/farith_Big.ml
deleted file mode 100644
index 6dcac828f..000000000
--- a/farith2/extract/farith_Big.ml
+++ /dev/null
@@ -1,267 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
-(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(************************************************************************)
-
-(** [Big] : a wrapper around ocaml [Big_int] with nicer names,
- and a few extraction-specific constructions *)
-
-(** To be linked with [nums.(cma|cmxa)] *)
-
-open Big_int_Z
-
-type big_int = Big_int_Z.big_int
-
-(* The type of big integers. *)
-let zero = zero_big_int
-
-(* The big integer [0]. *)
-let one = unit_big_int
-
-(* The big integer [1]. *)
-let two = big_int_of_int 2
-(* The big integer [2]. *)
-
-(* {6 Arithmetic operations} *)
-
-let opp = minus_big_int
-
-(* Unary negation. *)
-let abs = abs_big_int
-
-(* Absolute value. *)
-let add = add_big_int
-
-(* Addition. *)
-let succ = succ_big_int
-
-(* Successor (add 1). *)
-let add_int = add_int_big_int
-
-(* Addition of a small integer to a big integer. *)
-let sub = sub_big_int
-
-(* Subtraction. *)
-let pred = pred_big_int
-
-(* Predecessor (subtract 1). *)
-let mult = mult_big_int
-
-(* Multiplication of two big integers. *)
-let mult_int = mult_int_big_int
-
-(* Multiplication of a big integer by a small integer *)
-let _square = square_big_int
-
-(* Return the square of the given big integer *)
-let sqrt = sqrt_big_int
-
-(* [sqrt_big_int a] returns the integer square root of [a],
- that is, the largest big integer [r] such that [r * r <= a].
- Raise [Invalid_argument] if [a] is negative. *)
-let quomod = quomod_big_int
-
-(* Euclidean division of two big integers.
- The first part of the result is the quotient,
- the second part is the remainder.
- Writing [(q,r) = quomod_big_int a b], we have
- [a = q * b + r] and [0 <= r < |b|].
- Raise [Division_by_zero] if the divisor is zero. *)
-let div = div_big_int
-
-(* Euclidean quotient of two big integers.
- This is the first result [q] of [quomod_big_int] (see above). *)
-let modulo = mod_big_int
-
-(* Euclidean modulus of two big integers.
- This is the second result [r] of [quomod_big_int] (see above). *)
-let gcd = gcd_big_int
-
-(* Greatest common divisor of two big integers. *)
-let power = power_big_int_positive_big_int
-(* Exponentiation functions. Return the big integer
- representing the first argument [a] raised to the power [b]
- (the second argument). Depending
- on the function, [a] and [b] can be either small integers
- or big integers. Raise [Invalid_argument] if [b] is negative. *)
-
-(* {6 Comparisons and tests} *)
-
-let sign = sign_big_int
-
-(* Return [0] if the given big integer is zero,
- [1] if it is positive, and [-1] if it is negative. *)
-let compare = compare_big_int
-
-(* [compare_big_int a b] returns [0] if [a] and [b] are equal,
- [1] if [a] is greater than [b], and [-1] if [a] is smaller
- than [b]. *)
-let eq = eq_big_int
-
-let le = le_big_int
-
-let ge = ge_big_int
-
-let lt = lt_big_int
-
-let gt = gt_big_int
-
-(* Usual boolean comparisons between two big integers. *)
-let max = max_big_int
-
-(* Return the greater of its two arguments. *)
-let min = min_big_int
-
-(* Return the smaller of its two arguments. *)
-(* {6 Conversions to and from strings} *)
-
-let to_string = string_of_big_int
-
-(* Return the string representation of the given big integer,
- in decimal (base 10). *)
-let of_string = big_int_of_string
-(* Convert a string to a big integer, in decimal.
- The string consists of an optional [-] or [+] sign,
- followed by one or several decimal digits. *)
-
-(* {6 Conversions to and from other numerical types} *)
-
-let of_int = big_int_of_int
-
-(* Convert a small integer to a big integer. *)
-let is_int = is_int_big_int
-
-(* Test whether the given big integer is small enough to
- be representable as a small integer (type [int])
- without loss of precision. On a 32-bit platform,
- [is_int_big_int a] returns [true] if and only if
- [a] is between 2{^30} and 2{^30}-1. On a 64-bit platform,
- [is_int_big_int a] returns [true] if and only if
- [a] is between -2{^62} and 2{^62}-1. *)
-let to_int = int_of_big_int
-(* Convert a big integer to a small integer (type [int]).
- Raises [Failure "int_of_big_int"] if the big integer
- is not representable as a small integer. *)
-
-(* Functions used by extraction *)
-
-let double n = Z.shift_left n 1
-
-let succ_double n = Z.succ (Z.shift_left n 1)
-
-let pred_double n = Z.pred (Z.shift_left n 1)
-
-let nat_case fO fS n = if sign n <= 0 then fO () else fS (pred n)
-
-let positive_case f2p1 f2p f1 p =
- if le p one then f1 ()
- else
- let q, r = quomod p two in
- if eq r zero then f2p q else f2p1 q
-
-let n_case fO fp n = if sign n <= 0 then fO () else fp n
-
-let z_case fO fp fn z =
- let s = sign z in
- if s = 0 then fO () else if s > 0 then fp z else fn (opp z)
-
-let sgn z = Z.of_int (Z.sign z)
-
-let compare_case e l g x y =
- let s = compare x y in
- if s = 0 then e else if s < 0 then l else g
-
-let nat_rec fO fS =
- let rec loop acc n = if sign n <= 0 then acc else loop (fS acc) (pred n) in
- loop fO
-
-let positive_rec f2p1 f2p f1 =
- let rec loop n =
- if le n one then f1
- else
- let q, r = quomod n two in
- if eq r zero then f2p (loop q) else f2p1 (loop q)
- in
- loop
-
-let z_rec fO fp fn = z_case (fun _ -> fO) fp fn
-
-let rec nat_rect acc f n =
- if sign n <= 0 then acc else nat_rect (f () acc) f (pred n)
-
-let rec iter_nat f n acc =
- if sign n <= 0 then acc else iter_nat f (pred n) (f acc)
-
-external identity : 'a -> 'a = "%identity"
-
-let shiftl_pos a p = Z.shift_left a (Z.to_int p)
-
-let modulo_pos a b =
- assert (sign a >= 0);
- assert (sign b >= 0);
- modulo a b
-
-let div_pos a b =
- assert (sign a >= 0);
- assert (sign b > 0);
- div a b
-
-let square a = Z.mul a a
-
-let pow_pos a p = Z.pow a (Z.to_int p)
-
-let div2_trunc n = Z.shift_right_trunc n 1
-
-let div_floor = Z.fdiv
-
-let div2_floor n = Z.shift_right n 1
-
-let mod_floor a b =
- let r = Z.rem a b in
- if Stdlib.( lxor ) (Z.sign a) (Z.sign b) >= 0 || Z.equal r Z.zero then r
- else Z.add b r
-
-let div_mod_floor a b =
- let ((p, r) as pr) = Z.div_rem a b in
- if Stdlib.( lxor ) (Z.sign a) (Z.sign b) >= 0 || Z.equal r Z.zero then pr
- else (Z.pred p, Z.add b r)
-
-let pos_div_eucl a b =
- assert (sign a >= 0);
- assert (sign b > 0);
- Z.div_rem a b
-
-let shiftl a n =
- let n = Z.to_int n in
- if n < 0 then Z.shift_right a (-n) else Z.shift_left a n
-
-let shiftr a n =
- let n = Z.to_int n in
- if n < 0 then Z.shift_left a (-n) else Z.shift_right a n
-
-let ldiff a b = Z.logand a (Z.lognot b)
-
-module Z = Z (* zarith *)
-
-(* Q *)
-(* must be already normalize *)
-let q_mk (num, den) = { Q.den; Q.num }
-
-let q_case f q = f q.Q.den q.Q.num
-
-let q_den q = q.Q.den
-
-let q_num q = q.Q.num
-
-type mode = NE | ZR | DN | UP | NA
-
-type classify =
- | Zero of bool
- | Infinity of bool
- | NaN
- | Finite of bool * Z.t * Z.t
-
-let combine_hash acc n = (n * 65599) + acc
diff --git a/farith2/extracted/Assert.ml b/farith2/extracted/Assert.ml
deleted file mode 100644
index 9e851bf0c..000000000
--- a/farith2/extracted/Assert.ml
+++ /dev/null
@@ -1,19 +0,0 @@
-
-type __ = Obj.t
-let __ = let rec f _ = Obj.repr f in Obj.repr f
-
-module type Inhabited =
- sig
- type t
-
- val dummy : t
- end
-
-module Assert =
- functor (M:Inhabited) ->
- struct
- (** val coq_assert : bool -> (__ -> M.t) -> M.t **)
-
- let coq_assert x f =
- if x then f __ else M.dummy
- end
diff --git a/farith2/extracted/Assert.mli b/farith2/extracted/Assert.mli
deleted file mode 100644
index 75ac9d172..000000000
--- a/farith2/extracted/Assert.mli
+++ /dev/null
@@ -1,15 +0,0 @@
-
-type __ = Obj.t
-
-module type Inhabited =
- sig
- type t
-
- val dummy : t
- end
-
-module Assert :
- functor (M:Inhabited) ->
- sig
- val coq_assert : bool -> (__ -> M.t) -> M.t
- end
diff --git a/farith2/extracted/BinInt.ml b/farith2/extracted/BinInt.ml
deleted file mode 100644
index fc758fdda..000000000
--- a/farith2/extracted/BinInt.ml
+++ /dev/null
@@ -1,83 +0,0 @@
-
-module Z =
- struct
- type t = Farith_Big.big_int
-
- (** val pow :
- Farith_Big.big_int -> Farith_Big.big_int -> Farith_Big.big_int **)
-
- let pow x y =
- Farith_Big.z_case
- (fun _ -> Farith_Big.one)
- (fun p -> Farith_Big.pow_pos x p)
- (fun _ -> Farith_Big.zero)
- y
-
- (** val to_nat : Farith_Big.big_int -> Farith_Big.big_int **)
-
- let to_nat z =
- Farith_Big.z_case
- (fun _ -> Farith_Big.zero)
- (fun p -> Farith_Big.identity p)
- (fun _ -> Farith_Big.zero)
- z
-
- (** val to_pos : Farith_Big.big_int -> Farith_Big.big_int **)
-
- let to_pos z =
- Farith_Big.z_case
- (fun _ -> Farith_Big.one)
- (fun p -> p)
- (fun _ -> Farith_Big.one)
- z
-
- (** val pos_div_eucl :
- Farith_Big.big_int -> Farith_Big.big_int ->
- Farith_Big.big_int * Farith_Big.big_int **)
-
- let rec pos_div_eucl a b =
- Farith_Big.positive_case
- (fun a' ->
- let (q, r) = pos_div_eucl a' b in
- let r' =
- Farith_Big.add (Farith_Big.mult (Farith_Big.double Farith_Big.one) r)
- Farith_Big.one
- in
- if Farith_Big.lt r' b
- then ((Farith_Big.mult (Farith_Big.double Farith_Big.one) q), r')
- else ((Farith_Big.add
- (Farith_Big.mult (Farith_Big.double Farith_Big.one) q)
- Farith_Big.one), (Farith_Big.sub r' b)))
- (fun a' ->
- let (q, r) = pos_div_eucl a' b in
- let r' = Farith_Big.mult (Farith_Big.double Farith_Big.one) r in
- if Farith_Big.lt r' b
- then ((Farith_Big.mult (Farith_Big.double Farith_Big.one) q), r')
- else ((Farith_Big.add
- (Farith_Big.mult (Farith_Big.double Farith_Big.one) q)
- Farith_Big.one), (Farith_Big.sub r' b)))
- (fun _ ->
- if Farith_Big.le (Farith_Big.double Farith_Big.one) b
- then (Farith_Big.zero, Farith_Big.one)
- else (Farith_Big.one, Farith_Big.zero))
- a
-
- (** val even : Farith_Big.big_int -> bool **)
-
- let even z =
- Farith_Big.z_case
- (fun _ -> true)
- (fun p ->
- Farith_Big.positive_case
- (fun _ -> false)
- (fun _ -> true)
- (fun _ -> false)
- p)
- (fun p ->
- Farith_Big.positive_case
- (fun _ -> false)
- (fun _ -> true)
- (fun _ -> false)
- p)
- z
- end
diff --git a/farith2/extracted/BinInt.mli b/farith2/extracted/BinInt.mli
deleted file mode 100644
index c0985b8cd..000000000
--- a/farith2/extracted/BinInt.mli
+++ /dev/null
@@ -1,17 +0,0 @@
-
-module Z :
- sig
- type t = Farith_Big.big_int
-
- val pow : Farith_Big.big_int -> Farith_Big.big_int -> Farith_Big.big_int
-
- val to_nat : Farith_Big.big_int -> Farith_Big.big_int
-
- val to_pos : Farith_Big.big_int -> Farith_Big.big_int
-
- val pos_div_eucl :
- Farith_Big.big_int -> Farith_Big.big_int ->
- Farith_Big.big_int * Farith_Big.big_int
-
- val even : Farith_Big.big_int -> bool
- end
diff --git a/farith2/extracted/BinNums.ml b/farith2/extracted/BinNums.ml
deleted file mode 100644
index 139597f9c..000000000
--- a/farith2/extracted/BinNums.ml
+++ /dev/null
@@ -1,2 +0,0 @@
-
-
diff --git a/farith2/extracted/BinNums.mli b/farith2/extracted/BinNums.mli
deleted file mode 100644
index 139597f9c..000000000
--- a/farith2/extracted/BinNums.mli
+++ /dev/null
@@ -1,2 +0,0 @@
-
-
diff --git a/farith2/extracted/BinPos.ml b/farith2/extracted/BinPos.ml
deleted file mode 100644
index d77b19552..000000000
--- a/farith2/extracted/BinPos.ml
+++ /dev/null
@@ -1,174 +0,0 @@
-open BinPosDef
-
-module Pos =
- struct
- (** val add_carry :
- Farith_Big.big_int -> Farith_Big.big_int -> Farith_Big.big_int **)
-
- let rec add_carry = fun p q -> Farith_Big.succ (Farith_Big.add p q)
-
- (** val pred : Farith_Big.big_int -> Farith_Big.big_int **)
-
- let pred = fun n -> Farith_Big.max Farith_Big.one (Farith_Big.pred n)
-
- type mask = Pos.mask =
- | IsNul
- | IsPos of Farith_Big.big_int
- | IsNeg
-
- (** val succ_double_mask : mask -> mask **)
-
- let succ_double_mask = function
- | IsNul -> IsPos Farith_Big.one
- | IsPos p -> IsPos (Farith_Big.succ_double p)
- | IsNeg -> IsNeg
-
- (** val double_mask : mask -> mask **)
-
- let double_mask = function
- | IsPos p -> IsPos (Farith_Big.double p)
- | x0 -> x0
-
- (** val double_pred_mask : Farith_Big.big_int -> mask **)
-
- let double_pred_mask x =
- Farith_Big.positive_case
- (fun p -> IsPos (Farith_Big.double (Farith_Big.double p)))
- (fun p -> IsPos (Farith_Big.double
- (Farith_Big.pred_double p)))
- (fun _ -> IsNul)
- x
-
- (** val sub_mask : Farith_Big.big_int -> Farith_Big.big_int -> mask **)
-
- let rec sub_mask x y =
- Farith_Big.positive_case
- (fun p ->
- Farith_Big.positive_case
- (fun q -> double_mask (sub_mask p q))
- (fun q -> succ_double_mask (sub_mask p q))
- (fun _ -> IsPos (Farith_Big.double p))
- y)
- (fun p ->
- Farith_Big.positive_case
- (fun q -> succ_double_mask (sub_mask_carry p q))
- (fun q -> double_mask (sub_mask p q))
- (fun _ -> IsPos (Farith_Big.pred_double p))
- y)
- (fun _ ->
- Farith_Big.positive_case
- (fun _ -> IsNeg)
- (fun _ -> IsNeg)
- (fun _ -> IsNul)
- y)
- x
-
- (** val sub_mask_carry :
- Farith_Big.big_int -> Farith_Big.big_int -> mask **)
-
- and sub_mask_carry x y =
- Farith_Big.positive_case
- (fun p ->
- Farith_Big.positive_case
- (fun q -> succ_double_mask (sub_mask_carry p q))
- (fun q -> double_mask (sub_mask p q))
- (fun _ -> IsPos (Farith_Big.pred_double p))
- y)
- (fun p ->
- Farith_Big.positive_case
- (fun q -> double_mask (sub_mask_carry p q))
- (fun q -> succ_double_mask (sub_mask_carry p q))
- (fun _ -> double_pred_mask p)
- y)
- (fun _ -> IsNeg)
- x
-
- (** val sub :
- Farith_Big.big_int -> Farith_Big.big_int -> Farith_Big.big_int **)
-
- let sub = fun n m -> Farith_Big.max Farith_Big.one (Farith_Big.sub n m)
-
- (** val iter : ('a1 -> 'a1) -> 'a1 -> Farith_Big.big_int -> 'a1 **)
-
- let rec iter f x n =
- Farith_Big.positive_case
- (fun n' -> f (iter f (iter f x n') n'))
- (fun n' -> iter f (iter f x n') n')
- (fun _ -> f x)
- n
-
- (** val div2 : Farith_Big.big_int -> Farith_Big.big_int **)
-
- let div2 p =
- Farith_Big.positive_case
- (fun p0 -> p0)
- (fun p0 -> p0)
- (fun _ -> Farith_Big.one)
- p
-
- (** val div2_up : Farith_Big.big_int -> Farith_Big.big_int **)
-
- let div2_up p =
- Farith_Big.positive_case
- (fun p0 -> Farith_Big.succ p0)
- (fun p0 -> p0)
- (fun _ -> Farith_Big.one)
- p
-
- (** val sqrtrem_step :
- (Farith_Big.big_int -> Farith_Big.big_int) -> (Farith_Big.big_int ->
- Farith_Big.big_int) -> (Farith_Big.big_int * mask) ->
- Farith_Big.big_int * mask **)
-
- let sqrtrem_step f g = function
- | (s, y) ->
- (match y with
- | IsPos r ->
- let s' = Farith_Big.succ_double (Farith_Big.double s) in
- let r' = g (f r) in
- if Farith_Big.le s' r'
- then ((Farith_Big.succ_double s), (sub_mask r' s'))
- else ((Farith_Big.double s), (IsPos r'))
- | _ ->
- ((Farith_Big.double s),
- (sub_mask (g (f Farith_Big.one)) (Farith_Big.double
- (Farith_Big.double Farith_Big.one)))))
-
- (** val sqrtrem : Farith_Big.big_int -> Farith_Big.big_int * mask **)
-
- let rec sqrtrem p =
- Farith_Big.positive_case
- (fun p0 ->
- Farith_Big.positive_case
- (fun p1 ->
- sqrtrem_step (fun x -> Farith_Big.succ_double x) (fun x ->
- Farith_Big.succ_double x) (sqrtrem p1))
- (fun p1 ->
- sqrtrem_step (fun x -> Farith_Big.double x) (fun x ->
- Farith_Big.succ_double x) (sqrtrem p1))
- (fun _ -> (Farith_Big.one, (IsPos (Farith_Big.double
- Farith_Big.one))))
- p0)
- (fun p0 ->
- Farith_Big.positive_case
- (fun p1 ->
- sqrtrem_step (fun x -> Farith_Big.succ_double x) (fun x ->
- Farith_Big.double x) (sqrtrem p1))
- (fun p1 ->
- sqrtrem_step (fun x -> Farith_Big.double x) (fun x ->
- Farith_Big.double x) (sqrtrem p1))
- (fun _ -> (Farith_Big.one, (IsPos Farith_Big.one)))
- p0)
- (fun _ -> (Farith_Big.one, IsNul))
- p
-
- (** val iter_op :
- ('a1 -> 'a1 -> 'a1) -> Farith_Big.big_int -> 'a1 -> 'a1 **)
-
- let rec iter_op op p a =
- Farith_Big.positive_case
- (fun p0 -> op a (iter_op op p0 (op a a)))
- (fun p0 -> iter_op op p0 (op a a))
- (fun _ -> a)
- p
- end
diff --git a/farith2/extracted/BinPos.mli b/farith2/extracted/BinPos.mli
deleted file mode 100644
index d70b6e062..000000000
--- a/farith2/extracted/BinPos.mli
+++ /dev/null
@@ -1,41 +0,0 @@
-open BinPosDef
-
-module Pos :
- sig
- val add_carry :
- Farith_Big.big_int -> Farith_Big.big_int -> Farith_Big.big_int
-
- val pred : Farith_Big.big_int -> Farith_Big.big_int
-
- type mask = Pos.mask =
- | IsNul
- | IsPos of Farith_Big.big_int
- | IsNeg
-
- val succ_double_mask : mask -> mask
-
- val double_mask : mask -> mask
-
- val double_pred_mask : Farith_Big.big_int -> mask
-
- val sub_mask : Farith_Big.big_int -> Farith_Big.big_int -> mask
-
- val sub_mask_carry : Farith_Big.big_int -> Farith_Big.big_int -> mask
-
- val sub : Farith_Big.big_int -> Farith_Big.big_int -> Farith_Big.big_int
-
- val iter : ('a1 -> 'a1) -> 'a1 -> Farith_Big.big_int -> 'a1
-
- val div2 : Farith_Big.big_int -> Farith_Big.big_int
-
- val div2_up : Farith_Big.big_int -> Farith_Big.big_int
-
- val sqrtrem_step :
- (Farith_Big.big_int -> Farith_Big.big_int) -> (Farith_Big.big_int ->
- Farith_Big.big_int) -> (Farith_Big.big_int * mask) ->
- Farith_Big.big_int * mask
-
- val sqrtrem : Farith_Big.big_int -> Farith_Big.big_int * mask
-
- val iter_op : ('a1 -> 'a1 -> 'a1) -> Farith_Big.big_int -> 'a1 -> 'a1
- end
diff --git a/farith2/extracted/BinPosDef.ml b/farith2/extracted/BinPosDef.ml
deleted file mode 100644
index e1f8f253c..000000000
--- a/farith2/extracted/BinPosDef.ml
+++ /dev/null
@@ -1,8 +0,0 @@
-
-module Pos =
- struct
- type mask =
- | IsNul
- | IsPos of Farith_Big.big_int
- | IsNeg
- end
diff --git a/farith2/extracted/BinPosDef.mli b/farith2/extracted/BinPosDef.mli
deleted file mode 100644
index ae03b859d..000000000
--- a/farith2/extracted/BinPosDef.mli
+++ /dev/null
@@ -1,8 +0,0 @@
-
-module Pos :
- sig
- type mask =
- | IsNul
- | IsPos of Farith_Big.big_int
- | IsNeg
- end
diff --git a/farith2/extracted/Binary.ml b/farith2/extracted/Binary.ml
deleted file mode 100644
index 1fc1c209b..000000000
--- a/farith2/extracted/Binary.ml
+++ /dev/null
@@ -1,21 +0,0 @@
-
-type full_float =
-| F754_zero of bool
-| F754_infinity of bool
-| F754_nan of bool * Farith_Big.big_int
-| F754_finite of bool * Farith_Big.big_int * Farith_Big.big_int
-
-type binary_float =
-| B754_zero of bool
-| B754_infinity of bool
-| B754_nan of bool * Farith_Big.big_int
-| B754_finite of bool * Farith_Big.big_int * Farith_Big.big_int
-
-(** val coq_FF2B :
- Farith_Big.big_int -> Farith_Big.big_int -> full_float -> binary_float **)
-
-let coq_FF2B _ _ = function
-| F754_zero s -> B754_zero s
-| F754_infinity s -> B754_infinity s
-| F754_nan (b, pl) -> B754_nan (b, pl)
-| F754_finite (s, m, e) -> B754_finite (s, m, e)
diff --git a/farith2/extracted/Binary.mli b/farith2/extracted/Binary.mli
deleted file mode 100644
index a9eb82be8..000000000
--- a/farith2/extracted/Binary.mli
+++ /dev/null
@@ -1,15 +0,0 @@
-
-type full_float =
-| F754_zero of bool
-| F754_infinity of bool
-| F754_nan of bool * Farith_Big.big_int
-| F754_finite of bool * Farith_Big.big_int * Farith_Big.big_int
-
-type binary_float =
-| B754_zero of bool
-| B754_infinity of bool
-| B754_nan of bool * Farith_Big.big_int
-| B754_finite of bool * Farith_Big.big_int * Farith_Big.big_int
-
-val coq_FF2B :
- Farith_Big.big_int -> Farith_Big.big_int -> full_float -> binary_float
diff --git a/farith2/extracted/BinarySingleNaN.ml b/farith2/extracted/BinarySingleNaN.ml
deleted file mode 100644
index c5a85d703..000000000
--- a/farith2/extracted/BinarySingleNaN.ml
+++ /dev/null
@@ -1,413 +0,0 @@
-open BinInt
-open BinPos
-open Bool
-open Datatypes
-open Defs
-open Operations
-open Round
-open SpecFloat
-open Zaux
-open Zpower
-
-type binary_float =
-| B754_zero of bool
-| B754_infinity of bool
-| B754_nan
-| B754_finite of bool * Farith_Big.big_int * Farith_Big.big_int
-
-(** val coq_SF2B :
- Farith_Big.big_int -> Farith_Big.big_int -> spec_float -> binary_float **)
-
-let coq_SF2B _ _ = function
-| S754_zero s -> B754_zero s
-| S754_infinity s -> B754_infinity s
-| S754_nan -> B754_nan
-| S754_finite (s, m, e) -> B754_finite (s, m, e)
-
-(** val coq_B2SF :
- Farith_Big.big_int -> Farith_Big.big_int -> binary_float -> spec_float **)
-
-let coq_B2SF _ _ = function
-| B754_zero s -> S754_zero s
-| B754_infinity s -> S754_infinity s
-| B754_nan -> S754_nan
-| B754_finite (s, m, e) -> S754_finite (s, m, e)
-
-(** val coq_Bsign :
- Farith_Big.big_int -> Farith_Big.big_int -> binary_float -> bool **)
-
-let coq_Bsign _ _ = function
-| B754_zero s -> s
-| B754_infinity s -> s
-| B754_nan -> false
-| B754_finite (s, _, _) -> s
-
-(** val is_nan :
- Farith_Big.big_int -> Farith_Big.big_int -> binary_float -> bool **)
-
-let is_nan _ _ = function
-| B754_nan -> true
-| _ -> false
-
-(** val coq_Bopp :
- Farith_Big.big_int -> Farith_Big.big_int -> binary_float -> binary_float **)
-
-let coq_Bopp _ _ x = match x with
-| B754_zero sx -> B754_zero (Pervasives.not sx)
-| B754_infinity sx -> B754_infinity (Pervasives.not sx)
-| B754_nan -> x
-| B754_finite (sx, mx, ex) -> B754_finite ((Pervasives.not sx), mx, ex)
-
-(** val coq_Babs :
- Farith_Big.big_int -> Farith_Big.big_int -> binary_float -> binary_float **)
-
-let coq_Babs _ _ x = match x with
-| B754_zero _ -> B754_zero false
-| B754_infinity _ -> B754_infinity false
-| B754_nan -> x
-| B754_finite (_, mx, ex) -> B754_finite (false, mx, ex)
-
-(** val coq_Beqb :
- Farith_Big.big_int -> Farith_Big.big_int -> binary_float -> binary_float
- -> bool **)
-
-let coq_Beqb prec emax f1 f2 =
- coq_SFeqb (coq_B2SF prec emax f1) (coq_B2SF prec emax f2)
-
-(** val coq_Bltb :
- Farith_Big.big_int -> Farith_Big.big_int -> binary_float -> binary_float
- -> bool **)
-
-let coq_Bltb prec emax f1 f2 =
- coq_SFltb (coq_B2SF prec emax f1) (coq_B2SF prec emax f2)
-
-(** val coq_Bleb :
- Farith_Big.big_int -> Farith_Big.big_int -> binary_float -> binary_float
- -> bool **)
-
-let coq_Bleb prec emax f1 f2 =
- coq_SFleb (coq_B2SF prec emax f1) (coq_B2SF prec emax f2)
-
-(** val choice_mode :
- Farith_Big.mode -> bool -> Farith_Big.big_int -> location ->
- Farith_Big.big_int **)
-
-let choice_mode m sx mx lx =
- match m with
- | Farith_Big.NE -> cond_incr (round_N (Pervasives.not (Z.even mx)) lx) mx
- | Farith_Big.ZR -> mx
- | Farith_Big.DN -> cond_incr (round_sign_DN sx lx) mx
- | Farith_Big.UP -> cond_incr (round_sign_UP sx lx) mx
- | Farith_Big.NA -> cond_incr (round_N true lx) mx
-
-(** val overflow_to_inf : Farith_Big.mode -> bool -> bool **)
-
-let overflow_to_inf m s =
- match m with
- | Farith_Big.ZR -> false
- | Farith_Big.DN -> s
- | Farith_Big.UP -> Pervasives.not s
- | _ -> true
-
-(** val binary_overflow :
- Farith_Big.big_int -> Farith_Big.big_int -> Farith_Big.mode -> bool ->
- spec_float **)
-
-let binary_overflow prec emax m s =
- if overflow_to_inf m s
- then S754_infinity s
- else S754_finite (s,
- (Z.to_pos
- (Farith_Big.sub (Z.pow (Farith_Big.double Farith_Big.one) prec)
- Farith_Big.one)), (Farith_Big.sub emax prec))
-
-(** val binary_fit_aux :
- Farith_Big.big_int -> Farith_Big.big_int -> Farith_Big.mode -> bool ->
- Farith_Big.big_int -> Farith_Big.big_int -> spec_float **)
-
-let binary_fit_aux prec emax mode0 sx mx ex =
- if Farith_Big.le ex (Farith_Big.sub emax prec)
- then S754_finite (sx, mx, ex)
- else binary_overflow prec emax mode0 sx
-
-(** val binary_round_aux :
- Farith_Big.big_int -> Farith_Big.big_int -> Farith_Big.mode -> bool ->
- Farith_Big.big_int -> Farith_Big.big_int -> location -> spec_float **)
-
-let binary_round_aux prec emax mode0 sx mx ex lx =
- let (mrs', e') = shr_fexp prec emax mx ex lx in
- let (mrs'', e'') =
- shr_fexp prec emax
- (choice_mode mode0 sx mrs'.shr_m (loc_of_shr_record mrs')) e'
- Coq_loc_Exact
- in
- (Farith_Big.z_case
- (fun _ -> S754_zero sx)
- (fun m -> binary_fit_aux prec emax mode0 sx m e'')
- (fun _ -> S754_nan)
- mrs''.shr_m)
-
-(** val coq_Bmult :
- Farith_Big.big_int -> Farith_Big.big_int -> Farith_Big.mode ->
- binary_float -> binary_float -> binary_float **)
-
-let coq_Bmult prec emax m x y =
- match x with
- | B754_zero sx ->
- (match y with
- | B754_zero sy -> B754_zero (xorb sx sy)
- | B754_finite (sy, _, _) -> B754_zero (xorb sx sy)
- | _ -> B754_nan)
- | B754_infinity sx ->
- (match y with
- | B754_infinity sy -> B754_infinity (xorb sx sy)
- | B754_finite (sy, _, _) -> B754_infinity (xorb sx sy)
- | _ -> B754_nan)
- | B754_nan -> B754_nan
- | B754_finite (sx, mx, ex) ->
- (match y with
- | B754_zero sy -> B754_zero (xorb sx sy)
- | B754_infinity sy -> B754_infinity (xorb sx sy)
- | B754_nan -> B754_nan
- | B754_finite (sy, my, ey) ->
- coq_SF2B prec emax
- (binary_round_aux prec emax m (xorb sx sy) (Farith_Big.mult mx my)
- (Farith_Big.add ex ey) Coq_loc_Exact))
-
-(** val shl_align_fexp :
- Farith_Big.big_int -> Farith_Big.big_int -> Farith_Big.big_int ->
- Farith_Big.big_int -> Farith_Big.big_int * Farith_Big.big_int **)
-
-let shl_align_fexp prec emax mx ex =
- shl_align mx ex (fexp prec emax (Farith_Big.add (digits2_pos mx) ex))
-
-(** val binary_round :
- Farith_Big.big_int -> Farith_Big.big_int -> Farith_Big.mode -> bool ->
- Farith_Big.big_int -> Farith_Big.big_int -> spec_float **)
-
-let binary_round prec emax m sx mx ex =
- let (mz, ez) = shl_align_fexp prec emax mx ex in
- binary_round_aux prec emax m sx mz ez Coq_loc_Exact
-
-(** val binary_normalize :
- Farith_Big.big_int -> Farith_Big.big_int -> Farith_Big.mode ->
- Farith_Big.big_int -> Farith_Big.big_int -> bool -> binary_float **)
-
-let binary_normalize prec emax mode0 m e szero =
- Farith_Big.z_case
- (fun _ -> B754_zero szero)
- (fun m0 ->
- coq_SF2B prec emax (binary_round prec emax mode0 false m0 e))
- (fun m0 -> coq_SF2B prec emax (binary_round prec emax mode0 true m0 e))
- m
-
-(** val coq_Fplus_naive :
- bool -> Farith_Big.big_int -> Farith_Big.big_int -> bool ->
- Farith_Big.big_int -> Farith_Big.big_int -> Farith_Big.big_int ->
- Farith_Big.big_int **)
-
-let coq_Fplus_naive sx mx ex sy my ey ez =
- Farith_Big.add (cond_Zopp sx (Pervasives.fst (shl_align mx ex ez)))
- (cond_Zopp sy (Pervasives.fst (shl_align my ey ez)))
-
-(** val coq_Bplus :
- Farith_Big.big_int -> Farith_Big.big_int -> Farith_Big.mode ->
- binary_float -> binary_float -> binary_float **)
-
-let coq_Bplus prec emax m x y =
- match x with
- | B754_zero sx ->
- (match y with
- | B754_zero sy ->
- if eqb sx sy
- then x
- else (match m with
- | Farith_Big.DN -> B754_zero true
- | _ -> B754_zero false)
- | B754_nan -> B754_nan
- | _ -> y)
- | B754_infinity sx ->
- (match y with
- | B754_infinity sy -> if eqb sx sy then x else B754_nan
- | B754_nan -> B754_nan
- | _ -> x)
- | B754_nan -> B754_nan
- | B754_finite (sx, mx, ex) ->
- (match y with
- | B754_zero _ -> x
- | B754_infinity _ -> y
- | B754_nan -> B754_nan
- | B754_finite (sy, my, ey) ->
- let ez = Farith_Big.min ex ey in
- binary_normalize prec emax m (coq_Fplus_naive sx mx ex sy my ey ez) ez
- (match m with
- | Farith_Big.DN -> true
- | _ -> false))
-
-(** val coq_Bminus :
- Farith_Big.big_int -> Farith_Big.big_int -> Farith_Big.mode ->
- binary_float -> binary_float -> binary_float **)
-
-let coq_Bminus prec emax m x y =
- match x with
- | B754_zero sx ->
- (match y with
- | B754_zero sy ->
- if eqb sx (Pervasives.not sy)
- then x
- else (match m with
- | Farith_Big.DN -> B754_zero true
- | _ -> B754_zero false)
- | B754_infinity sy -> B754_infinity (Pervasives.not sy)
- | B754_nan -> B754_nan
- | B754_finite (sy, my, ey) -> B754_finite ((Pervasives.not sy), my, ey))
- | B754_infinity sx ->
- (match y with
- | B754_infinity sy -> if eqb sx (Pervasives.not sy) then x else B754_nan
- | B754_nan -> B754_nan
- | _ -> x)
- | B754_nan -> B754_nan
- | B754_finite (sx, mx, ex) ->
- (match y with
- | B754_zero _ -> x
- | B754_infinity sy -> B754_infinity (Pervasives.not sy)
- | B754_nan -> B754_nan
- | B754_finite (sy, my, ey) ->
- let ez = Farith_Big.min ex ey in
- binary_normalize prec emax m
- (coq_Fplus_naive sx mx ex (Pervasives.not sy) my ey ez) ez
- (match m with
- | Farith_Big.DN -> true
- | _ -> false))
-
-(** val coq_Bfma_szero :
- Farith_Big.big_int -> Farith_Big.big_int -> Farith_Big.mode ->
- binary_float -> binary_float -> binary_float -> bool **)
-
-let coq_Bfma_szero prec emax m x y z =
- let s_xy = xorb (coq_Bsign prec emax x) (coq_Bsign prec emax y) in
- if eqb s_xy (coq_Bsign prec emax z)
- then s_xy
- else (match m with
- | Farith_Big.DN -> true
- | _ -> false)
-
-(** val coq_Bfma :
- Farith_Big.big_int -> Farith_Big.big_int -> Farith_Big.mode ->
- binary_float -> binary_float -> binary_float -> binary_float **)
-
-let coq_Bfma prec emax m x y z =
- match x with
- | B754_zero _ ->
- (match y with
- | B754_zero _ ->
- (match z with
- | B754_zero _ -> B754_zero (coq_Bfma_szero prec emax m x y z)
- | B754_nan -> B754_nan
- | _ -> z)
- | B754_finite (_, _, _) ->
- (match z with
- | B754_zero _ -> B754_zero (coq_Bfma_szero prec emax m x y z)
- | B754_nan -> B754_nan
- | _ -> z)
- | _ -> B754_nan)
- | B754_infinity sx ->
- (match y with
- | B754_infinity sy ->
- let s = xorb sx sy in
- (match z with
- | B754_infinity sz -> if eqb s sz then z else B754_nan
- | B754_nan -> B754_nan
- | _ -> B754_infinity s)
- | B754_finite (sy, _, _) ->
- let s = xorb sx sy in
- (match z with
- | B754_infinity sz -> if eqb s sz then z else B754_nan
- | B754_nan -> B754_nan
- | _ -> B754_infinity s)
- | _ -> B754_nan)
- | B754_nan -> B754_nan
- | B754_finite (sx, mx, ex) ->
- (match y with
- | B754_zero _ ->
- (match z with
- | B754_zero _ -> B754_zero (coq_Bfma_szero prec emax m x y z)
- | B754_nan -> B754_nan
- | _ -> z)
- | B754_infinity sy ->
- let s = xorb sx sy in
- (match z with
- | B754_infinity sz -> if eqb s sz then z else B754_nan
- | B754_nan -> B754_nan
- | _ -> B754_infinity s)
- | B754_nan -> B754_nan
- | B754_finite (sy, my, ey) ->
- (match z with
- | B754_zero _ ->
- let x0 = { coq_Fnum = (cond_Zopp sx mx); coq_Fexp = ex } in
- let y0 = { coq_Fnum = (cond_Zopp sy my); coq_Fexp = ey } in
- let { coq_Fnum = mr; coq_Fexp = er } = coq_Fmult radix2 x0 y0 in
- binary_normalize prec emax m mr er
- (coq_Bfma_szero prec emax m x y z)
- | B754_infinity _ -> z
- | B754_nan -> B754_nan
- | B754_finite (sz, mz, ez) ->
- let x0 = { coq_Fnum = (cond_Zopp sx mx); coq_Fexp = ex } in
- let y0 = { coq_Fnum = (cond_Zopp sy my); coq_Fexp = ey } in
- let z0 = { coq_Fnum = (cond_Zopp sz mz); coq_Fexp = ez } in
- let { coq_Fnum = mr; coq_Fexp = er } =
- coq_Fplus radix2 (coq_Fmult radix2 x0 y0) z0
- in
- binary_normalize prec emax m mr er
- (coq_Bfma_szero prec emax m x y z)))
-
-(** val coq_Bdiv :
- Farith_Big.big_int -> Farith_Big.big_int -> Farith_Big.mode ->
- binary_float -> binary_float -> binary_float **)
-
-let coq_Bdiv prec emax m x y =
- match x with
- | B754_zero sx ->
- (match y with
- | B754_infinity sy -> B754_zero (xorb sx sy)
- | B754_finite (sy, _, _) -> B754_zero (xorb sx sy)
- | _ -> B754_nan)
- | B754_infinity sx ->
- (match y with
- | B754_zero sy -> B754_infinity (xorb sx sy)
- | B754_finite (sy, _, _) -> B754_infinity (xorb sx sy)
- | _ -> B754_nan)
- | B754_nan -> B754_nan
- | B754_finite (sx, mx, ex) ->
- (match y with
- | B754_zero sy -> B754_infinity (xorb sx sy)
- | B754_infinity sy -> B754_zero (xorb sx sy)
- | B754_nan -> B754_nan
- | B754_finite (sy, my, ey) ->
- coq_SF2B prec emax
- (let (p, lz) = coq_SFdiv_core_binary prec emax mx ex my ey in
- let (mz, ez) = p in
- binary_round_aux prec emax m (xorb sx sy) mz ez lz))
-
-(** val coq_Bsqrt :
- Farith_Big.big_int -> Farith_Big.big_int -> Farith_Big.mode ->
- binary_float -> binary_float **)
-
-let coq_Bsqrt prec emax m x = match x with
-| B754_zero _ -> x
-| B754_infinity s -> if s then B754_nan else x
-| B754_nan -> B754_nan
-| B754_finite (sx, mx, ex) ->
- if sx
- then B754_nan
- else coq_SF2B prec emax
- (let (p, lz) = coq_SFsqrt_core_binary prec emax mx ex in
- let (mz, ez) = p in binary_round_aux prec emax m false mz ez lz)
-
-(** val coq_Bmax_float :
- Farith_Big.big_int -> Farith_Big.big_int -> binary_float **)
-
-let coq_Bmax_float prec emax =
- coq_SF2B prec emax (S754_finite (false,
- (Pos.sub (shift_pos (Z.to_pos prec) Farith_Big.one) Farith_Big.one),
- (Farith_Big.sub emax prec)))
diff --git a/farith2/extracted/BinarySingleNaN.mli b/farith2/extracted/BinarySingleNaN.mli
deleted file mode 100644
index e0e17fd98..000000000
--- a/farith2/extracted/BinarySingleNaN.mli
+++ /dev/null
@@ -1,110 +0,0 @@
-open BinInt
-open BinPos
-open Bool
-open Datatypes
-open Defs
-open Operations
-open Round
-open SpecFloat
-open Zaux
-open Zpower
-
-type binary_float =
-| B754_zero of bool
-| B754_infinity of bool
-| B754_nan
-| B754_finite of bool * Farith_Big.big_int * Farith_Big.big_int
-
-val coq_SF2B :
- Farith_Big.big_int -> Farith_Big.big_int -> spec_float -> binary_float
-
-val coq_B2SF :
- Farith_Big.big_int -> Farith_Big.big_int -> binary_float -> spec_float
-
-val coq_Bsign :
- Farith_Big.big_int -> Farith_Big.big_int -> binary_float -> bool
-
-val is_nan : Farith_Big.big_int -> Farith_Big.big_int -> binary_float -> bool
-
-val coq_Bopp :
- Farith_Big.big_int -> Farith_Big.big_int -> binary_float -> binary_float
-
-val coq_Babs :
- Farith_Big.big_int -> Farith_Big.big_int -> binary_float -> binary_float
-
-val coq_Beqb :
- Farith_Big.big_int -> Farith_Big.big_int -> binary_float -> binary_float ->
- bool
-
-val coq_Bltb :
- Farith_Big.big_int -> Farith_Big.big_int -> binary_float -> binary_float ->
- bool
-
-val coq_Bleb :
- Farith_Big.big_int -> Farith_Big.big_int -> binary_float -> binary_float ->
- bool
-
-val choice_mode :
- Farith_Big.mode -> bool -> Farith_Big.big_int -> location ->
- Farith_Big.big_int
-
-val overflow_to_inf : Farith_Big.mode -> bool -> bool
-
-val binary_overflow :
- Farith_Big.big_int -> Farith_Big.big_int -> Farith_Big.mode -> bool ->
- spec_float
-
-val binary_fit_aux :
- Farith_Big.big_int -> Farith_Big.big_int -> Farith_Big.mode -> bool ->
- Farith_Big.big_int -> Farith_Big.big_int -> spec_float
-
-val binary_round_aux :
- Farith_Big.big_int -> Farith_Big.big_int -> Farith_Big.mode -> bool ->
- Farith_Big.big_int -> Farith_Big.big_int -> location -> spec_float
-
-val coq_Bmult :
- Farith_Big.big_int -> Farith_Big.big_int -> Farith_Big.mode -> binary_float
- -> binary_float -> binary_float
-
-val shl_align_fexp :
- Farith_Big.big_int -> Farith_Big.big_int -> Farith_Big.big_int ->
- Farith_Big.big_int -> Farith_Big.big_int * Farith_Big.big_int
-
-val binary_round :
- Farith_Big.big_int -> Farith_Big.big_int -> Farith_Big.mode -> bool ->
- Farith_Big.big_int -> Farith_Big.big_int -> spec_float
-
-val binary_normalize :
- Farith_Big.big_int -> Farith_Big.big_int -> Farith_Big.mode ->
- Farith_Big.big_int -> Farith_Big.big_int -> bool -> binary_float
-
-val coq_Fplus_naive :
- bool -> Farith_Big.big_int -> Farith_Big.big_int -> bool ->
- Farith_Big.big_int -> Farith_Big.big_int -> Farith_Big.big_int ->
- Farith_Big.big_int
-
-val coq_Bplus :
- Farith_Big.big_int -> Farith_Big.big_int -> Farith_Big.mode -> binary_float
- -> binary_float -> binary_float
-
-val coq_Bminus :
- Farith_Big.big_int -> Farith_Big.big_int -> Farith_Big.mode -> binary_float
- -> binary_float -> binary_float
-
-val coq_Bfma_szero :
- Farith_Big.big_int -> Farith_Big.big_int -> Farith_Big.mode -> binary_float
- -> binary_float -> binary_float -> bool
-
-val coq_Bfma :
- Farith_Big.big_int -> Farith_Big.big_int -> Farith_Big.mode -> binary_float
- -> binary_float -> binary_float -> binary_float
-
-val coq_Bdiv :
- Farith_Big.big_int -> Farith_Big.big_int -> Farith_Big.mode -> binary_float
- -> binary_float -> binary_float
-
-val coq_Bsqrt :
- Farith_Big.big_int -> Farith_Big.big_int -> Farith_Big.mode -> binary_float
- -> binary_float
-
-val coq_Bmax_float : Farith_Big.big_int -> Farith_Big.big_int -> binary_float
diff --git a/farith2/extracted/Bits.ml b/farith2/extracted/Bits.ml
deleted file mode 100644
index 072b92a0d..000000000
--- a/farith2/extracted/Bits.ml
+++ /dev/null
@@ -1,103 +0,0 @@
-open BinInt
-open Binary
-open SpecFloat
-
-(** val join_bits :
- Farith_Big.big_int -> Farith_Big.big_int -> bool -> Farith_Big.big_int ->
- Farith_Big.big_int -> Farith_Big.big_int **)
-
-let join_bits mw ew s m e =
- Farith_Big.add
- (Farith_Big.shiftl
- (Farith_Big.add
- (if s
- then Z.pow (Farith_Big.double Farith_Big.one) ew
- else Farith_Big.zero) e) mw) m
-
-(** val split_bits :
- Farith_Big.big_int -> Farith_Big.big_int -> Farith_Big.big_int ->
- (bool * Farith_Big.big_int) * Farith_Big.big_int **)
-
-let split_bits mw ew x =
- let mm = Z.pow (Farith_Big.double Farith_Big.one) mw in
- let em = Z.pow (Farith_Big.double Farith_Big.one) ew in
- (((Farith_Big.le (Farith_Big.mult mm em) x), (Farith_Big.mod_floor x mm)),
- (Farith_Big.mod_floor (Farith_Big.div_floor x mm) em))
-
-(** val bits_of_binary_float :
- Farith_Big.big_int -> Farith_Big.big_int -> binary_float ->
- Farith_Big.big_int **)
-
-let bits_of_binary_float mw ew =
- let prec = Farith_Big.add mw Farith_Big.one in
- let emax =
- Z.pow (Farith_Big.double Farith_Big.one)
- (Farith_Big.sub ew Farith_Big.one)
- in
- (fun x ->
- match x with
- | B754_zero sx -> join_bits mw ew sx Farith_Big.zero Farith_Big.zero
- | B754_infinity sx ->
- join_bits mw ew sx Farith_Big.zero
- (Farith_Big.sub (Z.pow (Farith_Big.double Farith_Big.one) ew)
- Farith_Big.one)
- | B754_nan (sx, plx) ->
- join_bits mw ew sx plx
- (Farith_Big.sub (Z.pow (Farith_Big.double Farith_Big.one) ew)
- Farith_Big.one)
- | B754_finite (sx, mx, ex) ->
- let m = Farith_Big.sub mx (Z.pow (Farith_Big.double Farith_Big.one) mw) in
- if Farith_Big.le Farith_Big.zero m
- then join_bits mw ew sx m
- (Farith_Big.add (Farith_Big.sub ex (emin prec emax))
- Farith_Big.one)
- else join_bits mw ew sx mx Farith_Big.zero)
-
-(** val binary_float_of_bits_aux :
- Farith_Big.big_int -> Farith_Big.big_int -> Farith_Big.big_int ->
- full_float **)
-
-let binary_float_of_bits_aux mw ew =
- let prec = Farith_Big.add mw Farith_Big.one in
- let emax =
- Z.pow (Farith_Big.double Farith_Big.one)
- (Farith_Big.sub ew Farith_Big.one)
- in
- (fun x ->
- let (p, ex) = split_bits mw ew x in
- let (sx, mx) = p in
- if Farith_Big.eq ex Farith_Big.zero
- then (Farith_Big.z_case
- (fun _ -> F754_zero sx)
- (fun px -> F754_finite (sx, px, (emin prec emax)))
- (fun _ -> F754_nan (false, Farith_Big.one))
- mx)
- else if Farith_Big.eq ex
- (Farith_Big.sub (Z.pow (Farith_Big.double Farith_Big.one) ew)
- Farith_Big.one)
- then (Farith_Big.z_case
- (fun _ -> F754_infinity sx)
- (fun plx -> F754_nan (sx, plx))
- (fun _ -> F754_nan (false, Farith_Big.one))
- mx)
- else (Farith_Big.z_case
- (fun _ -> F754_nan (false, Farith_Big.one))
- (fun px -> F754_finite (sx, px,
- (Farith_Big.sub (Farith_Big.add ex (emin prec emax))
- Farith_Big.one)))
- (fun _ -> F754_nan (false,
- Farith_Big.one))
- (Farith_Big.add mx
- (Z.pow (Farith_Big.double Farith_Big.one) mw))))
-
-(** val binary_float_of_bits :
- Farith_Big.big_int -> Farith_Big.big_int -> Farith_Big.big_int ->
- binary_float **)
-
-let binary_float_of_bits mw ew x =
- let prec = Farith_Big.add mw Farith_Big.one in
- let emax =
- Z.pow (Farith_Big.double Farith_Big.one)
- (Farith_Big.sub ew Farith_Big.one)
- in
- coq_FF2B prec emax (binary_float_of_bits_aux mw ew x)
diff --git a/farith2/extracted/Bits.mli b/farith2/extracted/Bits.mli
deleted file mode 100644
index 795221228..000000000
--- a/farith2/extracted/Bits.mli
+++ /dev/null
@@ -1,22 +0,0 @@
-open BinInt
-open Binary
-open SpecFloat
-
-val join_bits :
- Farith_Big.big_int -> Farith_Big.big_int -> bool -> Farith_Big.big_int ->
- Farith_Big.big_int -> Farith_Big.big_int
-
-val split_bits :
- Farith_Big.big_int -> Farith_Big.big_int -> Farith_Big.big_int ->
- (bool * Farith_Big.big_int) * Farith_Big.big_int
-
-val bits_of_binary_float :
- Farith_Big.big_int -> Farith_Big.big_int -> binary_float ->
- Farith_Big.big_int
-
-val binary_float_of_bits_aux :
- Farith_Big.big_int -> Farith_Big.big_int -> Farith_Big.big_int -> full_float
-
-val binary_float_of_bits :
- Farith_Big.big_int -> Farith_Big.big_int -> Farith_Big.big_int ->
- binary_float
diff --git a/farith2/extracted/Bool.ml b/farith2/extracted/Bool.ml
deleted file mode 100644
index 15e4eb09a..000000000
--- a/farith2/extracted/Bool.ml
+++ /dev/null
@@ -1,5 +0,0 @@
-
-(** val eqb : bool -> bool -> bool **)
-
-let eqb b1 b2 =
- if b1 then b2 else if b2 then false else true
diff --git a/farith2/extracted/Bool.mli b/farith2/extracted/Bool.mli
deleted file mode 100644
index 2af28bedb..000000000
--- a/farith2/extracted/Bool.mli
+++ /dev/null
@@ -1,2 +0,0 @@
-
-val eqb : bool -> bool -> bool
diff --git a/farith2/extracted/Datatypes.ml b/farith2/extracted/Datatypes.ml
deleted file mode 100644
index d5c929229..000000000
--- a/farith2/extracted/Datatypes.ml
+++ /dev/null
@@ -1,17 +0,0 @@
-
-(** val xorb : bool -> bool -> bool **)
-
-let xorb b1 b2 =
- if b1 then if b2 then false else true else b2
-
-type comparison =
-| Eq
-| Lt
-| Gt
-
-(** val coq_CompOpp : comparison -> comparison **)
-
-let coq_CompOpp = function
-| Eq -> Eq
-| Lt -> Gt
-| Gt -> Lt
diff --git a/farith2/extracted/Datatypes.mli b/farith2/extracted/Datatypes.mli
deleted file mode 100644
index 32ae55278..000000000
--- a/farith2/extracted/Datatypes.mli
+++ /dev/null
@@ -1,9 +0,0 @@
-
-val xorb : bool -> bool -> bool
-
-type comparison =
-| Eq
-| Lt
-| Gt
-
-val coq_CompOpp : comparison -> comparison
diff --git a/farith2/extracted/Defs.ml b/farith2/extracted/Defs.ml
deleted file mode 100644
index 9337fe2a6..000000000
--- a/farith2/extracted/Defs.ml
+++ /dev/null
@@ -1,2 +0,0 @@
-
-type float = { coq_Fnum : Farith_Big.big_int; coq_Fexp : Farith_Big.big_int }
diff --git a/farith2/extracted/Defs.mli b/farith2/extracted/Defs.mli
deleted file mode 100644
index 9337fe2a6..000000000
--- a/farith2/extracted/Defs.mli
+++ /dev/null
@@ -1,2 +0,0 @@
-
-type float = { coq_Fnum : Farith_Big.big_int; coq_Fexp : Farith_Big.big_int }
diff --git a/farith2/extracted/GenericFloat.ml b/farith2/extracted/GenericFloat.ml
deleted file mode 100644
index 7a517f4fe..000000000
--- a/farith2/extracted/GenericFloat.ml
+++ /dev/null
@@ -1,434 +0,0 @@
-open BinInt
-open Binary
-open BinarySingleNaN
-open Bits
-open Datatypes
-open Interval
-open Op
-open Qextended
-open SpecFloat
-
-type __ = Obj.t
-let __ = let rec f _ = Obj.repr f in Obj.repr f
-
-(** val cprec : Farith_Big.big_int -> Farith_Big.big_int **)
-
-let cprec =
- Farith_Big.succ
-
-(** val cemax : Farith_Big.big_int -> Farith_Big.big_int **)
-
-let cemax ew0 =
- Z.pow (Farith_Big.double Farith_Big.one) (Farith_Big.sub ew0 Farith_Big.one)
-
-(** val check_param : Farith_Big.big_int -> Farith_Big.big_int -> bool **)
-
-let check_param mw0 ew0 =
- (&&)
- ((&&) (Farith_Big.lt Farith_Big.zero mw0)
- (Farith_Big.lt Farith_Big.zero ew0))
- (Farith_Big.lt (cprec mw0) (cemax ew0))
-
-type 'v coq_Generic = { mw : Farith_Big.big_int; ew : Farith_Big.big_int;
- value : 'v }
-
-(** val prec : 'a1 coq_Generic -> Farith_Big.big_int **)
-
-let prec f =
- cprec f.mw
-
-(** val emax : 'a1 coq_Generic -> Farith_Big.big_int **)
-
-let emax f =
- cemax f.ew
-
-(** val mk_generic :
- Farith_Big.big_int -> Farith_Big.big_int -> (Farith_Big.big_int ->
- Farith_Big.big_int -> __ -> __ -> 'a1) -> 'a1 coq_Generic **)
-
-let mk_generic mw0 ew0 x =
- let prec0 = cprec mw0 in
- let emax0 = cemax ew0 in
- { mw = mw0; ew = ew0; value = (x prec0 emax0 __ __) }
-
-(** val same_format_cast :
- Farith_Big.big_int -> Farith_Big.big_int -> Farith_Big.big_int ->
- Farith_Big.big_int -> 'a1 -> 'a1 **)
-
-let same_format_cast _ _ _ _ f =
- f
-
-(** val same_format : 'a1 coq_Generic -> 'a2 coq_Generic -> bool **)
-
-let same_format x y =
- (&&) (Farith_Big.eq (prec x) (prec y)) (Farith_Big.eq (emax x) (emax y))
-
-(** val mk_with : 'a1 coq_Generic -> 'a2 -> 'a2 coq_Generic **)
-
-let mk_with x y =
- { mw = x.mw; ew = x.ew; value = y }
-
-(** val mk_witho : 'a1 coq_Generic -> 'a2 option -> 'a2 coq_Generic option **)
-
-let mk_witho x = function
-| Some r -> Some (mk_with x r)
-| None -> None
-
-module GenericFloat =
- struct
- module Coq__1 = struct
- type t = binary_float coq_Generic
- end
- include Coq__1
-
- module F_inhab =
- struct
- type t = Coq__1.t
-
- (** val dummy : binary_float coq_Generic **)
-
- let dummy =
- { mw = (Farith_Big.double (Farith_Big.double (Farith_Big.double
- (Farith_Big.succ_double Farith_Big.one)))); ew = (Farith_Big.double
- (Farith_Big.double (Farith_Big.double (Farith_Big.double
- (Farith_Big.double (Farith_Big.double (Farith_Big.double
- Farith_Big.one))))))); value = B754_nan }
- end
-
- module AssertF = Assert.Assert(F_inhab)
-
- module B_inhab =
- struct
- type t = bool
-
- (** val dummy : bool **)
-
- let dummy =
- true
- end
-
- module AssertB = Assert.Assert(B_inhab)
-
- (** val of_q' :
- Farith_Big.big_int -> Farith_Big.big_int -> Farith_Big.mode -> Q.t ->
- binary_float **)
-
- let of_q' prec0 emax0 m q =
- match Q.classify q with
- | Q.INF -> B754_infinity false
- | Q.MINF -> B754_infinity true
- | Q.UNDEF -> B754_nan
- | Q.ZERO -> B754_zero false
- | Q.NZERO ->
- (Farith_Big.z_case
- (fun _ -> B754_nan)
- (fun pn ->
- coq_SF2B prec0 emax0
- (let (p, lz) =
- coq_SFdiv_core_binary prec0 emax0 pn Farith_Big.zero
- (Z.to_pos (Farith_Big.q_den q)) Farith_Big.zero
- in
- let (mz, ez) = p in
- binary_round_aux prec0 emax0 m (xorb false false) mz ez lz))
- (fun nn ->
- coq_SF2B prec0 emax0
- (let (p, lz) =
- coq_SFdiv_core_binary prec0 emax0 nn Farith_Big.zero
- (Z.to_pos (Farith_Big.q_den q)) Farith_Big.zero
- in
- let (mz, ez) = p in
- binary_round_aux prec0 emax0 m (xorb true false) mz ez lz))
- (Farith_Big.q_num q))
-
- (** val of_q :
- Farith_Big.big_int -> Farith_Big.big_int -> Farith_Big.mode -> Q.t -> t **)
-
- let of_q mw0 ew0 m q =
- (fun x f -> assert x; f ()) (check_param mw0 ew0) (fun _ ->
- mk_generic mw0 ew0 (fun prec0 emax0 _ _ -> of_q' prec0 emax0 m q))
-
- (** val add : Farith_Big.mode -> t -> t -> t **)
-
- let add m x y =
- (fun x f -> assert x; f ()) (same_format x y) (fun _ ->
- mk_with x
- (coq_Bplus (cprec x.mw) (cemax x.ew) m x.value
- (same_format_cast (prec x) (emax x) (prec y) (emax y) y.value)))
-
- (** val sub : Farith_Big.mode -> t -> t -> t **)
-
- let sub m x y =
- (fun x f -> assert x; f ()) (same_format x y) (fun _ ->
- mk_with x
- (coq_Bminus (cprec x.mw) (cemax x.ew) m x.value
- (same_format_cast (prec x) (emax x) (prec y) (emax y) y.value)))
-
- (** val mul : Farith_Big.mode -> t -> t -> t **)
-
- let mul m x y =
- (fun x f -> assert x; f ()) (same_format x y) (fun _ ->
- mk_with x
- (coq_Bmult (cprec x.mw) (cemax x.ew) m x.value
- (same_format_cast (prec x) (emax x) (prec y) (emax y) y.value)))
-
- (** val div : Farith_Big.mode -> t -> t -> t **)
-
- let div m x y =
- (fun x f -> assert x; f ()) (same_format x y) (fun _ ->
- mk_with x
- (coq_Bdiv (cprec x.mw) (cemax x.ew) m x.value
- (same_format_cast (prec x) (emax x) (prec y) (emax y) y.value)))
-
- (** val fma : Farith_Big.mode -> t -> t -> t -> t **)
-
- let fma m x y z =
- (fun x f -> assert x; f ()) ((&&) (same_format x y) (same_format x z))
- (fun _ ->
- mk_with x
- (coq_Bfma (cprec x.mw) (cemax x.ew) m x.value
- (same_format_cast (cprec x.mw) (cemax x.ew) (cprec y.mw)
- (cemax y.ew) y.value)
- (same_format_cast (cprec x.mw) (cemax x.ew) (cprec z.mw)
- (cemax z.ew) z.value)))
-
- (** val sqrt : Farith_Big.mode -> t -> t **)
-
- let sqrt m x =
- mk_with x (coq_Bsqrt (cprec x.mw) (cemax x.ew) m x.value)
-
- (** val abs : t -> t **)
-
- let abs x =
- mk_with x (coq_Babs (cprec x.mw) (cemax x.ew) x.value)
-
- (** val succ : t -> t **)
-
- let succ x =
- mk_with x (coq_Fsucc (cprec x.mw) (cemax x.ew) x.value)
-
- (** val pred : t -> t **)
-
- let pred x =
- mk_with x (coq_Fpred (cprec x.mw) (cemax x.ew) x.value)
-
- (** val neg : t -> t **)
-
- let neg x =
- mk_with x (coq_Fneg (cprec x.mw) (cemax x.ew) x.value)
-
- (** val least_bit_Pnat : Farith_Big.big_int -> Farith_Big.big_int **)
-
- let rec least_bit_Pnat n =
- Farith_Big.positive_case
- (fun _ -> Farith_Big.zero)
- (fun p -> Farith_Big.succ (least_bit_Pnat p))
- (fun _ -> Farith_Big.zero)
- n
-
- (** val shiftr_pos :
- Farith_Big.big_int -> Farith_Big.big_int -> Farith_Big.big_int **)
-
- let shiftr_pos a p =
- Farith_Big.nat_rect a (fun _ -> Farith_Big.div2_floor) p
-
- (** val to_q : t -> Q.t **)
-
- let to_q f =
- match f.value with
- | B754_zero _ -> coq_Qx_zero
- | B754_infinity b -> if b then coq_Qx_minus_inf else coq_Qx_inf
- | B754_nan -> coq_Qx_undef
- | B754_finite (b, m, e) ->
- let e' = least_bit_Pnat m in
- let m' = if b then Farith_Big.opp m else m in
- let e'' = Farith_Big.add e (Farith_Big.identity e') in
- (Farith_Big.z_case
- (fun _ -> Farith_Big.q_mk ((shiftr_pos m' e'),
- Farith_Big.one))
- (fun _ -> Farith_Big.q_mk ((Farith_Big.shiftl m' e),
- Farith_Big.one))
- (fun p -> Farith_Big.q_mk ((shiftr_pos m' e'),
- (Farith_Big.shiftl Farith_Big.one p)))
- e'')
-
- (** val le : t -> t -> bool **)
-
- let le x y =
- (fun x f -> assert x; f ()) (same_format x y) (fun _ ->
- coq_Bleb (cprec x.mw) (cemax x.ew) x.value
- (same_format_cast (prec x) (emax x) (prec y) (emax y) y.value))
-
- (** val lt : t -> t -> bool **)
-
- let lt x y =
- (fun x f -> assert x; f ()) (same_format x y) (fun _ ->
- coq_Bltb (cprec x.mw) (cemax x.ew) x.value
- (same_format_cast (prec x) (emax x) (prec y) (emax y) y.value))
-
- (** val eq : t -> t -> bool **)
-
- let eq x y =
- (fun x f -> assert x; f ()) (same_format x y) (fun _ ->
- coq_Beqb (cprec x.mw) (cemax x.ew) x.value
- (same_format_cast (prec x) (emax x) (prec y) (emax y) y.value))
-
- (** val ge : t -> t -> bool **)
-
- let ge x y =
- (fun x f -> assert x; f ()) (same_format x y) (fun _ ->
- coq_Bleb (cprec x.mw) (cemax x.ew)
- (same_format_cast (prec x) (emax x) (prec y) (emax y) y.value) x.value)
-
- (** val gt : t -> t -> bool **)
-
- let gt x y =
- (fun x f -> assert x; f ()) (same_format x y) (fun _ ->
- coq_Bltb (cprec x.mw) (cemax x.ew)
- (same_format_cast (prec x) (emax x) (prec y) (emax y) y.value) x.value)
-
- (** val of_bits' :
- Farith_Big.big_int -> Farith_Big.big_int -> Farith_Big.big_int ->
- binary_float **)
-
- let of_bits' mw0 ew0 b =
- let filtered_var = binary_float_of_bits mw0 ew0 b in
- (match filtered_var with
- | Binary.B754_zero s -> B754_zero s
- | Binary.B754_infinity s -> B754_infinity s
- | Binary.B754_nan (_, _) -> B754_nan
- | Binary.B754_finite (s, m, e) -> B754_finite (s, m, e))
-
- (** val of_bits : Farith_Big.big_int -> Farith_Big.big_int -> Z.t -> t **)
-
- let of_bits mw0 ew0 z =
- (fun x f -> assert x; f ()) (check_param mw0 ew0) (fun _ -> { mw = mw0;
- ew = ew0; value = (of_bits' mw0 ew0 z) })
-
- (** val pl_cst : Farith_Big.big_int -> Farith_Big.big_int **)
-
- let pl_cst mw0 =
- Farith_Big.iter_nat (fun x -> Farith_Big.double x)
- (Z.to_nat (Farith_Big.pred mw0)) Farith_Big.one
-
- (** val to_bits : t -> Farith_Big.big_int **)
-
- let to_bits f =
- match f.value with
- | B754_zero s -> bits_of_binary_float f.mw f.ew (Binary.B754_zero s)
- | B754_infinity s ->
- bits_of_binary_float f.mw f.ew (Binary.B754_infinity s)
- | B754_nan ->
- bits_of_binary_float f.mw f.ew (Binary.B754_nan (true, (pl_cst f.mw)))
- | B754_finite (s, m, e) ->
- bits_of_binary_float f.mw f.ew (Binary.B754_finite (s, m, e))
-
- (** val nan : Farith_Big.big_int -> Farith_Big.big_int -> t **)
-
- let nan mw0 ew0 =
- (fun x f -> assert x; f ()) (check_param mw0 ew0) (fun _ ->
- mk_generic mw0 ew0 (fun _ _ _ _ -> B754_nan))
-
- (** val zero : Farith_Big.big_int -> Farith_Big.big_int -> bool -> t **)
-
- let zero mw0 ew0 b =
- (fun x f -> assert x; f ()) (check_param mw0 ew0) (fun _ ->
- mk_generic mw0 ew0 (fun _ _ _ _ -> B754_zero b))
-
- (** val inf : Farith_Big.big_int -> Farith_Big.big_int -> bool -> t **)
-
- let inf mw0 ew0 b =
- (fun x f -> assert x; f ()) (check_param mw0 ew0) (fun _ ->
- mk_generic mw0 ew0 (fun _ _ _ _ -> B754_infinity b))
- end
-
-module GenericInterval =
- struct
- module Coq__2 = struct
- type t = coq_Interval coq_Generic
- end
- include Coq__2
-
- module I_inhab =
- struct
- type t = Coq__2.t
-
- (** val dummy : t **)
-
- let dummy =
- { mw = (Farith_Big.succ_double (Farith_Big.succ_double
- (Farith_Big.succ_double (Farith_Big.double Farith_Big.one)))); ew =
- (Farith_Big.double (Farith_Big.double (Farith_Big.double
- Farith_Big.one))); value = (Intv ((B754_infinity true),
- (B754_infinity false), true)) }
- end
-
- module AssertI = Assert.Assert(I_inhab)
-
- module O_inhab =
- struct
- type t = Coq__2.t option
-
- (** val dummy : t **)
-
- let dummy =
- None
- end
-
- module AssertO = Assert.Assert(O_inhab)
-
- (** val inter : t -> t -> t option **)
-
- let inter x y =
- (fun x f -> assert x; f ()) (same_format x y) (fun _ ->
- let r =
- inter (prec x) (emax x) x.value
- (same_format_cast (prec x) (emax x) (prec y) (emax y) y.value)
- in
- (match r with
- | Some r0 -> Some (mk_with x r0)
- | None -> None))
-
- (** val add : Farith_Big.mode -> t -> t -> t **)
-
- let add m x y =
- (fun x f -> assert x; f ()) (same_format x y) (fun _ ->
- mk_with x
- (coq_Iadd (prec x) (emax x) m x.value
- (same_format_cast (prec x) (emax x) (prec y) (emax y) y.value)))
-
- (** val ge : t -> t option **)
-
- let ge x =
- mk_witho x (coq_Ige (prec x) (emax x) x.value)
-
- (** val gt : t -> t option **)
-
- let gt x =
- mk_witho x (coq_Igt (prec x) (emax x) x.value)
-
- (** val le : t -> t option **)
-
- let le x =
- mk_witho x (coq_Ile (prec x) (emax x) x.value)
-
- (** val lt : t -> t option **)
-
- let lt x =
- mk_witho x (coq_Ilt (prec x) (emax x) x.value)
-
- (** val singleton : GenericFloat.t -> t **)
-
- let singleton x =
- mk_with x (singleton (cprec x.mw) (cemax x.ew) x.value)
-
- (** val is_singleton : t -> GenericFloat.t option **)
-
- let is_singleton x =
- mk_witho x (is_singleton (cprec x.mw) (cemax x.ew) x.value)
-
- (** val top : Farith_Big.big_int -> Farith_Big.big_int -> t **)
-
- let top mw0 ew0 =
- (fun x f -> assert x; f ()) (check_param mw0 ew0) (fun _ ->
- mk_generic mw0 ew0 (fun prec0 emax0 _ _ -> top prec0 emax0))
- end
diff --git a/farith2/extracted/GenericFloat.mli b/farith2/extracted/GenericFloat.mli
deleted file mode 100644
index 184d37efd..000000000
--- a/farith2/extracted/GenericFloat.mli
+++ /dev/null
@@ -1,176 +0,0 @@
-open BinInt
-open Binary
-open BinarySingleNaN
-open Bits
-open Datatypes
-open Interval
-open Op
-open Qextended
-open SpecFloat
-
-type __ = Obj.t
-
-val cprec : Farith_Big.big_int -> Farith_Big.big_int
-
-val cemax : Farith_Big.big_int -> Farith_Big.big_int
-
-val check_param : Farith_Big.big_int -> Farith_Big.big_int -> bool
-
-type 'v coq_Generic = { mw : Farith_Big.big_int; ew : Farith_Big.big_int;
- value : 'v }
-
-val prec : 'a1 coq_Generic -> Farith_Big.big_int
-
-val emax : 'a1 coq_Generic -> Farith_Big.big_int
-
-val mk_generic :
- Farith_Big.big_int -> Farith_Big.big_int -> (Farith_Big.big_int ->
- Farith_Big.big_int -> __ -> __ -> 'a1) -> 'a1 coq_Generic
-
-val same_format_cast :
- Farith_Big.big_int -> Farith_Big.big_int -> Farith_Big.big_int ->
- Farith_Big.big_int -> 'a1 -> 'a1
-
-val same_format : 'a1 coq_Generic -> 'a2 coq_Generic -> bool
-
-val mk_with : 'a1 coq_Generic -> 'a2 -> 'a2 coq_Generic
-
-val mk_witho : 'a1 coq_Generic -> 'a2 option -> 'a2 coq_Generic option
-
-module GenericFloat :
- sig
- module Coq__1 : sig
- type t = binary_float coq_Generic
- end
- include module type of struct include Coq__1 end
-
- module F_inhab :
- sig
- type t = Coq__1.t
-
- val dummy : binary_float coq_Generic
- end
-
- module AssertF :
- sig
- end
-
- module B_inhab :
- sig
- type t = bool
-
- val dummy : bool
- end
-
- module AssertB :
- sig
- end
-
- val of_q' :
- Farith_Big.big_int -> Farith_Big.big_int -> Farith_Big.mode -> Q.t ->
- binary_float
-
- val of_q :
- Farith_Big.big_int -> Farith_Big.big_int -> Farith_Big.mode -> Q.t -> t
-
- val add : Farith_Big.mode -> t -> t -> t
-
- val sub : Farith_Big.mode -> t -> t -> t
-
- val mul : Farith_Big.mode -> t -> t -> t
-
- val div : Farith_Big.mode -> t -> t -> t
-
- val fma : Farith_Big.mode -> t -> t -> t -> t
-
- val sqrt : Farith_Big.mode -> t -> t
-
- val abs : t -> t
-
- val succ : t -> t
-
- val pred : t -> t
-
- val neg : t -> t
-
- val least_bit_Pnat : Farith_Big.big_int -> Farith_Big.big_int
-
- val shiftr_pos :
- Farith_Big.big_int -> Farith_Big.big_int -> Farith_Big.big_int
-
- val to_q : t -> Q.t
-
- val le : t -> t -> bool
-
- val lt : t -> t -> bool
-
- val eq : t -> t -> bool
-
- val ge : t -> t -> bool
-
- val gt : t -> t -> bool
-
- val of_bits' :
- Farith_Big.big_int -> Farith_Big.big_int -> Farith_Big.big_int ->
- binary_float
-
- val of_bits : Farith_Big.big_int -> Farith_Big.big_int -> Z.t -> t
-
- val pl_cst : Farith_Big.big_int -> Farith_Big.big_int
-
- val to_bits : t -> Farith_Big.big_int
-
- val nan : Farith_Big.big_int -> Farith_Big.big_int -> t
-
- val zero : Farith_Big.big_int -> Farith_Big.big_int -> bool -> t
-
- val inf : Farith_Big.big_int -> Farith_Big.big_int -> bool -> t
- end
-
-module GenericInterval :
- sig
- module Coq__2 : sig
- type t = coq_Interval coq_Generic
- end
- include module type of struct include Coq__2 end
-
- module I_inhab :
- sig
- type t = Coq__2.t
-
- val dummy : t
- end
-
- module AssertI :
- sig
- end
-
- module O_inhab :
- sig
- type t = Coq__2.t option
-
- val dummy : t
- end
-
- module AssertO :
- sig
- end
-
- val inter : t -> t -> t option
-
- val add : Farith_Big.mode -> t -> t -> t
-
- val ge : t -> t option
-
- val gt : t -> t option
-
- val le : t -> t option
-
- val lt : t -> t option
-
- val singleton : GenericFloat.t -> t
-
- val is_singleton : t -> GenericFloat.t option
-
- val top : Farith_Big.big_int -> Farith_Big.big_int -> t
- end
diff --git a/farith2/extracted/Interval.ml b/farith2/extracted/Interval.ml
deleted file mode 100644
index 8f35f75cb..000000000
--- a/farith2/extracted/Interval.ml
+++ /dev/null
@@ -1,137 +0,0 @@
-open BinarySingleNaN
-open Utils
-
-type float = binary_float
-
-type coq_Interval' =
-| Inan
-| Intv of float * float * bool
-
-type coq_Interval = coq_Interval'
-
-type coq_Interval_opt = coq_Interval option
-
-(** val to_Interval_opt :
- Farith_Big.big_int -> Farith_Big.big_int -> coq_Interval' option ->
- coq_Interval_opt **)
-
-let to_Interval_opt _ _ = function
-| Some j -> Some j
-| None -> None
-
-(** val top : Farith_Big.big_int -> Farith_Big.big_int -> coq_Interval **)
-
-let top _ _ =
- Intv ((B754_infinity true), (B754_infinity false), true)
-
-(** val is_singleton :
- Farith_Big.big_int -> Farith_Big.big_int -> coq_Interval -> float option **)
-
-let is_singleton prec emax = function
-| Inan -> Some B754_nan
-| Intv (a, b, n) ->
- if (&&)
- ((&&) (coq_Beqb prec emax a b)
- (Pervasives.not (coq_Beqb prec emax a (B754_zero false))))
- (Pervasives.not n)
- then Some a
- else None
-
-(** val singleton :
- Farith_Big.big_int -> Farith_Big.big_int -> float -> coq_Interval **)
-
-let singleton _ _ x = match x with
-| B754_nan -> Inan
-| _ -> Intv (x, x, false)
-
-(** val inter' :
- Farith_Big.big_int -> Farith_Big.big_int -> coq_Interval' ->
- coq_Interval' -> coq_Interval' option **)
-
-let inter' prec emax i1 i2 =
- match i1 with
- | Inan ->
- (match i2 with
- | Inan -> Some Inan
- | Intv (_, _, nan) -> if nan then Some Inan else None)
- | Intv (lo1, hi1, nan1) ->
- (match i2 with
- | Inan -> if nan1 then Some Inan else None
- | Intv (lo2, hi2, nan2) ->
- if (||) (coq_Bltb prec emax hi1 lo2) (coq_Bltb prec emax hi2 lo1)
- then if (&&) nan1 nan2 then Some Inan else None
- else Some (Intv ((coq_Bmax prec emax lo1 lo2),
- (coq_Bmin prec emax hi1 hi2), ((&&) nan1 nan2))))
-
-(** val inter :
- Farith_Big.big_int -> Farith_Big.big_int -> coq_Interval -> coq_Interval
- -> coq_Interval_opt **)
-
-let inter prec emax i1 i2 =
- to_Interval_opt prec emax (inter' prec emax i1 i2)
-
-(** val coq_Iadd' :
- Farith_Big.big_int -> Farith_Big.big_int -> Farith_Big.mode ->
- coq_Interval' -> coq_Interval' -> coq_Interval' **)
-
-let coq_Iadd' prec emax m i1 i2 =
- match i1 with
- | Inan -> Inan
- | Intv (l, h, n) ->
- (match i2 with
- | Inan -> Inan
- | Intv (l', h', n') ->
- let sum1 = coq_Bplus prec emax m l l' in
- let sum2 = coq_Bplus prec emax m h h' in
- if is_nan prec emax sum1
- then if is_nan prec emax sum2
- then Inan
- else Intv ((B754_infinity false), (B754_infinity false), true)
- else if is_nan prec emax sum2
- then Intv ((B754_infinity true), (B754_infinity true), true)
- else Intv (sum1, sum2,
- ((||)
- ((||) ((||) n n')
- ((&&) (coq_Beqb prec emax h (B754_infinity false))
- (coq_Beqb prec emax l' (B754_infinity true))))
- ((&&) (coq_Beqb prec emax h' (B754_infinity false))
- (coq_Beqb prec emax l (B754_infinity true))))))
-
-(** val coq_Iadd :
- Farith_Big.big_int -> Farith_Big.big_int -> Farith_Big.mode ->
- coq_Interval -> coq_Interval -> coq_Interval **)
-
-let coq_Iadd =
- coq_Iadd'
-
-(** val coq_Ile :
- Farith_Big.big_int -> Farith_Big.big_int -> coq_Interval ->
- coq_Interval_opt **)
-
-let coq_Ile _ _ = function
-| Inan -> None
-| Intv (_, b, n) -> Some (Intv ((B754_infinity true), b, n))
-
-(** val coq_Ilt :
- Farith_Big.big_int -> Farith_Big.big_int -> coq_Interval ->
- coq_Interval_opt **)
-
-let coq_Ilt _ _ = function
-| Inan -> None
-| Intv (_, b, n) -> Some (Intv ((B754_infinity true), b, n))
-
-(** val coq_Ige :
- Farith_Big.big_int -> Farith_Big.big_int -> coq_Interval ->
- coq_Interval_opt **)
-
-let coq_Ige _ _ = function
-| Inan -> None
-| Intv (a, _, n) -> Some (Intv (a, (B754_infinity false), n))
-
-(** val coq_Igt :
- Farith_Big.big_int -> Farith_Big.big_int -> coq_Interval ->
- coq_Interval_opt **)
-
-let coq_Igt _ _ = function
-| Inan -> None
-| Intv (a, _, n) -> Some (Intv (a, (B754_infinity false), n))
diff --git a/farith2/extracted/Interval.mli b/farith2/extracted/Interval.mli
deleted file mode 100644
index 6a873c01a..000000000
--- a/farith2/extracted/Interval.mli
+++ /dev/null
@@ -1,52 +0,0 @@
-open BinarySingleNaN
-open Utils
-
-type float = binary_float
-
-type coq_Interval' =
-| Inan
-| Intv of float * float * bool
-
-type coq_Interval = coq_Interval'
-
-type coq_Interval_opt = coq_Interval option
-
-val to_Interval_opt :
- Farith_Big.big_int -> Farith_Big.big_int -> coq_Interval' option ->
- coq_Interval_opt
-
-val top : Farith_Big.big_int -> Farith_Big.big_int -> coq_Interval
-
-val is_singleton :
- Farith_Big.big_int -> Farith_Big.big_int -> coq_Interval -> float option
-
-val singleton :
- Farith_Big.big_int -> Farith_Big.big_int -> float -> coq_Interval
-
-val inter' :
- Farith_Big.big_int -> Farith_Big.big_int -> coq_Interval' -> coq_Interval'
- -> coq_Interval' option
-
-val inter :
- Farith_Big.big_int -> Farith_Big.big_int -> coq_Interval -> coq_Interval ->
- coq_Interval_opt
-
-val coq_Iadd' :
- Farith_Big.big_int -> Farith_Big.big_int -> Farith_Big.mode ->
- coq_Interval' -> coq_Interval' -> coq_Interval'
-
-val coq_Iadd :
- Farith_Big.big_int -> Farith_Big.big_int -> Farith_Big.mode -> coq_Interval
- -> coq_Interval -> coq_Interval
-
-val coq_Ile :
- Farith_Big.big_int -> Farith_Big.big_int -> coq_Interval -> coq_Interval_opt
-
-val coq_Ilt :
- Farith_Big.big_int -> Farith_Big.big_int -> coq_Interval -> coq_Interval_opt
-
-val coq_Ige :
- Farith_Big.big_int -> Farith_Big.big_int -> coq_Interval -> coq_Interval_opt
-
-val coq_Igt :
- Farith_Big.big_int -> Farith_Big.big_int -> coq_Interval -> coq_Interval_opt
diff --git a/farith2/extracted/Op.ml b/farith2/extracted/Op.ml
deleted file mode 100644
index 08ad65bb1..000000000
--- a/farith2/extracted/Op.ml
+++ /dev/null
@@ -1,54 +0,0 @@
-open BinInt
-open BinPos
-open BinarySingleNaN
-open SpecFloat
-open Zpower
-
-type float = binary_float
-
-(** val coq_Fsucc :
- Farith_Big.big_int -> Farith_Big.big_int -> binary_float -> binary_float **)
-
-let coq_Fsucc prec emax x = match x with
-| B754_zero _ -> B754_finite (false, Farith_Big.one, (emin prec emax))
-| B754_infinity s ->
- if s then coq_Bopp prec emax (coq_Bmax_float prec emax) else x
-| B754_nan -> x
-| B754_finite (s, m, e) ->
- if s
- then if Farith_Big.identity (Farith_Big.eq e (emin prec emax))
- then if Farith_Big.identity (Farith_Big.lt Farith_Big.one m)
- then B754_finite (true, (Pos.pred m), e)
- else B754_zero true
- else let m0 = Farith_Big.pred m in
- if Farith_Big.identity (Farith_Big.lt (coq_Zdigits2 m0) prec)
- then B754_finite (true,
- (Pos.sub (shift_pos (Z.to_pos prec) Farith_Big.one)
- Farith_Big.one), (Farith_Big.sub e Farith_Big.one))
- else B754_finite (true, (Z.to_pos m0), e)
- else let m0 = Farith_Big.succ m in
- if Farith_Big.identity (Farith_Big.lt prec (digits2_pos m0))
- then if Farith_Big.identity
- (Farith_Big.eq e (Farith_Big.sub emax prec))
- then B754_infinity false
- else B754_finite (false,
- (Z.to_pos
- (Farith_Big.shiftl Farith_Big.one
- (Farith_Big.sub prec Farith_Big.one))),
- (Farith_Big.add e Farith_Big.one))
- else B754_finite (false, m0, e)
-
-(** val coq_Fneg :
- Farith_Big.big_int -> Farith_Big.big_int -> float -> float **)
-
-let coq_Fneg _ _ = function
-| B754_zero s -> B754_zero (Pervasives.not s)
-| B754_infinity s -> B754_infinity (Pervasives.not s)
-| B754_nan -> B754_nan
-| B754_finite (s, m, e) -> B754_finite ((Pervasives.not s), m, e)
-
-(** val coq_Fpred :
- Farith_Big.big_int -> Farith_Big.big_int -> float -> float **)
-
-let coq_Fpred prec emax x =
- coq_Fneg prec emax (coq_Fsucc prec emax (coq_Fneg prec emax x))
diff --git a/farith2/extracted/Op.mli b/farith2/extracted/Op.mli
deleted file mode 100644
index bc8250632..000000000
--- a/farith2/extracted/Op.mli
+++ /dev/null
@@ -1,14 +0,0 @@
-open BinInt
-open BinPos
-open BinarySingleNaN
-open SpecFloat
-open Zpower
-
-type float = binary_float
-
-val coq_Fsucc :
- Farith_Big.big_int -> Farith_Big.big_int -> binary_float -> binary_float
-
-val coq_Fneg : Farith_Big.big_int -> Farith_Big.big_int -> float -> float
-
-val coq_Fpred : Farith_Big.big_int -> Farith_Big.big_int -> float -> float
diff --git a/farith2/extracted/Operations.ml b/farith2/extracted/Operations.ml
deleted file mode 100644
index f17de46a1..000000000
--- a/farith2/extracted/Operations.ml
+++ /dev/null
@@ -1,30 +0,0 @@
-open BinInt
-open Defs
-open Zaux
-
-(** val coq_Falign :
- radix -> float -> float ->
- (Farith_Big.big_int * Farith_Big.big_int) * Farith_Big.big_int **)
-
-let coq_Falign beta f1 f2 =
- let { coq_Fnum = m1; coq_Fexp = e1 } = f1 in
- let { coq_Fnum = m2; coq_Fexp = e2 } = f2 in
- if Farith_Big.le e1 e2
- then ((m1,
- (Farith_Big.mult m2 (Z.pow (radix_val beta) (Farith_Big.sub e2 e1)))),
- e1)
- else (((Farith_Big.mult m1 (Z.pow (radix_val beta) (Farith_Big.sub e1 e2))),
- m2), e2)
-
-(** val coq_Fplus : radix -> float -> float -> float **)
-
-let coq_Fplus beta f1 f2 =
- let (p, e) = coq_Falign beta f1 f2 in
- let (m1, m2) = p in { coq_Fnum = (Farith_Big.add m1 m2); coq_Fexp = e }
-
-(** val coq_Fmult : radix -> float -> float -> float **)
-
-let coq_Fmult _ f1 f2 =
- let { coq_Fnum = m1; coq_Fexp = e1 } = f1 in
- let { coq_Fnum = m2; coq_Fexp = e2 } = f2 in
- { coq_Fnum = (Farith_Big.mult m1 m2); coq_Fexp = (Farith_Big.add e1 e2) }
diff --git a/farith2/extracted/Operations.mli b/farith2/extracted/Operations.mli
deleted file mode 100644
index 386fb4067..000000000
--- a/farith2/extracted/Operations.mli
+++ /dev/null
@@ -1,11 +0,0 @@
-open BinInt
-open Defs
-open Zaux
-
-val coq_Falign :
- radix -> float -> float ->
- (Farith_Big.big_int * Farith_Big.big_int) * Farith_Big.big_int
-
-val coq_Fplus : radix -> float -> float -> float
-
-val coq_Fmult : radix -> float -> float -> float
diff --git a/farith2/extracted/Qextended.ml b/farith2/extracted/Qextended.ml
deleted file mode 100644
index 4d9bfaa92..000000000
--- a/farith2/extracted/Qextended.ml
+++ /dev/null
@@ -1,22 +0,0 @@
-
-(** val coq_Qx_zero : Q.t **)
-
-let coq_Qx_zero =
- Farith_Big.q_mk (Farith_Big.zero, Farith_Big.one)
-
-(** val coq_Qx_undef : Q.t **)
-
-let coq_Qx_undef =
- Farith_Big.q_mk (Farith_Big.zero, Farith_Big.zero)
-
-(** val coq_Qx_inf : Q.t **)
-
-let coq_Qx_inf =
- Farith_Big.q_mk (Farith_Big.one, Farith_Big.zero)
-
-(** val coq_Qx_minus_inf : Q.t **)
-
-let coq_Qx_minus_inf =
- Farith_Big.q_mk ((Farith_Big.opp Farith_Big.one), Farith_Big.zero)
-
-
diff --git a/farith2/extracted/Qextended.mli b/farith2/extracted/Qextended.mli
deleted file mode 100644
index 7698b1e58..000000000
--- a/farith2/extracted/Qextended.mli
+++ /dev/null
@@ -1,10 +0,0 @@
-
-val coq_Qx_zero : Q.t
-
-val coq_Qx_undef : Q.t
-
-val coq_Qx_inf : Q.t
-
-val coq_Qx_minus_inf : Q.t
-
-
diff --git a/farith2/extracted/Round.ml b/farith2/extracted/Round.ml
deleted file mode 100644
index f6c4da1bd..000000000
--- a/farith2/extracted/Round.ml
+++ /dev/null
@@ -1,28 +0,0 @@
-open Datatypes
-open SpecFloat
-
-(** val cond_incr : bool -> Farith_Big.big_int -> Farith_Big.big_int **)
-
-let cond_incr b m =
- if b then Farith_Big.add m Farith_Big.one else m
-
-(** val round_sign_DN : bool -> location -> bool **)
-
-let round_sign_DN s = function
-| Coq_loc_Exact -> false
-| Coq_loc_Inexact _ -> s
-
-(** val round_sign_UP : bool -> location -> bool **)
-
-let round_sign_UP s = function
-| Coq_loc_Exact -> false
-| Coq_loc_Inexact _ -> Pervasives.not s
-
-(** val round_N : bool -> location -> bool **)
-
-let round_N p = function
-| Coq_loc_Exact -> false
-| Coq_loc_Inexact c -> (match c with
- | Eq -> p
- | Lt -> false
- | Gt -> true)
diff --git a/farith2/extracted/Round.mli b/farith2/extracted/Round.mli
deleted file mode 100644
index db97e992a..000000000
--- a/farith2/extracted/Round.mli
+++ /dev/null
@@ -1,10 +0,0 @@
-open Datatypes
-open SpecFloat
-
-val cond_incr : bool -> Farith_Big.big_int -> Farith_Big.big_int
-
-val round_sign_DN : bool -> location -> bool
-
-val round_sign_UP : bool -> location -> bool
-
-val round_N : bool -> location -> bool
diff --git a/farith2/extracted/SpecFloat.ml b/farith2/extracted/SpecFloat.ml
deleted file mode 100644
index 7c315960c..000000000
--- a/farith2/extracted/SpecFloat.ml
+++ /dev/null
@@ -1,290 +0,0 @@
-open BinInt
-open Datatypes
-open Zpower
-
-type spec_float =
-| S754_zero of bool
-| S754_infinity of bool
-| S754_nan
-| S754_finite of bool * Farith_Big.big_int * Farith_Big.big_int
-
-(** val emin :
- Farith_Big.big_int -> Farith_Big.big_int -> Farith_Big.big_int **)
-
-let emin prec emax =
- Farith_Big.sub
- (Farith_Big.sub (Farith_Big.succ_double Farith_Big.one) emax) prec
-
-(** val fexp :
- Farith_Big.big_int -> Farith_Big.big_int -> Farith_Big.big_int ->
- Farith_Big.big_int **)
-
-let fexp prec emax e =
- Farith_Big.max (Farith_Big.sub e prec) (emin prec emax)
-
-(** val digits2_pos : Farith_Big.big_int -> Farith_Big.big_int **)
-
-let rec digits2_pos n =
- Farith_Big.positive_case
- (fun p -> Farith_Big.succ (digits2_pos p))
- (fun p -> Farith_Big.succ (digits2_pos p))
- (fun _ -> Farith_Big.one)
- n
-
-(** val coq_Zdigits2 : Farith_Big.big_int -> Farith_Big.big_int **)
-
-let coq_Zdigits2 n =
- Farith_Big.z_case
- (fun _ -> n)
- (fun p -> (digits2_pos p))
- (fun p -> (digits2_pos p))
- n
-
-(** val iter_pos : ('a1 -> 'a1) -> Farith_Big.big_int -> 'a1 -> 'a1 **)
-
-let rec iter_pos f n x =
- Farith_Big.positive_case
- (fun n' -> iter_pos f n' (iter_pos f n' (f x)))
- (fun n' -> iter_pos f n' (iter_pos f n' x))
- (fun _ -> f x)
- n
-
-type location =
-| Coq_loc_Exact
-| Coq_loc_Inexact of comparison
-
-type shr_record = { shr_m : Farith_Big.big_int; shr_r : bool; shr_s : bool }
-
-(** val shr_1 : shr_record -> shr_record **)
-
-let shr_1 mrs =
- let { shr_m = m; shr_r = r; shr_s = s } = mrs in
- let s0 = (||) r s in
- (Farith_Big.z_case
- (fun _ -> { shr_m = Farith_Big.zero; shr_r = false; shr_s =
- s0 })
- (fun p0 ->
- Farith_Big.positive_case
- (fun p -> { shr_m = p; shr_r = true; shr_s = s0 })
- (fun p -> { shr_m = p; shr_r = false; shr_s = s0 })
- (fun _ -> { shr_m = Farith_Big.zero; shr_r = true; shr_s = s0 })
- p0)
- (fun p0 ->
- Farith_Big.positive_case
- (fun p -> { shr_m = (Farith_Big.opp p); shr_r = true; shr_s =
- s0 })
- (fun p -> { shr_m = (Farith_Big.opp p); shr_r = false; shr_s =
- s0 })
- (fun _ -> { shr_m = Farith_Big.zero; shr_r = true; shr_s = s0 })
- p0)
- m)
-
-(** val loc_of_shr_record : shr_record -> location **)
-
-let loc_of_shr_record mrs =
- let { shr_m = _; shr_r = shr_r0; shr_s = shr_s0 } = mrs in
- if shr_r0
- then if shr_s0 then Coq_loc_Inexact Gt else Coq_loc_Inexact Eq
- else if shr_s0 then Coq_loc_Inexact Lt else Coq_loc_Exact
-
-(** val shr_record_of_loc : Farith_Big.big_int -> location -> shr_record **)
-
-let shr_record_of_loc m = function
-| Coq_loc_Exact -> { shr_m = m; shr_r = false; shr_s = false }
-| Coq_loc_Inexact c ->
- (match c with
- | Eq -> { shr_m = m; shr_r = true; shr_s = false }
- | Lt -> { shr_m = m; shr_r = false; shr_s = true }
- | Gt -> { shr_m = m; shr_r = true; shr_s = true })
-
-(** val shr :
- shr_record -> Farith_Big.big_int -> Farith_Big.big_int ->
- shr_record * Farith_Big.big_int **)
-
-let shr mrs e n =
- Farith_Big.z_case
- (fun _ -> (mrs, e))
- (fun p -> ((iter_pos shr_1 p mrs), (Farith_Big.add e n)))
- (fun _ -> (mrs, e))
- n
-
-(** val shr_fexp :
- Farith_Big.big_int -> Farith_Big.big_int -> Farith_Big.big_int ->
- Farith_Big.big_int -> location -> shr_record * Farith_Big.big_int **)
-
-let shr_fexp prec emax m e l =
- shr (shr_record_of_loc m l) e
- (Farith_Big.sub (fexp prec emax (Farith_Big.add (coq_Zdigits2 m) e)) e)
-
-(** val shl_align :
- Farith_Big.big_int -> Farith_Big.big_int -> Farith_Big.big_int ->
- Farith_Big.big_int * Farith_Big.big_int **)
-
-let shl_align mx ex ex' =
- Farith_Big.z_case
- (fun _ -> (mx, ex))
- (fun _ -> (mx, ex))
- (fun d -> ((shift_pos d mx), ex'))
- (Farith_Big.sub ex' ex)
-
-(** val coq_SFcompare : spec_float -> spec_float -> comparison option **)
-
-let coq_SFcompare f1 f2 =
- match f1 with
- | S754_zero _ ->
- (match f2 with
- | S754_zero _ -> Some Eq
- | S754_infinity s -> Some (if s then Gt else Lt)
- | S754_nan -> None
- | S754_finite (s, _, _) -> Some (if s then Gt else Lt))
- | S754_infinity s ->
- (match f2 with
- | S754_infinity s0 ->
- Some (if s then if s0 then Eq else Lt else if s0 then Gt else Eq)
- | S754_nan -> None
- | _ -> Some (if s then Lt else Gt))
- | S754_nan -> None
- | S754_finite (s1, m1, e1) ->
- (match f2 with
- | S754_zero _ -> Some (if s1 then Lt else Gt)
- | S754_infinity s -> Some (if s then Gt else Lt)
- | S754_nan -> None
- | S754_finite (s2, m2, e2) ->
- Some
- (if s1
- then if s2
- then (match (Farith_Big.compare_case Eq Lt Gt) e1 e2 with
- | Eq ->
- coq_CompOpp
- ((fun c x y -> Farith_Big.compare_case c Lt Gt x y)
- Eq m1 m2)
- | Lt -> Gt
- | Gt -> Lt)
- else Lt
- else if s2
- then Gt
- else (match (Farith_Big.compare_case Eq Lt Gt) e1 e2 with
- | Eq ->
- (fun c x y -> Farith_Big.compare_case c Lt Gt x y) Eq
- m1 m2
- | x -> x)))
-
-(** val coq_SFeqb : spec_float -> spec_float -> bool **)
-
-let coq_SFeqb f1 f2 =
- match coq_SFcompare f1 f2 with
- | Some c -> (match c with
- | Eq -> true
- | _ -> false)
- | None -> false
-
-(** val coq_SFltb : spec_float -> spec_float -> bool **)
-
-let coq_SFltb f1 f2 =
- match coq_SFcompare f1 f2 with
- | Some c -> (match c with
- | Lt -> true
- | _ -> false)
- | None -> false
-
-(** val coq_SFleb : spec_float -> spec_float -> bool **)
-
-let coq_SFleb f1 f2 =
- match coq_SFcompare f1 f2 with
- | Some c -> (match c with
- | Gt -> false
- | _ -> true)
- | None -> false
-
-(** val cond_Zopp : bool -> Farith_Big.big_int -> Farith_Big.big_int **)
-
-let cond_Zopp b m =
- if b then Farith_Big.opp m else m
-
-(** val new_location_even :
- Farith_Big.big_int -> Farith_Big.big_int -> location **)
-
-let new_location_even nb_steps k =
- if Farith_Big.eq k Farith_Big.zero
- then Coq_loc_Exact
- else Coq_loc_Inexact
- ((Farith_Big.compare_case Eq Lt Gt)
- (Farith_Big.mult (Farith_Big.double Farith_Big.one) k) nb_steps)
-
-(** val new_location_odd :
- Farith_Big.big_int -> Farith_Big.big_int -> location **)
-
-let new_location_odd nb_steps k =
- if Farith_Big.eq k Farith_Big.zero
- then Coq_loc_Exact
- else Coq_loc_Inexact
- (match (Farith_Big.compare_case Eq Lt Gt)
- (Farith_Big.add
- (Farith_Big.mult (Farith_Big.double Farith_Big.one) k)
- Farith_Big.one) nb_steps with
- | Eq -> Lt
- | x -> x)
-
-(** val new_location :
- Farith_Big.big_int -> Farith_Big.big_int -> location **)
-
-let new_location nb_steps =
- if Z.even nb_steps
- then new_location_even nb_steps
- else new_location_odd nb_steps
-
-(** val coq_SFdiv_core_binary :
- Farith_Big.big_int -> Farith_Big.big_int -> Farith_Big.big_int ->
- Farith_Big.big_int -> Farith_Big.big_int -> Farith_Big.big_int ->
- (Farith_Big.big_int * Farith_Big.big_int) * location **)
-
-let coq_SFdiv_core_binary prec emax m1 e1 m2 e2 =
- let d1 = coq_Zdigits2 m1 in
- let d2 = coq_Zdigits2 m2 in
- let e' =
- Farith_Big.min
- (fexp prec emax
- (Farith_Big.sub (Farith_Big.add d1 e1) (Farith_Big.add d2 e2)))
- (Farith_Big.sub e1 e2)
- in
- let s = Farith_Big.sub (Farith_Big.sub e1 e2) e' in
- let m' =
- Farith_Big.z_case
- (fun _ -> m1)
- (fun _ -> Farith_Big.shiftl m1 s)
- (fun _ -> Farith_Big.zero)
- s
- in
- let (q, r) = Farith_Big.div_mod_floor m' m2 in
- ((q, e'), (new_location m2 r))
-
-(** val coq_SFsqrt_core_binary :
- Farith_Big.big_int -> Farith_Big.big_int -> Farith_Big.big_int ->
- Farith_Big.big_int -> (Farith_Big.big_int * Farith_Big.big_int) * location **)
-
-let coq_SFsqrt_core_binary prec emax m e =
- let d = coq_Zdigits2 m in
- let e' =
- Farith_Big.min
- (fexp prec emax
- (Farith_Big.div2_floor
- (Farith_Big.add (Farith_Big.add d e) Farith_Big.one)))
- (Farith_Big.div2_floor e)
- in
- let s =
- Farith_Big.sub e (Farith_Big.mult (Farith_Big.double Farith_Big.one) e')
- in
- let m' =
- Farith_Big.z_case
- (fun _ -> m)
- (fun _ -> Farith_Big.shiftl m s)
- (fun _ -> Farith_Big.zero)
- s
- in
- let (q, r) = Farith_Big.Z.sqrt_rem m' in
- let l =
- if Farith_Big.eq r Farith_Big.zero
- then Coq_loc_Exact
- else Coq_loc_Inexact (if Farith_Big.le r q then Lt else Gt)
- in
- ((q, e'), l)
diff --git a/farith2/extracted/SpecFloat.mli b/farith2/extracted/SpecFloat.mli
deleted file mode 100644
index 0523a53f1..000000000
--- a/farith2/extracted/SpecFloat.mli
+++ /dev/null
@@ -1,70 +0,0 @@
-open BinInt
-open Datatypes
-open Zpower
-
-type spec_float =
-| S754_zero of bool
-| S754_infinity of bool
-| S754_nan
-| S754_finite of bool * Farith_Big.big_int * Farith_Big.big_int
-
-val emin : Farith_Big.big_int -> Farith_Big.big_int -> Farith_Big.big_int
-
-val fexp :
- Farith_Big.big_int -> Farith_Big.big_int -> Farith_Big.big_int ->
- Farith_Big.big_int
-
-val digits2_pos : Farith_Big.big_int -> Farith_Big.big_int
-
-val coq_Zdigits2 : Farith_Big.big_int -> Farith_Big.big_int
-
-val iter_pos : ('a1 -> 'a1) -> Farith_Big.big_int -> 'a1 -> 'a1
-
-type location =
-| Coq_loc_Exact
-| Coq_loc_Inexact of comparison
-
-type shr_record = { shr_m : Farith_Big.big_int; shr_r : bool; shr_s : bool }
-
-val shr_1 : shr_record -> shr_record
-
-val loc_of_shr_record : shr_record -> location
-
-val shr_record_of_loc : Farith_Big.big_int -> location -> shr_record
-
-val shr :
- shr_record -> Farith_Big.big_int -> Farith_Big.big_int ->
- shr_record * Farith_Big.big_int
-
-val shr_fexp :
- Farith_Big.big_int -> Farith_Big.big_int -> Farith_Big.big_int ->
- Farith_Big.big_int -> location -> shr_record * Farith_Big.big_int
-
-val shl_align :
- Farith_Big.big_int -> Farith_Big.big_int -> Farith_Big.big_int ->
- Farith_Big.big_int * Farith_Big.big_int
-
-val coq_SFcompare : spec_float -> spec_float -> comparison option
-
-val coq_SFeqb : spec_float -> spec_float -> bool
-
-val coq_SFltb : spec_float -> spec_float -> bool
-
-val coq_SFleb : spec_float -> spec_float -> bool
-
-val cond_Zopp : bool -> Farith_Big.big_int -> Farith_Big.big_int
-
-val new_location_even : Farith_Big.big_int -> Farith_Big.big_int -> location
-
-val new_location_odd : Farith_Big.big_int -> Farith_Big.big_int -> location
-
-val new_location : Farith_Big.big_int -> Farith_Big.big_int -> location
-
-val coq_SFdiv_core_binary :
- Farith_Big.big_int -> Farith_Big.big_int -> Farith_Big.big_int ->
- Farith_Big.big_int -> Farith_Big.big_int -> Farith_Big.big_int ->
- (Farith_Big.big_int * Farith_Big.big_int) * location
-
-val coq_SFsqrt_core_binary :
- Farith_Big.big_int -> Farith_Big.big_int -> Farith_Big.big_int ->
- Farith_Big.big_int -> (Farith_Big.big_int * Farith_Big.big_int) * location
diff --git a/farith2/extracted/Specif.ml b/farith2/extracted/Specif.ml
deleted file mode 100644
index 0109f6d7c..000000000
--- a/farith2/extracted/Specif.ml
+++ /dev/null
@@ -1,5 +0,0 @@
-
-type 'a coq_sig = 'a
- (* singleton inductive, whose constructor was exist *)
-
-
diff --git a/farith2/extracted/Specif.mli b/farith2/extracted/Specif.mli
deleted file mode 100644
index 0109f6d7c..000000000
--- a/farith2/extracted/Specif.mli
+++ /dev/null
@@ -1,5 +0,0 @@
-
-type 'a coq_sig = 'a
- (* singleton inductive, whose constructor was exist *)
-
-
diff --git a/farith2/extracted/Utils.ml b/farith2/extracted/Utils.ml
deleted file mode 100644
index ff1c2c78e..000000000
--- a/farith2/extracted/Utils.ml
+++ /dev/null
@@ -1,19 +0,0 @@
-open BinarySingleNaN
-
-type float = binary_float
-
-(** val coq_Bmax :
- Farith_Big.big_int -> Farith_Big.big_int -> float -> float -> float **)
-
-let coq_Bmax prec emax f1 f2 =
- if (||) (is_nan prec emax f1) (is_nan prec emax f2)
- then B754_nan
- else if coq_Bleb prec emax f1 f2 then f2 else f1
-
-(** val coq_Bmin :
- Farith_Big.big_int -> Farith_Big.big_int -> float -> float -> float **)
-
-let coq_Bmin prec emax f1 f2 =
- if (||) (is_nan prec emax f1) (is_nan prec emax f2)
- then B754_nan
- else if coq_Bleb prec emax f1 f2 then f1 else f2
diff --git a/farith2/extracted/Utils.mli b/farith2/extracted/Utils.mli
deleted file mode 100644
index 5eb5b65c8..000000000
--- a/farith2/extracted/Utils.mli
+++ /dev/null
@@ -1,9 +0,0 @@
-open BinarySingleNaN
-
-type float = binary_float
-
-val coq_Bmax :
- Farith_Big.big_int -> Farith_Big.big_int -> float -> float -> float
-
-val coq_Bmin :
- Farith_Big.big_int -> Farith_Big.big_int -> float -> float -> float
diff --git a/farith2/extracted/Version.ml b/farith2/extracted/Version.ml
deleted file mode 100644
index 20839a8b4..000000000
--- a/farith2/extracted/Version.ml
+++ /dev/null
@@ -1,9 +0,0 @@
-
-(** val coq_Flocq_version : Farith_Big.big_int **)
-
-let coq_Flocq_version =
- (Farith_Big.double (Farith_Big.double (Farith_Big.double (Farith_Big.double
- (Farith_Big.double (Farith_Big.double (Farith_Big.succ_double
- (Farith_Big.double (Farith_Big.double (Farith_Big.double
- (Farith_Big.succ_double (Farith_Big.succ_double (Farith_Big.succ_double
- (Farith_Big.double (Farith_Big.double Farith_Big.one)))))))))))))))
diff --git a/farith2/extracted/Version.mli b/farith2/extracted/Version.mli
deleted file mode 100644
index dce3905b8..000000000
--- a/farith2/extracted/Version.mli
+++ /dev/null
@@ -1,2 +0,0 @@
-
-val coq_Flocq_version : Farith_Big.big_int
diff --git a/farith2/extracted/Zaux.ml b/farith2/extracted/Zaux.ml
deleted file mode 100644
index d575ac647..000000000
--- a/farith2/extracted/Zaux.ml
+++ /dev/null
@@ -1,16 +0,0 @@
-
-type radix =
- Farith_Big.big_int
- (* singleton inductive, whose constructor was Build_radix *)
-
-(** val radix_val : radix -> Farith_Big.big_int **)
-
-let radix_val r =
- r
-
-(** val radix2 : radix **)
-
-let radix2 =
- (Farith_Big.double Farith_Big.one)
-
-
diff --git a/farith2/extracted/Zaux.mli b/farith2/extracted/Zaux.mli
deleted file mode 100644
index 200260b8d..000000000
--- a/farith2/extracted/Zaux.mli
+++ /dev/null
@@ -1,10 +0,0 @@
-
-type radix =
- Farith_Big.big_int
- (* singleton inductive, whose constructor was Build_radix *)
-
-val radix_val : radix -> Farith_Big.big_int
-
-val radix2 : radix
-
-
diff --git a/farith2/extracted/Zbool.ml b/farith2/extracted/Zbool.ml
deleted file mode 100644
index 139597f9c..000000000
--- a/farith2/extracted/Zbool.ml
+++ /dev/null
@@ -1,2 +0,0 @@
-
-
diff --git a/farith2/extracted/Zbool.mli b/farith2/extracted/Zbool.mli
deleted file mode 100644
index 139597f9c..000000000
--- a/farith2/extracted/Zbool.mli
+++ /dev/null
@@ -1,2 +0,0 @@
-
-
diff --git a/farith2/extracted/Zpower.ml b/farith2/extracted/Zpower.ml
deleted file mode 100644
index d7ddaef5c..000000000
--- a/farith2/extracted/Zpower.ml
+++ /dev/null
@@ -1,7 +0,0 @@
-open BinPos
-
-(** val shift_pos :
- Farith_Big.big_int -> Farith_Big.big_int -> Farith_Big.big_int **)
-
-let shift_pos n z =
- Pos.iter (fun x -> Farith_Big.double x) z n
diff --git a/farith2/extracted/Zpower.mli b/farith2/extracted/Zpower.mli
deleted file mode 100644
index 0887c39e5..000000000
--- a/farith2/extracted/Zpower.mli
+++ /dev/null
@@ -1,4 +0,0 @@
-open BinPos
-
-val shift_pos :
- Farith_Big.big_int -> Farith_Big.big_int -> Farith_Big.big_int
diff --git a/farith2/extracted/dune b/farith2/extracted/dune
deleted file mode 100644
index de83f6b1c..000000000
--- a/farith2/extracted/dune
+++ /dev/null
@@ -1,48 +0,0 @@
-(rule (action (copy ../extract/BinNums.ml BinNums.ml)) (mode promote))
-(rule (action (copy ../extract/Bool.ml Bool.ml)) (mode promote))
-(rule (action (copy ../extract/Qextended.ml Qextended.ml)) (mode promote))
-(rule (action (copy ../extract/Utils.ml Utils.ml)) (mode promote))
-(rule (action (copy ../extract/BinNums.mli BinNums.mli)) (mode promote))
-(rule (action (copy ../extract/Bool.mli Bool.mli)) (mode promote))
-(rule (action (copy ../extract/Qextended.mli Qextended.mli)) (mode promote))
-(rule (action (copy ../extract/Utils.mli Utils.mli)) (mode promote))
-(rule (action (copy ../extract/Binary.ml Binary.ml)) (mode promote))
-(rule (action (copy ../extract/BinPosDef.ml BinPosDef.ml)) (mode promote))
-(rule (action (copy ../extract/Datatypes.ml Datatypes.ml)) (mode promote))
-(rule (action (copy ../extract/Round.ml Round.ml)) (mode promote))
-(rule (action (copy ../extract/Zaux.ml Zaux.ml)) (mode promote))
-(rule (action (copy ../extract/Binary.mli Binary.mli)) (mode promote))
-(rule (action (copy ../extract/BinPosDef.mli BinPosDef.mli)) (mode promote))
-(rule (action (copy ../extract/Datatypes.mli Datatypes.mli)) (mode promote))
-(rule (action (copy ../extract/Round.mli Round.mli)) (mode promote))
-(rule (action (copy ../extract/Zaux.mli Zaux.mli)) (mode promote))
-(rule (action (copy ../extract/BinarySingleNaN.ml BinarySingleNaN.ml)) (mode promote))
-(rule (action (copy ../extract/BinPos.ml BinPos.ml)) (mode promote))
-(rule (action (copy ../extract/Interval.ml Interval.ml)) (mode promote))
-(rule (action (copy ../extract/SpecFloat.ml SpecFloat.ml)) (mode promote))
-(rule (action (copy ../extract/Zbool.ml Zbool.ml)) (mode promote))
-(rule (action (copy ../extract/BinarySingleNaN.mli BinarySingleNaN.mli)) (mode promote))
-(rule (action (copy ../extract/BinPos.mli BinPos.mli)) (mode promote))
-(rule (action (copy ../extract/Interval.mli Interval.mli)) (mode promote))
-(rule (action (copy ../extract/SpecFloat.mli SpecFloat.mli)) (mode promote))
-(rule (action (copy ../extract/Zbool.mli Zbool.mli)) (mode promote))
-(rule (action (copy ../extract/BinInt.ml BinInt.ml)) (mode promote))
-(rule (action (copy ../extract/Bits.ml Bits.ml)) (mode promote))
-(rule (action (copy ../extract/Specif.ml Specif.ml)) (mode promote))
-(rule (action (copy ../extract/Zpower.ml Zpower.ml)) (mode promote))
-(rule (action (copy ../extract/BinInt.mli BinInt.mli)) (mode promote))
-(rule (action (copy ../extract/Bits.mli Bits.mli)) (mode promote))
-(rule (action (copy ../extract/Specif.mli Specif.mli)) (mode promote))
-(rule (action (copy ../extract/Zpower.mli Zpower.mli)) (mode promote))
-(rule (action (copy ../extract/Assert.ml Assert.ml)) (mode promote))
-(rule (action (copy ../extract/Assert.mli Assert.mli)) (mode promote))
-(rule (action (copy ../extract/GenericFloat.ml GenericFloat.ml)) (mode promote))
-(rule (action (copy ../extract/GenericFloat.mli GenericFloat.mli)) (mode promote))
-(rule (action (copy ../extract/Version.ml Version.ml)) (mode promote))
-(rule (action (copy ../extract/Version.mli Version.mli)) (mode promote))
-(rule (action (copy ../extract/Defs.ml Defs.ml)) (mode promote))
-(rule (action (copy ../extract/Defs.mli Defs.mli)) (mode promote))
-(rule (action (copy ../extract/Operations.ml Operations.ml)) (mode promote))
-(rule (action (copy ../extract/Operations.mli Operations.mli)) (mode promote))
-(rule (action (copy ../extract/Op.ml Op.ml)) (mode promote))
-(rule (action (copy ../extract/Op.mli Op.mli)) (mode promote))
diff --git a/farith2/farith2.ml b/farith2/farith2.ml
deleted file mode 100644
index a99fe6652..000000000
--- a/farith2/farith2.ml
+++ /dev/null
@@ -1,292 +0,0 @@
-(**************************************************************************)
-(* This file is part of FArith. *)
-(* *)
-(* Copyright (C) 2015-2015 *)
-(* CEA (Commissariat a l'energie atomique et aux energies *)
-(* alternatives) *)
-(* *)
-(* you can redistribute it and/or modify it under the terms of the GNU *)
-(* Lesser General Public License as published by the Free Software *)
-(* Foundation, version 2.1. *)
-(* *)
-(* It 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 Lesser General Public License for more details. *)
-(* *)
-(* See the GNU Lesser General Public License version 2.1 *)
-(* (enclosed file LGPLv2.1). *)
-(* *)
-(**************************************************************************)
-open Base
-
-module Format = Stdlib.Format
-
-module Z = struct
- include Z
-
- let hash_fold_t s t = Base.Hash.fold_int s (hash t)
-end
-
-type mode = Farith_Big.mode = NE | ZR | DN | UP | NA
-[@@deriving eq, ord, hash]
-
-type classify = Farith_Big.classify =
- | Zero of bool
- | Infinity of bool
- | NaN
- | Finite of bool * Z.t * Z.t
-
-type 'v generic = 'v GenericFloat.coq_Generic = {
- mw : Z.t;
- ew : Z.t;
- value : 'v;
-}
-[@@deriving eq, ord, hash]
-
-module F = struct
- open GenericFloat
- include GenericFloat
-
- let mw t = Z.to_int t.mw
- let ew t = Z.to_int t.ew
- let pp_sign fmt b = Format.pp_print_string fmt (if b then "-" else "+")
-
- type binary_float = BinarySingleNaN.binary_float =
- | B754_zero of bool
- | B754_infinity of bool
- | B754_nan
- | B754_finite of bool * Z.t * Z.t
- [@@deriving eq, ord, hash]
-
- type t = binary_float generic [@@deriving eq, ord, hash]
-
- let pp_binary_float fmt (t : binary_float) =
- match t with
- | B754_zero b -> Format.fprintf fmt "%a0" pp_sign b
- | B754_infinity b -> Format.fprintf fmt "%a∞" pp_sign b
- | B754_nan -> Format.fprintf fmt "NaN"
- | B754_finite (b, m, e) ->
- let rec oddify a p =
- if Z.equal (Z.logand a Z.one) Z.zero then
- oddify (Z.shift_right_trunc a 1) (Z.succ p)
- else if Z.equal a Z.zero then (Z.zero, Z.zero)
- else (a, p)
- in
- let m, e = oddify m e in
- Format.fprintf fmt "%a%ap%a" pp_sign b Z.pp_print m Z.pp_print e
-
- let pp fmt t = pp_binary_float fmt t.value
-
- (** lexer for finite float *)
- let lex_float s =
- match String.index s 'p' with
- | Some k ->
- let m = String.sub s ~pos:0 ~len:k in
- let e = String.sub s (Int.succ k) (String.length s - k - 1) in
- (Z.of_string m, Z.of_string e)
- | None -> (Z.of_string s, Z.zero)
-
- let of_q ~mw ~ew mode q = of_q (Z.of_int mw) (Z.of_int ew) mode q
- let of_bits ~mw ~ew z = of_bits (Z.of_int mw) (Z.of_int ew) z
- let to_bits t = to_bits t
- let nan ~mw ~ew = nan (Z.of_int mw) (Z.of_int ew)
- let zero ~mw ~ew b = zero (Z.of_int mw) (Z.of_int ew) b
- let inf ~mw ~ew b = inf (Z.of_int mw) (Z.of_int ew) b
- let is_zero t = match t.value with B754_zero _ -> true | _ -> false
- let is_infinite t = match t.value with B754_infinity _ -> true | _ -> false
- let is_nan t = match t.value with B754_nan -> true | _ -> false
-
- let round ~mw ~ew mode (f:t) : t =
- (match f.value with
- | B754_zero _
- | B754_infinity _
- | B754_nan -> { mw = Z.of_int mw; ew = Z.of_int ew; value = f.value }
- | B754_finite (_, _, _) ->
- (of_q ~mw ~ew mode (to_q f))
- )
-
- let of_float f = of_bits ~mw:52 ~ew:11
- @@ Z.extract (Z.of_int64 (Int64.bits_of_float f)) 0 64
- let to_float mode f = round ~mw:52 ~ew:11 mode f
- |> to_bits
- |> fun z -> Z.signed_extract z 0 64
- |> Z.to_int64
- |> Int64.float_of_bits
-
- let is_negative t =
- match t.value with
- | B754_zero true | B754_finite (true, _, _) -> true
- | _ -> false
-
- let is_positive t =
- match t.value with
- | B754_zero false | B754_finite (false, _, _) -> true
- | _ -> false
-
- let is_normal t =
- match t.value with
- | B754_zero _ -> true
- | B754_finite (_, e, _) when Z.sign e <> 0 -> true
- | _ -> false
-
- let is_subnormal t =
- match t.value with
- | B754_finite (_, e, _) when Z.sign e = 0 -> true
- | _ -> false
-end
-
-module I = struct
- open GenericFloat
- include GenericInterval
-
- type interval = Interval.coq_Interval' =
- | Inan
- | Intv of F.binary_float * F.binary_float * bool
- [@@deriving eq, ord, hash]
-
- type t = interval generic [@@deriving eq, ord, hash]
-
- let mw t = Z.to_int t.mw
- let ew t = Z.to_int t.ew
-
- let pp fmt (t : t) =
- match t.value with
- | Inan -> Format.fprintf fmt "{ NaN }"
- | Intv (a, b, nan) ->
- if nan then
- Format.fprintf fmt "[%a, %a] + NaN" F.pp_binary_float a
- F.pp_binary_float b
- else
- Format.fprintf fmt "[%a, %a]" F.pp_binary_float a F.pp_binary_float b
-
- let top ~mw ~ew = top (Z.of_int mw) (Z.of_int ew)
-end
-
-(*
-module D = struct
- type 't conf = 't Farith_F_aux.fconf
- include Farith_F_aux.D
- include Common
-
- let mw conf = Z.to_int (Farith_F_aux.mw conf)
- let ew conf = Z.to_int (Farith_F_aux.ew conf)
-
- let roundq ~mw ~ew mode q = roundq (Z.of_int mw) (Z.of_int ew) mode q
-
- let pp conf fmt x = pp fmt (cast_to_t conf x)
-
- (* let of_string conf mode s =
- * let m,e = lex_float s in
- * finite conf mode m e *)
-end
-
-module type S = sig
-
- type t
- val conf : t D.conf
-
- val compare: t -> t -> int
- val equal: t -> t -> bool
- val hash : t -> int
-
- val opp : t -> t
- val add : mode -> t -> t -> t
- val sub : mode -> t -> t -> t
- val mul : mode -> t -> t -> t
- val div : mode -> t -> t -> t
- val sqrt : mode -> t -> t
- val abs : t -> t
-
- val of_bits : Z.t -> t
- val to_bits : t -> Z.t
-
- val of_z : mode -> Z.t -> t (** Round. *)
-
- val of_q : mode -> Q.t -> t (** Round. *)
-
- val to_q : t -> Q.t (** Exact. *)
-
- val conv : 't D.conf -> mode -> t -> 't
-
- val infinity: bool -> t
- val infp : t
- val infm : t
- val zero : bool -> t
- val zerop: t
- val nan: bool -> Z.t -> t
- val default_nan: t
- val finite: mode -> Z.t -> Z.t -> t
- val classify: t -> classify
-
- val le : t -> t -> bool
- val lt : t -> t -> bool
- val ge : t -> t -> bool
- val gt : t -> t -> bool
- val eq : t -> t -> bool
- val neq : t -> t -> bool
-
- val fcompare : t -> t -> int option
-
- val pp : Format.formatter -> t -> unit
- val of_string: mode -> string -> t
-
-end
-
-module B32 = struct include Farith_F_aux.B32 include Common
-
- let of_string mode s =
- let m,e = lex_float s in
- finite mode m e
-end
-
-module B64 = struct include Farith_F_aux.B64 include Common
-
- (** unfortunately of_bits and to_bits wants positive argument (unsigned int64)
- and Z.of_int64/Z.to_int64 wants signed argument (signed int64)
- *)
- let mask_one = Z.pred (Z.shift_left Z.one 64)
- let of_float f =
- let fb = (Big_int_Z.big_int_of_int64 (Int64.bits_of_float f)) in
- let fb = Z.logand mask_one fb in
- of_bits fb
-
- let mask_63 = Z.shift_left Z.one 63
- let intmask_63 = Int64.shift_left Int64.one 63
- let to_float f =
- let fb = to_bits f in
- let i = if Z.logand mask_63 fb = Z.zero then Z.to_int64 fb
- else Int64.logor intmask_63 (Z.to_int64 (Z.logxor mask_63 fb)) in
- Int64.float_of_bits i
-
- let of_string mode s =
- let m,e = lex_float s in
- finite mode m e
-
-end
-
-module type Size =
-sig
- val mw : int (** mantissa size (in bits) *)
-
- val ew : int (** exponent size (in bits) *)
-end
-
-module Make(Size : Size) =
-struct
-
- include Farith_F_aux.Make
- (struct
- let mw = Z.of_int Size.mw
- let ew = Z.of_int Size.ew
- end)
-
- include Common
-
- let of_string mode s =
- let m,e = lex_float s in
- finite mode m e
-
-end
-*)
-let flocq_version = Version.coq_Flocq_version
diff --git a/farith2/farith2.mli b/farith2/farith2.mli
deleted file mode 100644
index 936004966..000000000
--- a/farith2/farith2.mli
+++ /dev/null
@@ -1,399 +0,0 @@
-(**************************************************************************)
-(* This file is part of FArith. *)
-(* *)
-(* Copyright (C) 2015-2015 *)
-(* CEA (Commissariat a l'energie atomique et aux energies *)
-(* alternatives) *)
-(* *)
-(* you can redistribute it and/or modify it under the terms of the GNU *)
-(* Lesser General Public License as published by the Free Software *)
-(* Foundation, version 2.1. *)
-(* *)
-(* It 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 Lesser General Public License for more details. *)
-(* *)
-(* See the GNU Lesser General Public License version 2.1 *)
-(* (enclosed file LGPLv2.1). *)
-(* *)
-(**************************************************************************)
-
-(** Float Arithmetics (based on [Flocq] extraction) *)
-
-(** Supported rounding modes *)
-type mode =
- | NE (** Nearest to even *)
- | ZR (** Toward zero *)
- | DN (** Toward minus infinity *)
- | UP (** Toward plus infinity *)
- | NA (** Nearest away from zero *)
-[@@deriving eq, ord, hash]
-
-(** Type used for classifying floating points *)
-type classify =
- | Zero of bool
- | Infinity of bool
- | NaN
- | Finite of bool * Z.t * Z.t
-
-module F : sig
- type t [@@deriving eq, ord, hash]
-
- val ew : t -> int
-
- val mw : t -> int
-
- val pp : Format.formatter -> t -> unit
-
- val of_q : mw:int -> ew:int -> mode -> Q.t -> t
-
- val to_q : t -> Q.t
-
- val add : mode -> t -> t -> t
-
- val sub : mode -> t -> t -> t
-
- val mul : mode -> t -> t -> t
-
- val div : mode -> t -> t -> t
-
- val fma : mode -> t -> t -> t -> t
-
- val sqrt : mode -> t -> t
-
- val abs : t -> t
-
- val neg : t -> t
-
- val pred : t -> t
-
- val succ : t -> t
-
- val of_bits : mw:int -> ew:int -> Z.t -> t
-
- val to_bits : t -> Z.t
-
- val of_float : float -> t
-
- val to_float : mode -> t -> float
-
- val round: mw:int -> ew:int -> mode -> t -> t
-
- val ge : t -> t -> bool
-
- val gt : t -> t -> bool
-
- val le : t -> t -> bool
-
- val lt : t -> t -> bool
-
- val eq : t -> t -> bool
-
- val nan : mw:int -> ew:int -> t
-
- val zero : mw:int -> ew:int -> bool -> t
-
- val inf : mw:int -> ew:int -> bool -> t
-
- val is_zero : t -> bool
-
- val is_infinite : t -> bool
-
- val is_nan : t -> bool
-
- val is_negative : t -> bool
-
- val is_positive : t -> bool
-
- val is_normal : t -> bool
-
- val is_subnormal : t -> bool
-end
-
-module I : sig
- type t [@@deriving eq, ord, hash]
-
- val ew : t -> int
-
- val mw : t -> int
-
- val pp : Format.formatter -> t -> unit
-
- val top : mw:int -> ew:int -> t
-
- val inter : t -> t -> t option
-
- val add : mode -> t -> t -> t
-
- val ge : t -> t option
-
- val gt : t -> t option
-
- val le : t -> t option
-
- val lt : t -> t option
-
- val singleton : F.t -> t
-
- val is_singleton : t -> F.t option
-end
-
-val flocq_version: Z.t
-
-(* (\** {2 Generic Version } *\)
- *
- *
- * module D : sig
- *
- * type 't conf
- * (\** A configuration links a mantissa and exponent size to a
- * type which is the set of representable floating point with these sizes.
- * A value of this type is obtained by application of {!Farith.Make}
- * *\)
- *
- * val mw : 't conf -> int
- * (\** mantissa size *\)
- *
- * val ew : 't conf -> int
- * (\** exponent size *\)
- *
- * (\** {2 Total operators} *\)
- *
- * val compare: 't conf -> 't -> 't -> int
- * val equal: 't conf -> 't -> 't -> bool
- * val hash : 't conf -> 't -> int
- *
- * (\** {2 Floating point operations} *\)
- *
- * val opp : 't conf -> 't -> 't
- * val add : 't conf -> mode -> 't -> 't -> 't
- * val sub : 't conf -> mode -> 't -> 't -> 't
- * val mul : 't conf -> mode -> 't -> 't -> 't
- * val div : 't conf -> mode -> 't -> 't -> 't
- * val sqrt : 't conf -> mode -> 't -> 't
- * val abs : 't conf -> 't -> 't
- *
- * (\** {2 Conversions} *\)
- *
- * val of_bits : 't conf -> Z.t -> 't
- * (\** Conversions from bitvector representation.
- * The given bitvector must be positive.
- * *\)
- *
- * val to_bits : 't conf -> 't -> Z.t
- * (\** Convert the floating point to its bitvector representation *\)
- *
- * val of_z : 't conf -> mode -> Z.t -> 't
- * (\** Convert the integer to the nearest representable integer *\)
- *
- * val of_q : 't conf -> mode -> Q.t -> 't
- * (\** Convert the rational to the nearest representable integer. *\)
- *
- * val to_q : 't conf -> 't -> Q.t
- * (\** Convert the floating-point to its rational representation. *\)
- *
- * val conv : 't1 conf -> 't2 conf -> mode -> 't1 -> 't2
- * (\** Convert the floating point to the nearest representable floating point
- * having another mantissa and exponent size. *\)
- *
- * val roundq : mw:int -> ew:int -> mode -> Q.t -> Q.t
- * (\** Round the given rational to the nearest representable floating
- * point with the mantissa width [mw] and exponent width [ew] using
- * the rounding mode [mode].
- * *\)
- *
- * (\** {2 Floating point constants} *\)
- * val infinity: 't conf -> bool -> 't
- * (\** create infinity floating point (true negative, false positive) *\)
- *
- * val infp : 't conf -> 't
- * (\** positive infinity *\)
- *
- * val infm : 't conf -> 't
- * (\** minus infinity *\)
- *
- * val zero : 't conf -> bool -> 't
- * (\** create zero floating point (true negative, false positive) *\)
- *
- * val zerop: 't conf -> 't
- * (\** positive zero *\)
- *
- * val nan: 't conf -> bool -> Z.t -> 't
- * (\** create a nan with the given payload. The payload must fit in the
- * mantissa *\)
- *
- * val default_nan: 't conf -> 't
- *
- * val finite: 't conf -> mode -> Z.t -> Z.t -> 't
- * (\** [finite conf mode m e] return the rounded floating point
- * corresponding to m*2^e. Beware of the result can be classified
- * not only as finite but also as infinite or zero because of the
- * rounding.
- * *\)
- *
- * val classify: 't conf -> 't -> classify
- * (\** Classify the floating point according to its kind *\)
- *
- * (\** {3 IEEE Comparison}
- *
- * Respect IEEE behavior for NaN
- * *\)
- *
- * val le : 't conf -> 't -> 't -> bool
- * val lt : 't conf -> 't -> 't -> bool
- * val ge : 't conf -> 't -> 't -> bool
- * val gt : 't conf -> 't -> 't -> bool
- * val eq : 't conf -> 't -> 't -> bool
- * val neq : 't conf -> 't -> 't -> bool
- *
- * val fcompare : 't conf -> 't -> 't -> int option
- * (\** return None in the undefined cases (one of the argument is NaN) *\)
- *
- * (\** {3 Formatting}
- *
- * Format is [<m>[p<e>]] where [<m>] is a signed decimal integer
- * and [p<e>] an optional exponent in power of 2.
- * For instance [to_string (of_string "24p-1")] is ["3p2"].
- * *\)
- *
- * val pp : 't conf -> Format.formatter -> 't -> unit
- * end
- *
- * (\** {2 Functorized Version} *\)
- *
- *
- * module type S = sig
- * type t
- *
- * val conf : t D.conf
- * (\** The configuration for this type of floating-point *\)
- *
- * (\** {2 Total operators} *\)
- *
- * val compare: t -> t -> int
- * val equal: t -> t -> bool
- * val hash : t -> int
- *
- * (\** {2 Floating point operations} *\)
- *
- * val opp : t -> t
- * val add : mode -> t -> t -> t
- * val sub : mode -> t -> t -> t
- * val mul : mode -> t -> t -> t
- * val div : mode -> t -> t -> t
- * val sqrt : mode -> t -> t
- * val abs : t -> t
- *
- * (\** {2 conversions} *\)
- *
- * val of_bits : Z.t -> t
- * (\** Conversions from bitvector representation.
- * The given bitvector must be positive.
- * *\)
- *
- * val to_bits : t -> Z.t
- * (\** Convert the floating point to its bitvector representation *\)
- *
- * val of_z : mode -> Z.t -> t
- * (\** Convert the integer to the nearest representable integer *\)
- *
- * val of_q : mode -> Q.t -> t
- * (\** Convert the rational to the nearest representable integer. *\)
- *
- * val to_q : t -> Q.t
- * (\** Convert the floating-point to its rational representation. *\)
- *
- * val conv : 't D.conf -> mode -> t -> 't
- * (\** Convert the floating point to the nearest representable floating point
- * having another mantissa and exponent size. *\)
- *
- * (\** {2 Floating point constants} *\)
- * val infinity: bool -> t
- * (\** create infinity floating point (true negative, false positive) *\)
- *
- * val infp : t
- * (\** positive infinity *\)
- *
- * val infm : t
- * (\** minus infinity *\)
- *
- * val zero : bool -> t
- * (\** create zero floating point (true negative, false positive) *\)
- *
- * val zerop: t
- * (\** positive zero *\)
- *
- * val nan: bool -> Z.t -> t
- * (\** create a nan with the given payload. The payload must fit in the
- * mantissa *\)
- *
- * val default_nan: t
- *
- * val finite: mode -> Z.t -> Z.t -> t
- * (\** [finite conf mode m e] return the rounded floating point
- * corresponding to m*2^e. Beware of the result can be classified
- * not only as finite but also as infinite or zero because of the
- * rounding. *\)
- *
- * val classify: t -> classify
- * (\** Classify the floating point according to its kind *\)
- *
- * (\** {3 IEEE Comparison}
- *
- * Respect IEEE behavior for NaN
- * *\)
- *
- * val le : t -> t -> bool
- * val lt : t -> t -> bool
- * val ge : t -> t -> bool
- * val gt : t -> t -> bool
- * val eq : t -> t -> bool
- * val neq : t -> t -> bool
- *
- * val fcompare : t -> t -> int option
- * (\** return None in the undefined cases (one of the argument is NaN) *\)
- *
- *
- * (\** {3 Formatting}
- *
- * Format is [<m>[p<e>]] where [<m>] is a signed decimal integer
- * and [p<e>] an optional exponent in power of 2.
- * For instance [to_string (of_string "24p-1")] is ["3p2"].
- * *\)
- *
- * val pp : Format.formatter -> t -> unit
- *
- *
- * val of_string: mode -> string -> t
- * (\** convert string of the shape "[-+][0-9]+p[-+][0-9]+" or "[-+][0-9]+"
- * to a floating point using the given rounding *\)
- * end
- *
- * module type Size =
- * sig
- * val mw : int
- * (\** mantissa size (in bits) *\)
- *
- * val ew : int
- * (\** exponent size (in bits) *\)
- * end
- *
- * module Make (Size : Size) : S
- *
- * (\** {2 Already Applied Versions } *\)
- *
- * (\** Simple (mw = 23 ew = 8) *\)
- * module B32 : S
- *
- * (\** Double (mw = 52 ew = 11) *\)
- * module B64 : sig
- * include S
- *
- * (\** {3 Exact conversion from/to OCaml floats} *\)
- * val of_float : float -> t
- * val to_float : t -> float
- *
- * end
- *
- * val flocq_version: Z.t *)
diff --git a/farith2/tests/issue_005.expected b/farith2/tests/issue_005.expected
deleted file mode 100644
index ed3078295..000000000
--- a/farith2/tests/issue_005.expected
+++ /dev/null
@@ -1 +0,0 @@
-[F] 0.100000 : +3602879701896397p-55
diff --git a/farith2/tests/issue_005.ml b/farith2/tests/issue_005.ml
deleted file mode 100644
index 363837f36..000000000
--- a/farith2/tests/issue_005.ml
+++ /dev/null
@@ -1,11 +0,0 @@
-open Format
-open Farith2
-
-let f_convert r =
- let fp = F.of_float r in
- printf "[F] %f : %a@." r F.pp fp ; fp
-
-let () =
- begin
- ignore (f_convert 0.1) ;
- end
diff --git a/farith2/tests/mode.expected b/farith2/tests/mode.expected
deleted file mode 100644
index 5d6065ed5..000000000
--- a/farith2/tests/mode.expected
+++ /dev/null
@@ -1,61 +0,0 @@
-[F] 3.1 = +6980579422424269p-51
-[Fp] 3.1 = +6501171p-21
-[Fq] 3.1 = +6501171p-21
------------------------
- Simple Roundings
------------------------
-Q=31/10
-[F-NE] +6980579422424269p-51
-[F-NE] -6980579422424269p-51
------------------------
-Q=31/10
-[F-NA] +6980579422424269p-51
-[F-NA] -6980579422424269p-51
------------------------
-Q=31/10
-[F-ZR] +1745144855606067p-49
-[F-ZR] -1745144855606067p-49
------------------------
-Q=31/10
-[F-UP] +6980579422424269p-51
-[F-UP] -1745144855606067p-49
------------------------
-Q=31/10
-[F-DN] +1745144855606067p-49
-[F-DN] -6980579422424269p-51
------------------------
- Tie Breaks (NE)
------------------------
-Q=562949953421313/562949953421312
-[F-NE-ex] +562949953421313p-49
-[F-NE-ex] -562949953421313p-49
------------------------
-Q=2251799813685253/2251799813685248
-[F-NE-lo] +2251799813685253p-51
-[F-NE-lo] -2251799813685253p-51
------------------------
-Q=1125899906842627/1125899906842624
-[F-NE-ti] +1125899906842627p-50
-[F-NE-ti] -1125899906842627p-50
------------------------
-Q=2251799813685255/2251799813685248
-[F-NE-up] +2251799813685255p-51
-[F-NE-up] -2251799813685255p-51
------------------------
- Tie Breaks (NA)
------------------------
-Q=562949953421313/562949953421312
-[F-NA-ex] +562949953421313p-49
-[F-NA-ex] -562949953421313p-49
------------------------
-Q=2251799813685253/2251799813685248
-[F-NA-lo] +2251799813685253p-51
-[F-NA-lo] -2251799813685253p-51
------------------------
-Q=1125899906842627/1125899906842624
-[F-NA-ti] +1125899906842627p-50
-[F-NA-ti] -1125899906842627p-50
------------------------
-Q=2251799813685255/2251799813685248
-[F-NA-up] +2251799813685255p-51
-[F-NA-up] -2251799813685255p-51
diff --git a/farith2/tests/mode.ml b/farith2/tests/mode.ml
deleted file mode 100644
index 8771308e8..000000000
--- a/farith2/tests/mode.ml
+++ /dev/null
@@ -1,43 +0,0 @@
-module F = Farith2.F
-
-let fpp mode fmt q = F.pp fmt (F.of_q mode ~mw:52 ~ew:11 q)
-
-let () =
- begin
- let f = (F.of_float 3.1) in
- Format.printf "[F] 3.1 = %a@." F.pp f;
- let q = Q.make (Z.of_int 31) (Z.of_int 10) in
- Format.printf "[Fp] 3.1 = %a@." F.pp (F.round ~mw:24 ~ew:11 ZR (F.of_float 3.1)) ;
- Format.printf "[Fq] 3.1 = %a@." F.pp (F.of_q ~mw:24 ~ew:11 ZR q) ;
- Format.printf "-----------------------@." ;
- Format.printf " Simple Roundings@." ;
- let job m m2 q =
- begin
- Format.printf "-----------------------@." ;
- Format.printf "Q=%a@." Q.pp_print q ;
- Format.printf "[F-%s] %a@." m (fpp m2) q ;
- Format.printf "[F-%s] %a@." m (fpp m2) (Q.neg q) ;
- end in
- job "NE" Farith2.NE q ;
- job "NA" Farith2.NA q ;
- job "ZR" Farith2.ZR q ;
- job "UP" Farith2.UP q ;
- job "DN" Farith2.DN q ;
- Format.printf "-----------------------@." ;
- Format.printf " Tie Breaks (NE)@." ;
- let eps = Z.shift_left Z.one 51 in
- let e_ex = Q.make (Z.of_int 0b100) eps in
- let e_lo = Q.make (Z.of_int 0b101) eps in
- let e_ti = Q.make (Z.of_int 0b110) eps in
- let e_up = Q.make (Z.of_int 0b111) eps in
- job "NE-ex" Farith2.NE (Q.add Q.one e_ex) ;
- job "NE-lo" Farith2.NE (Q.add Q.one e_lo) ;
- job "NE-ti" Farith2.NE (Q.add Q.one e_ti) ;
- job "NE-up" Farith2.NE (Q.add Q.one e_up) ;
- Format.printf "-----------------------@." ;
- Format.printf " Tie Breaks (NA)@." ;
- job "NA-ex" Farith2.NA (Q.add Q.one e_ex) ;
- job "NA-lo" Farith2.NA (Q.add Q.one e_lo) ;
- job "NA-ti" Farith2.NA (Q.add Q.one e_ti) ;
- job "NA-up" Farith2.NA (Q.add Q.one e_up) ;
- end
diff --git a/farith2/tests/subnormal.expected b/farith2/tests/subnormal.expected
deleted file mode 100644
index cf3afb2fc..000000000
--- a/farith2/tests/subnormal.expected
+++ /dev/null
@@ -1,7 +0,0 @@
-of-float 1p1023 = +1p1023 (normal)
-of-float 1p1024 = +∞ (infinity)
-of-float 1p-1022 = +1p-1022 (normal)
-of-float 1p-1023 = +1p-1023 (sub-normal)
-of-float 1p-1048 = +1p-1048 (sub-normal)
-of-float 1p-1074 = +1p-1074 (sub-normal)
-of-float 1p-1075 = +0 (zero)
diff --git a/farith2/tests/subnormal.ml b/farith2/tests/subnormal.ml
deleted file mode 100644
index 75445605c..000000000
--- a/farith2/tests/subnormal.ml
+++ /dev/null
@@ -1,39 +0,0 @@
-open Farith2
-
-let eps n = Stdlib.ldexp 1.0 n
-
-let pp_class fmt u =
- Format.pp_print_string fmt
- begin
- match classify_float u with
- | FP_zero -> "zero"
- | FP_normal -> "normal"
- | FP_subnormal -> "sub-normal"
- | FP_infinite -> "infinity"
- | FP_nan -> "nan"
- end
-
-let test_of_float n =
- let u = eps n in
- let f = F.of_float u in
- Format.printf "of-float 1p%d = %a (%a)@." n F.pp f pp_class u
-
-(* let test_to_float n =
- * begin
- * let u = eps n in
- * let f = F.power2 n in
- * let v = F.to_float f in
- * Format.printf "to-float %a = %f (%a)@." F.pp f v pp_class v ;
- * let fu,eu = Stdlib.frexp u in
- * let fv,ev = Stdlib.frexp v in
- * Format.printf " expected = %fp%d@\n" fu eu ;
- * Format.printf " obtained = %fp%d@." fv ev ;
- * end *)
-
-let limits = [ 1023;1024;-1022;-1023;-1048;-1074;-1075 ]
-
-let () =
- begin
- List.iter test_of_float limits ;
- (* List.iter test_to_float limits ; *)
- end
diff --git a/farith2/tests/test.expected b/farith2/tests/test.expected
deleted file mode 100644
index e823e1d3c..000000000
--- a/farith2/tests/test.expected
+++ /dev/null
@@ -1,18 +0,0 @@
-Flocq version: 40000
-Run tests with Farith2.F
- 0.100000 + 2.000000 = 2.100000
- 0.100000 : +3602879701896397p-55
- 2.000000 : +1p1
- 2.100000 : +4728779608739021p-51
--0.100000 + 2.000000 = 1.900000
--0.100000 : -3602879701896397p-55
-2.000000 : +1p1
-1.900000 : +4278419646001971p-51
--0.100000 + -2.000000 = -2.100000
--0.100000 : -3602879701896397p-55
--2.000000 : -1p1
--2.100000 : -4728779608739021p-51
-0.100000 + -2.000000 = -1.900000
-0.100000 : +3602879701896397p-55
--2.000000 : -1p1
--1.900000 : -4278419646001971p-51
diff --git a/farith2/tests/test.ml b/farith2/tests/test.ml
deleted file mode 100644
index 2b49f0f11..000000000
--- a/farith2/tests/test.ml
+++ /dev/null
@@ -1,26 +0,0 @@
-open Format
-
-let () =
- printf "Flocq version: %a@."
- Z.pp_print Farith2.flocq_version
-
-open Farith2
-
-module Run = struct
- let () =
- printf "@[<3>Run tests with %s@\n" "Farith2.F";
- let add u v =
- let fu = F.of_float u in
- let fv = F.of_float v in
- let fr = F.add NE fu fv in
- let r = F.to_float NE fr in
- printf "%f + %f = %f@\n" u v r;
- printf "%f : %a@\n" u F.pp fu;
- printf "%f : %a@\n" v F.pp fv;
- printf "%f : %a@]@\n" r F.pp fr;
- in
- add (0.1) (2.0);
- add (-.0.1) (2.0);
- add (-.0.1) (-.2.0);
- add (0.1) (-.2.0)
-end
diff --git a/farith2/tests/tie.expected b/farith2/tests/tie.expected
deleted file mode 100644
index 8b916f281..000000000
--- a/farith2/tests/tie.expected
+++ /dev/null
@@ -1,22 +0,0 @@
-------------------------------------------
- - +4503599627370496 (+1p52)
-1p52+1/2 = +9007199254740993p-1 (+9007199254740993p-1)
- + +4503599627370497 (+4503599627370497)
-mantissa = 9007199254740992
-=NE +1p52
-+NE +1p52 (+4503599627370496)
--NE -1p52 (-4503599627370496)
-=NA +4503599627370497p0
-+NA +4503599627370497 (+4503599627370497)
--NA -4503599627370497 (-4503599627370497)
-------------------------------------------
- - +4503599627370497 (+4503599627370497)
-1p52+3/2 = +9007199254740995p-1 (+9007199254740995p-1)
- + +4503599627370498 (+2251799813685249p1)
-mantissa = 9007199254740992
-=NE +2251799813685249p1
-+NE +2251799813685249p1 (+4503599627370498)
--NE -2251799813685249p1 (-4503599627370498)
-=NA +2251799813685249p1
-+NA +2251799813685249p1 (+4503599627370498)
--NA -2251799813685249p1 (-4503599627370498)
diff --git a/farith2/tests/tie.ml b/farith2/tests/tie.ml
deleted file mode 100644
index 111be991c..000000000
--- a/farith2/tests/tie.ml
+++ /dev/null
@@ -1,34 +0,0 @@
-open Farith2
-
-(** not tested *)
-
-let tiebreak a b n =
- begin
- (* Tie breaks at [2^(n-1) + e] with [n] bits precision *)
- let m = n-1 in
- let up = Q.mul_2exp Q.one m in
- let q = Q.(up + Q.make (Z.of_int a) (Z.of_int b)) in
- let f0 = F.of_qint ~bits:(n+1) q in (* exact *)
- let f1,f2 = F.seize ~bits:n f0 in
- Format.printf "------------------------------------------@\n" ;
- Format.printf " - %a (%a)@\n" F.pp f1 F.pp f1 ;
- Format.printf "1p%d+%d/%d = %a (%a)@\n" m a b pp f0 F.pp f0 ;
- Format.printf " + %a (%a)@\n" pp f2 F.pp f2 ;
- Format.printf "mantissa = %a@\n" Z.pp_print (Z.shift_left Z.one n) ;
- let f1 = F.neg f0 in
- let pos_ne = F.round ~mode:F.NE ~bits:n f0 in
- let pos_na = F.round ~mode:F.NA ~bits:n f0 in
- let neg_ne = F.round ~mode:F.NE ~bits:n f1 in
- let neg_na = F.round ~mode:F.NA ~bits:n f1 in
- Format.printf "+NE %a (%a)@\n" F.pp pos_ne pp pos_ne ;
- Format.printf "-NE %a (%a)@\n" F.pp neg_ne pp neg_ne ;
- Format.printf "+NA %a (%a)@\n" F.pp pos_na pp pos_na ;
- Format.printf "-NA %a (%a)@\n" F.pp neg_na pp neg_na ;
- Format.print_flush () ;
- end
-
-let () =
- begin
- tiebreak 1 2 F.b64 ;
- tiebreak 3 2 F.b64 ;
- end
diff --git a/farith2/thry/All.v b/farith2/thry/All.v
deleted file mode 100644
index 90ece08dd..000000000
--- a/farith2/thry/All.v
+++ /dev/null
@@ -1,27 +0,0 @@
-(** * A list of all submodules of Farith2 *)
-
-(** Usefull facts about floating points *)
-From F Require Import Utils.
-
-(** An extension of [R] including infinite values
- together with a new semantic for floating points
-*)
-From F Require Import Rextended.
-
-(** An extension of [Q] including infinite values
- used to write the specifications of conversions from [Q] to [float]
- and from [float] to [Q]
-*)
-From F Require Import Qextended.
-
-(** Correction lemmas associated to floating point binary operators *)
-From F Require Import Utils.
-
-(** A 32 bits instanciation of Flocq's [BinarySingleNaN] *)
-From F Require Import B32.
-
-(** Generic float intervals with verified propagators *)
-From F Require Import Interval.
-
-(** A 32 bits instanciation of [Interval] *)
-From F Require Import Intv32.
\ No newline at end of file
diff --git a/farith2/thry/Assert.v b/farith2/thry/Assert.v
deleted file mode 100644
index e7f2f4f09..000000000
--- a/farith2/thry/Assert.v
+++ /dev/null
@@ -1,26 +0,0 @@
-From Flocq Require Import IEEE754.BinarySingleNaN.
-From Coq Require Import Program ZArith.
-
-Module Type Inhabited.
- Parameter t : Type.
- Parameter dummy : t.
-End Inhabited.
-
-Module Assert (M : Inhabited).
- Program Definition assert (x : bool) (f : x = true -> M.t) : M.t :=
- match x with
- | true => f _
- | false => M.dummy
- end.
-
- Extract Inlined Constant assert => "(fun x f -> assert x; f ())".
-
- Lemma assert_spec:
- forall (pre : bool) (f : M.t),
- pre = true -> assert pre (fun _ => f) = f.
- Proof.
- intros.
- unfold assert.
- now rewrite H.
- Qed.
-End Assert.
diff --git a/farith2/thry/B32.v b/farith2/thry/B32.v
deleted file mode 100644
index 0c3f6367e..000000000
--- a/farith2/thry/B32.v
+++ /dev/null
@@ -1,133 +0,0 @@
-From Flocq Require Import Core.Core IEEE754.BinarySingleNaN IEEE754.Bits.
-Require Import QArith.
-Require Import Qreals.
-Require Import Reals.
-Require Import ZBits.
-Require Import Lia Lra.
-Require Coq.Arith.Wf_nat.
-Require Import Extraction.
-Require Import Qextended Rextended.
-
-(** * An instanciation of Flocq's BinarySingleNan for 32 bits IEEE-754 floating points *)
-
-Module B32.
-
-(** ** 1. Precision, maximal exponent & their properties *)
-
-Definition prec : Z := 24.
-Definition emax : Z := 128.
-Definition mw : Z := 23.
-Definition ew : Z := 8.
-Definition t : Type := binary_float prec emax.
-
-Lemma Hprec : Prec_gt_0 prec.
-Proof.
- unfold Prec_gt_0, prec; lia.
-Qed.
-
-Lemma Hemax : Prec_lt_emax prec emax.
-Proof.
- unfold Prec_lt_emax, prec, emax; lia.
-Qed.
-
-Lemma Hmw : (0 < mw)%Z.
-Proof.
- unfold mw; lia.
-Qed.
-
-Lemma Hew : (0 < ew)%Z.
-Proof.
- unfold ew; lia.
-Qed.
-
-(** ** 2. Floating-points operators *)
-
-Definition add : mode -> t -> t -> t := @Bplus _ _ Hprec Hemax.
-Definition sub : mode -> t -> t -> t := @Bminus _ _ Hprec Hemax.
-Definition mult : mode -> t -> t -> t := @Bmult _ _ Hprec Hemax.
-Definition div : mode -> t -> t -> t := @Bdiv _ _ Hprec Hemax.
-Definition sqrt : mode -> t -> t := @Bsqrt _ _ Hprec Hemax.
-Definition abs : t -> t := Babs.
-
-(** ** 3. Floating-points relations *)
-
-Definition le : t -> t -> bool := Bleb.
-Definition lt : t -> t -> bool := Bltb.
-Definition eq : t -> t -> bool := Beqb.
-Definition ge : t -> t -> bool := fun x y => Bleb y x.
-Definition gt : t -> t -> bool := fun x y => Bltb y x.
-
-(** ** 4. convertions to and from [Z] and [Q]*)
-
-Definition of_bits (b : Z) : t :=
- match Bits.binary_float_of_bits mw ew Hmw Hew Hemax b with
- | Binary.B754_nan _ _ _ _ _ => B754_nan
- | Binary.B754_zero _ _ s => B754_zero s
- | Binary.B754_infinity _ _ s => B754_infinity s
- | Binary.B754_finite _ _ s m e H => B754_finite s m e H
- end.
-
-Definition pl_cst := (Zaux.iter_nat xO (Z.to_nat (Z.pred mw)) xH)%Z.
-
-Lemma pl_valid : (Z.pos (Digits.digits2_pos pl_cst) <? prec)%Z = true.
-Proof.
- assert (G:forall n, Digits.digits2_Pnat (Zaux.iter_nat xO n xH)%Z = n).
- - induction n.
- * reflexivity.
- * rewrite iter_nat_S; simpl.
- rewrite IHn; reflexivity.
- - rewrite Digits.Zpos_digits2_pos.
- rewrite <- Digits.Z_of_nat_S_digits2_Pnat.
- unfold pl_cst, prec, mw.
- rewrite G;clear G.
- rewrite Nat2Z.inj_succ.
- rewrite Z2Nat.id; [rewrite Z.ltb_lt | ]; lia.
-Qed.
-
-Definition to_bits (f : t) : Z :=
- match f with
- | B754_nan =>
- Bits.bits_of_binary_float mw ew (Binary.B754_nan prec emax true pl_cst pl_valid)
- | B754_zero s => Bits.bits_of_binary_float mw ew (Binary.B754_zero prec emax s)
- | B754_infinity s => Bits.bits_of_binary_float mw ew (Binary.B754_infinity prec emax s)
- | B754_finite s m e H => Bits.bits_of_binary_float mw ew (Binary.B754_finite prec emax s m e H)
- end.
-
-Definition of_q (m : mode) (q : Qx) : t :=
- match Qx_classify q with
- | Qx_ZERO _ _ _ _ => B754_zero false
- | Qx_INF _ _ _ => B754_infinity false
- | Qx_MINF _ _ _ => B754_infinity true
- | Qx_UNDEF _ _ _ => B754_nan
- | Qx_NZERO _ _ _ _ _ =>
- match num q with
- | Z0 => B754_nan (** absurd *)
- | Z.pos pn =>
- SF2B _ (proj1 (Bdiv_correct_aux _ _ Hprec Hemax m false pn 0%Z false (Z.to_pos (den q)) 0%Z))
- | Z.neg nn =>
- SF2B _ (proj1 (Bdiv_correct_aux _ _ Hprec Hemax m true nn 0%Z false (Z.to_pos (den q)) 0%Z))
- end
- end.
-
-Lemma of_q_correct : forall m q, Q2Rx q = B2Rx (of_q m q).
-Proof.
- intros m q.
- unfold of_q, Q2Rx; destruct (Qx_classify q).
- - rewrite e, e0. reflexivity.
- - rewrite e, e0. reflexivity.
- - rewrite e, e0. reflexivity.
- - rewrite e, e0.
- destruct (Z.pos pq =? 0)%Z; try reflexivity.
- unfold Q2R; simpl.
- now rewrite Rmult_0_l.
- - rewrite e.
- destruct (Z.pos pq =? 0)%Z eqn:E1, (num q =? 0)%Z eqn:E2.
- + rewrite Z.eqb_eq in E1; rewrite E1;
- rewrite Z.eqb_eq in E2; rewrite E2.
- reflexivity.
- + admit.
- + admit.
- + admit.
-Admitted.
-
-End B32.
diff --git a/farith2/thry/Correction_thms.v b/farith2/thry/Correction_thms.v
deleted file mode 100644
index 6b38c9cb7..000000000
--- a/farith2/thry/Correction_thms.v
+++ /dev/null
@@ -1,195 +0,0 @@
-From Flocq Require Import IEEE754.BinarySingleNaN.
-From Coq Require Import ZArith Lia Reals Psatz.
-Require Import Utils Rextended.
-
-Section Correction.
-
-Variable prec : Z.
-Variable emax : Z.
-Context (Hprec : FLX.Prec_gt_0 prec).
-Context (Hemax : Prec_lt_emax prec emax).
-
-Definition float : Type := binary_float prec emax.
-
-
-Lemma B2SF_eq :
- forall (x : float) y H, B2SF x = y -> x = SF2B y H.
-Proof.
- intros.
- apply B2SF_inj.
- rewrite H0.
- symmetry.
- apply B2SF_SF2B.
-Qed.
-
-Lemma Bplus_correct :
- forall (m : mode) (x y : float),
- is_nan (Bplus m x y) = false ->
- B2Rx (Bplus m x y) = round m (add (B2Rx x) (B2Rx y)).
-Proof.
- Ltac compute0 :=
- match goal with
- | [ m : mode |- _ ] =>
- destruct m; simpl (B2Rx (B754_zero _)); (rewrite add_0_l || rewrite add_0_r); try apply round_id; apply round_0
- end.
- intros m x y HnanS.
- destruct (Bplus_not_nan_inv _ _ _ HnanS) as [HnanX HnanY].
- induction x as [ [ ] | [ ] | | ] eqn:Ex, y as [ [ ] | [ ] | | ] eqn:Ey; try easy; try compute0.
- unfold add.
- repeat rewrite (B2Rx_finite (B754_finite _ _ _ _)); auto.
- unfold round.
- assert (Fx : is_finite x = true) by (rewrite Ex; auto).
- assert (Fy : is_finite y = true) by (rewrite Ey; auto).
- pose proof (Bplus_correct _ _ _ _ m x y Fx Fy).
- destruct (do_overflow _ _ _ _) eqn:Ho1.
- - apply do_overflow_true in Ho1.
- unfold dont_overflow in Ho1.
- rewrite <- Ex, <- Ey in *.
- unfold R_imax in Ho1.
- rewrite Ho1 in H.
- destruct H as [H1 H2].
- apply (B2SF_eq _ _ (binary_overflow_correct _ _ _ _ _ _)) in H1.
- destruct m eqn:Em, (sign (B2R x + B2R y)) eqn:Hs.
- + simpl in *. rewrite H1; simpl.
- fdestruct x; fdestruct y.
- destruct s1, s2; simpl in *; try easy.
- unfold Defs.F2R in Hs; simpl in Hs.
- apply sign_neg_inv in Hs.
- pose proof (IZR_pos m2); pose proof (IZR_pos m3);
- pose proof (Raux.bpow_gt_0 Zaux.radix2 e3);
- pose proof (Raux.bpow_gt_0 Zaux.radix2 e5); nra.
- + simpl in *. rewrite H1; simpl.
- fdestruct x; fdestruct y.
- destruct s1, s2; simpl in *; try easy.
- unfold Defs.F2R in Hs; simpl in Hs.
- apply sign_pos_inv in Hs.
- pose proof (IZR_neg m2); pose proof (IZR_neg m3);
- pose proof (Raux.bpow_gt_0 Zaux.radix2 e3);
- pose proof (Raux.bpow_gt_0 Zaux.radix2 e5); nra.
- + simpl in *. rewrite H1; simpl.
- fdestruct x; fdestruct y.
- destruct s1, s2; simpl in *; try easy.
- unfold Defs.F2R in Hs; simpl in Hs.
- apply sign_neg_inv in Hs.
- pose proof (IZR_pos m2); pose proof (IZR_pos m3);
- pose proof (Raux.bpow_gt_0 Zaux.radix2 e3);
- pose proof (Raux.bpow_gt_0 Zaux.radix2 e5); nra.
- + simpl in *. rewrite H1; simpl.
- fdestruct x; fdestruct y.
- destruct s1, s2; simpl in *; try easy.
- unfold Defs.F2R in Hs; simpl in Hs.
- apply sign_pos_inv in Hs.
- change (Z.neg m2) with (- Z.pos m2)%Z in Hs.
- change (Z.neg m3) with (- Z.pos m3)%Z in Hs.
- repeat rewrite opp_IZR in Hs.
- pose proof (IZR_pos m2); pose proof (IZR_pos m3);
- pose proof (Raux.bpow_gt_0 Zaux.radix2 e3);
- pose proof (Raux.bpow_gt_0 Zaux.radix2 e5); nra.
- + simpl in *. rewrite H1; simpl.
- fdestruct x; fdestruct y.
- destruct s1, s2; simpl in *; try easy.
- unfold Defs.F2R in Hs; simpl in Hs.
- apply sign_neg_inv in Hs.
- pose proof (IZR_pos m2); pose proof (IZR_pos m3);
- pose proof (Raux.bpow_gt_0 Zaux.radix2 e3);
- pose proof (Raux.bpow_gt_0 Zaux.radix2 e5); nra.
- + simpl in *. rewrite H1; simpl.
- fdestruct x; fdestruct y.
- destruct s1, s2; simpl in *; try easy.
- unfold Defs.F2R in Hs; simpl in Hs.
- apply sign_pos_inv in Hs.
- pose proof (IZR_neg m2); pose proof (IZR_neg m3);
- pose proof (Raux.bpow_gt_0 Zaux.radix2 e5);
- pose proof (Raux.bpow_gt_0 Zaux.radix2 e3);
- nra.
- + simpl in *. rewrite H1; simpl.
- fdestruct x; fdestruct y.
- destruct s1, s2; simpl in *; try easy.
- unfold Defs.F2R in Hs; simpl in Hs.
- apply sign_neg_inv in Hs.
- pose proof (IZR_pos m2); pose proof (IZR_pos m3);
- pose proof (Raux.bpow_gt_0 Zaux.radix2 e3);
- pose proof (Raux.bpow_gt_0 Zaux.radix2 e5); nra.
- + simpl in *. rewrite H1; simpl.
- fdestruct x; fdestruct y.
- destruct s1, s2; simpl in *; try easy.
- unfold Defs.F2R in Hs; simpl in Hs.
- apply sign_pos_inv in Hs.
- pose proof (IZR_neg m2); pose proof (IZR_neg m3);
- pose proof (Raux.bpow_gt_0 Zaux.radix2 e3);
- pose proof (Raux.bpow_gt_0 Zaux.radix2 e5); nra.
- + simpl in *. rewrite H1; simpl.
- fdestruct x; fdestruct y.
- destruct s1, s2; simpl in *; try easy.
- unfold Defs.F2R in Hs; simpl in Hs.
- apply sign_neg_inv in Hs.
- pose proof (IZR_pos m2); pose proof (IZR_pos m3);
- pose proof (Raux.bpow_gt_0 Zaux.radix2 e3);
- pose proof (Raux.bpow_gt_0 Zaux.radix2 e5); nra.
- + simpl in *. rewrite H1; simpl.
- fdestruct x; fdestruct y.
- destruct s1, s2; simpl in *; try easy.
- unfold Defs.F2R in Hs; simpl in Hs.
- apply sign_pos_inv in Hs.
- pose proof (IZR_neg m2); pose proof (IZR_neg m3);
- pose proof (Raux.bpow_gt_0 Zaux.radix2 e3);
- pose proof (Raux.bpow_gt_0 Zaux.radix2 e5); nra.
- - apply do_overflow_false in Ho1.
- unfold dont_overflow in Ho1.
- rewrite <- Ex, <- Ey in *.
- unfold R_imax in Ho1.
- rewrite Ho1 in H.
- now destruct H as [<- [Hf _]], (Bplus _ _ _).
-Qed.
-
-Lemma Bmult_correct :
- forall (m : mode) (x y : float),
- is_nan (Bmult m x y) = false ->
- B2Rx (Bmult m x y) = round m (mult (B2Rx x) (B2Rx y)).
-Admitted.
-
-Theorem Bplus_le_mono_l:
- forall m (a b c : float),
- is_nan (Bplus m a c) = false ->
- is_nan (Bplus m b c) = false ->
- a <= b ->
- Bplus m a c <= Bplus m b c.
-Proof.
- intros m a b c Hnan1 Hnan2 Hab.
- apply B2Rx_le; auto.
- repeat (rewrite Bplus_correct; auto).
- apply round_le.
- apply (add_leb_mono_l _ _ _ (le_B2Rx _ _ Hab)).
-Qed.
-
-Theorem Bplus_le_mono_r:
- forall m (a b c : float),
- is_nan (Bplus m c a) = false ->
- is_nan (Bplus m c b) = false ->
- a <= b ->
- Bplus m c a <= Bplus m c b.
-Proof.
- intros m a b c Hnan1 Hnan2 Hab.
- apply B2Rx_le; auto.
- repeat (rewrite Bplus_correct; auto).
- apply round_le.
- apply (add_leb_mono_r _ _ _ (le_B2Rx _ _ Hab)).
-Qed.
-
-Theorem Bplus_le_compat:
- forall m (a b c d : float),
- is_nan (Bplus m a b) = false ->
- is_nan (Bplus m c d) = false ->
- a <= c ->
- b <= d ->
- Bplus m a b <= Bplus m c d.
-Proof.
- intros.
- apply B2Rx_le; auto.
- repeat (rewrite Bplus_correct); auto.
- eapply leb_trans; apply round_le.
- - apply (add_leb_mono_l _ _ _ (le_B2Rx _ _ H1)).
- - apply (add_leb_mono_r _ _ _ (le_B2Rx _ _ H2)).
-Qed.
-
-End Correction.
diff --git a/farith2/thry/Fle0.v b/farith2/thry/Fle0.v
deleted file mode 100644
index 97838ceb6..000000000
--- a/farith2/thry/Fle0.v
+++ /dev/null
@@ -1,733 +0,0 @@
-From Flocq Require Import IEEE754.BinarySingleNaN.
-From Coq Require Import ZArith Psatz Reals.
-From F Require Import Utils Correction_thms Rextended.
-
-(**
- The usual ordering relation on [binary_float] is [Bleb]. As defined
- in IEEE754, [Bleb] does'nt discriminate the signed zeros and thus
- zeros are always in relation regardless of the sign.
-
- We introduce a new relation [Fle0] that extends [Bleb] but discriminates
- signed zeros. [Fle0] can be proven to be antisymmetric whereas [Bleb] is not.
-*)
-Section Fle0.
-
-Variable prec : Z.
-Variable emax : Z.
-Context (Hprec : FLX.Prec_gt_0 prec).
-Context (Hemax : Prec_lt_emax prec emax).
-
-Definition float := binary_float prec emax.
-
-Definition Fle0 (x y : float) :=
- match x, y with
- | B754_zero s1, B754_zero s2 =>
- if negb s1 then negb s2
- else true
- | _, _ => Bleb x y
- end.
-
-Notation "+0" := (B754_zero false).
-Notation "-0" := (B754_zero true).
-
-Example Fle0_PP :
- Fle0 +0 +0 = true.
-Proof.
- reflexivity.
-Qed.
-
-Example Fle0_PN :
- Fle0 +0 -0 = false.
-Proof.
- reflexivity.
-Qed.
-
-Example Fle0_NP :
- Fle0 -0 +0 = true.
-Proof.
- reflexivity.
-Qed.
-
-Example Fle0_NN :
- Fle0 -0 -0 = true.
-Proof.
- reflexivity.
-Qed.
-
-
-Example Fle0_sign_true:
- forall (x y : float),
- x <> NaN ->
- y <> NaN ->
- Bsign x = true ->
- Bsign y = false ->
- Fle0 x y = true.
-Proof.
- intros.
- fdestruct x; fdestruct y.
- - now destruct s.
- - now destruct s.
- - now destruct s, s0.
-Qed.
-
-
-(**
- Contrary to Bleb, Fle0 is antisymmetric
- with respect to Coq's default equality
-*)
-Lemma Fle0_antysim:
- forall (x y : float),
- Fle0 x y = true ->
- Fle0 y x = true ->
- x = y.
-Proof.
- intros x y Hxy Hyx.
- fdestruct x; fdestruct y; try now destruct s.
- simpl in Hxy, Hyx.
- apply (Bleb_antisymm_strict _ _ _ _ (conj Hxy Hyx)).
- now destruct s.
-Qed.
-
-(**
- [Fle0] is included in [Bleb].
-*)
-Lemma Fle0_Bleb:
- forall (x y : float),
- Fle0 x y = true -> Bleb x y = true.
-Proof.
- fdestruct x; fdestruct y.
-Qed.
-
-(**
- [Fle0] is transitive
-*)
-Lemma Fle0_trans:
- forall (x y z : float),
- Fle0 x y = true -> Fle0 y z = true -> Fle0 x z = true.
-Proof.
- intros.
- fdestruct y; fdestruct x; fdestruct z;
- try (now destruct s, s0);
- try (now destruct s).
- apply (Bleb_trans _ _ _ H H0).
-Qed.
-
-Lemma Fle0_refl:
- forall (x : float),
- is_nan x = false ->
- Fle0 x x = true.
-Proof.
- intros. fdestruct x.
- now apply Beqb_Bleb, Beqb_refl.
-Qed.
-
-(* Inductive interv : Type :=
- | I_val : float -> interv
- | I_closed : forall (lo hi : float) (nan : bool) (H : Bltb lo hi = true), interv.
-
-Definition contains (i : interv) (x : float) : Prop :=
- match i with
- | I_val v => x = v
- | I_closed lo hi nan _ =>
- (x = NaN /\ nan = true) \/ lo <= x <= hi
- end. *)
-
-
-
-Inductive interv : Type :=
- | I_closed : forall (lo hi : float) (nan : bool) (H : Fle0 lo hi = true), interv
- | I_nan : interv.
-
-Definition contains (i : interv) (x : float) : Prop :=
- match i with
- | I_nan => x = NaN
- | I_closed lo hi nan _ =>
- (x = NaN /\ nan = true) \/ Fle0 lo x = true /\ Fle0 x hi = true
- end.
-
-Lemma contains_nan :
- forall (i : interv), contains i NaN ->
- (exists a b H, i = I_closed a b true H)
- \/ i = I_nan.
-Proof.
- intros [ ].
- + intros [ [_ ->] | ]; try easy.
- left; repeat eexists.
- + now right.
-Qed.
-
-Example szerop := I_closed (+0) (+0) false eq_refl.
-
-Example szerom := I_closed (-0) (-0) false eq_refl.
-
-Example contains_szerop :
- forall x, contains szerop x -> x = +0.
-Proof.
- intros x [ [Hx ? ] | ]; try easy.
- now apply Fle0_antysim.
-Qed.
-
-Example contains_szerom :
- forall x, contains szerom x -> x = -0.
-Proof.
- intros x [ [Hx ? ] | ]; try easy.
- now apply Fle0_antysim.
-Qed.
-
-Example szero := I_closed (-0) (+0) false eq_refl.
-
-Example contains_szero:
- forall x, contains szero x -> (x = -0 \/ x = +0).
-Proof.
- intros x [ [Hx ? ] | ]; try easy.
- fdestruct x; cbn in *.
- + now left.
- + now right.
- + now destruct s.
-Qed.
-
-Lemma Bsign_B2SF:
- forall ( x : float ), sign_SF (B2SF x) = Bsign x.
-Proof.
- fdestruct x.
-Qed.
-
-Lemma Bsign_Bplus :
- forall m (x y : float),
- Bsign x = Bsign y -> Bsign (Bplus m x y) = Bsign x.
-Proof.
- intros m x y H.
- fdestruct x; fdestruct y.
- pose proof (BinarySingleNaN.Bplus_correct _ _ _ _ m (B754_finite s m0 e e0) (B754_finite s0 m1 e1 e2) eq_refl eq_refl).
- destruct Raux.Rlt_bool; intuition.
- + destruct Raux.Rcompare eqn:E;
- replace s with s0 in *.
- * now destruct m, s0.
- * rewrite H3.
- destruct s0; try easy; simpl.
- apply Raux.Rcompare_Lt_inv in E.
- cbn in E.
- assert (@Defs.F2R Zaux.radix2 {| Defs.Fnum := Z.pos m0; Defs.Fexp := e |} >= 0)%R. unfold Defs.F2R; simpl.
- pose proof (IZR_pos m0).
- pose proof (Raux.bpow_gt_0 Zaux.radix2 e).
- nra.
- assert (@Defs.F2R Zaux.radix2 {| Defs.Fnum := Z.pos m1; Defs.Fexp := e1 |} >= 0)%R. unfold Defs.F2R; simpl.
- pose proof (IZR_pos m1).
- pose proof (Raux.bpow_gt_0 Zaux.radix2 e1).
- nra.
- nra.
- * rewrite H3.
- destruct s0; try easy; simpl.
- apply Raux.Rcompare_Gt_inv in E.
- cbn in E.
- pose proof (IZR_neg m0).
- pose proof (Raux.bpow_gt_0 Zaux.radix2 e).
- assert (@Defs.F2R Zaux.radix2 {| Defs.Fnum := Z.neg m0; Defs.Fexp := e |} <= 0)%R. unfold Defs.F2R; simpl. nra.
- pose proof (IZR_neg m1).
- pose proof (Raux.bpow_gt_0 Zaux.radix2 e1).
- assert (@Defs.F2R Zaux.radix2 {| Defs.Fnum := Z.neg m1; Defs.Fexp := e1 |} < 0)%R. unfold Defs.F2R; simpl. nra.
- nra.
- + replace s with s0. destruct s0, s; try easy.
- * rewrite <- Bsign_B2SF.
- rewrite H1. simpl.
- unfold binary_overflow.
- destruct overflow_to_inf; reflexivity.
- * rewrite <- Bsign_B2SF.
- rewrite H1. simpl.
- unfold binary_overflow.
- destruct overflow_to_inf; reflexivity.
-Qed.
-
-Lemma sum_to_0 :
- forall mode m e H m' e' H',
- Bplus mode (B754_finite true m e H) (B754_finite true m' e' H') <> -0.
-Proof.
- intros. intros Hcontr.
- pose proof (BinarySingleNaN.Bplus_correct _ _ _ _ mode (B754_finite true m e H) (B754_finite true m' e' H') eq_refl eq_refl).
- destruct Raux.Rlt_bool; intuition.
- + destruct Raux.Rcompare eqn:E.
- * apply Raux.Rcompare_Eq_inv in E.
- cbn in E.
- assert (@Defs.F2R Zaux.radix2 {| Defs.Fnum := Z.neg m; Defs.Fexp := e |} < 0)%R. unfold Defs.F2R; simpl.
- pose proof (IZR_neg m).
- pose proof (Raux.bpow_gt_0 Zaux.radix2 e).
- nra.
- assert (@Defs.F2R Zaux.radix2 {| Defs.Fnum := Z.neg m'; Defs.Fexp := e' |} < 0)%R. unfold Defs.F2R; simpl.
- pose proof (IZR_neg m').
- pose proof (Raux.bpow_gt_0 Zaux.radix2 e').
- nra.
- nra.
- * apply Raux.Rcompare_Lt_inv in E.
- apply Rlt_le in E.
- apply (Generic_fmt.round_le Zaux.radix2 (SpecFloat.fexp prec emax)
- (round_mode mode)) in E.
- rewrite Generic_fmt.round_0 in E by intuition.
- rewrite <- H1 in E.
- assert (B2R (Bplus mode (B754_finite true m e H) (B754_finite true m' e' H')) = 0%R) by now rewrite Hcontr.
- destruct E.
- - nra.
-
-Admitted.
-
-Theorem Fle0_is_Bleb_r:
- forall (x y : float),
- (y <> +0 /\ y <> -0) ->
- Fle0 x y = Bleb x y.
-Proof.
- fdestruct x; fdestruct y.
-Qed.
-
-Theorem Fle0_is_Bleb_l:
- forall (x y : float),
- (x <> +0 /\ x <> -0) ->
- Fle0 x y = Bleb x y.
-Proof.
- fdestruct x; fdestruct y.
-Qed.
-
-Theorem Bsign_Fle0:
- forall x y,
- is_nan x = false ->
- is_nan y = false ->
- Bsign x = true -> Bsign y = false -> Fle0 x y = true.
-Proof.
- intros.
- fdestruct x; fdestruct y.
- + now destruct s.
- + now destruct s.
- + now destruct s, s0.
-Qed.
-
-Theorem Bplus_pos:
- forall (x y : float) m,
- Fle0 -0 x = true ->
- Fle0 -0 y = true ->
- Fle0 -0 (Bplus m x y) = true.
-Proof.
- intros.
- pose proof Bsign_Bplus m x y.
- fdestruct x; fdestruct y.
- + now destruct m.
- + now destruct m.
- + simpl in H, H0.
- destruct s, s0; try easy.
- apply Bsign_Fle0; try easy.
- - now apply Bplus_finites_not_nan.
- - now apply H1.
-Qed.
-
-Theorem finite_Fle0_pos:
- forall (f : float), is_nan f = false -> Bsign f = false -> Fle0 -0 f = true.
-Proof.
- intros.
- fdestruct f.
- now destruct s.
-Qed.
-
-Theorem finite_Fle0_neg:
- forall (f : float), is_nan f = false -> Bsign f = true -> Fle0 f +0 = true.
-Proof.
- intros.
- fdestruct f.
- now destruct s.
-Qed.
-
-Inductive Rx0 : Type :=
- | Rx0_NaN : Rx0
- | Rx0_zero : bool -> Rx0
- | Rx0_inf : bool -> Rx0
- | Rx0_real : R -> Rx0.
-
-Definition B2Rx0 (f : float) : Rx0 :=
- match f with
- | B754_zero s => Rx0_zero s
- | B754_infinity s => Rx0_inf s
- | NaN => Rx0_NaN
- | B754_finite _ _ _ _ => Rx0_real (B2R f)
- end.
-
-Definition Rx0le (x y : Rx0) : bool :=
- match x with
- | Rx0_NaN => false
- | Rx0_zero s =>
- match y with
- | Rx0_NaN => false
- | Rx0_zero s' => if negb s then negb s' else true
- | Rx0_inf s' => negb s'
- | Rx0_real r => Raux.Rle_bool 0%R r
- end
- | Rx0_inf s =>
- match y with
- | Rx0_NaN => false
- | Rx0_zero s' => s
- | Rx0_inf s' =>
- if negb s then negb s' else true
- | Rx0_real r => s
- end
- | Rx0_real r =>
- if Raux.Req_bool r 0%R then
- match y with
- | Rx0_NaN => false
- | Rx0_zero s' => negb s'
- | Rx0_inf s' => negb s'
- | Rx0_real r' => Raux.Rle_bool r r'
- end
- else
- match y with
- | Rx0_NaN => false
- | Rx0_zero s' => Raux.Rle_bool r 0%R
- | Rx0_inf s' => negb s'
- | Rx0_real r' => Raux.Rle_bool r r'
- end
- end.
-
-Theorem B2Rx0_le:
- forall (x y : float),
- Rx0le (B2Rx0 x) (B2Rx0 y) = true -> x <= y.
-Proof.
- intros.
- destruct x as [[ ] | [ ] | | ] eqn:E1; destruct y as [ [ ] | [ ] | | ] eqn:E2; try easy.
- + repeat (unfold B2Rx0 in H); unfold Rx0le in H.
- apply Rleb_Rle in H; now apply Rle_Bleb.
- + repeat (unfold B2Rx0 in H); unfold Rx0le in H.
- apply Rleb_Rle in H; now apply Rle_Bleb.
- + repeat (unfold B2Rx0 in H); unfold Rx0le in H.
- destruct Raux.Req_bool eqn:E.
- * apply Reqb_Req in E.
- apply Rle_Bleb; auto; rewrite E; simpl; lra.
- * apply Rleb_Rle in H.
- now apply Rle_Bleb.
- + repeat (unfold B2Rx0 in H); unfold Rx0le in H.
- destruct Raux.Req_bool eqn:E.
- * apply Reqb_Req in E.
- apply Rle_Bleb; auto; rewrite E; simpl; lra.
- * apply Rleb_Rle in H.
- now apply Rle_Bleb.
- + repeat (unfold B2Rx0 in H); unfold Rx0le in H.
- now destruct Raux.Req_bool eqn:E.
- + repeat (unfold B2Rx0 in H); unfold Rx0le in H.
- now destruct Raux.Req_bool eqn:E.
- + repeat (unfold B2Rx0 in H); unfold Rx0le in H.
- destruct Raux.Req_bool eqn:E;
- apply Rle_Bleb; auto;
- now apply Rleb_Rle in H.
-Qed.
-
-Theorem Fle0_B2Rx0 :
- forall (x y : float),
- Fle0 x y = true -> Rx0le (B2Rx0 x) (B2Rx0 y) = true.
-Proof.
- intros.
- fdestruct x; fdestruct y;
- repeat (unfold B2Rx0);
- unfold Rx0le.
- - apply Raux.Rle_bool_true; now apply Bleb_Rle in H.
- - apply Raux.Rle_bool_true; now apply Bleb_Rle in H.
- - destruct Raux.Req_bool eqn:E; auto.
- + apply Reqb_Req in E.
- unfold B2R, Defs.F2R in E.
- destruct s; simpl in E.
- * pose proof (IZR_neg m);
- pose proof (Raux.bpow_gt_0 Zaux.radix2 e).
- nra.
- * pose proof (IZR_pos m);
- pose proof (Raux.bpow_gt_0 Zaux.radix2 e).
- nra.
- + apply Raux.Rle_bool_true.
- now apply Bleb_Rle in H.
- - destruct Raux.Req_bool eqn:E; auto.
- apply Raux.Rle_bool_true.
- now apply Bleb_Rle in H.
- - now destruct Raux.Req_bool eqn:E.
- - destruct Raux.Req_bool eqn:E;
- apply Bleb_Rle in H; auto;
- now apply Raux.Rle_bool_true.
-Qed.
-
-Theorem B2Rx0_Fle0 :
- forall (x y : float), Rx0le (B2Rx0 x) (B2Rx0 y) = true -> Fle0 x y = true.
-Proof.
- intros.
- fdestruct x; fdestruct y;
- repeat (unfold B2Rx0 in H);
- unfold Rx0le in H;
- apply Rle_Bleb; try easy.
- + now apply Rleb_Rle.
- + now apply Rleb_Rle.
- + destruct Raux.Req_bool eqn:E in H.
- - rewrite (Reqb_Req _ _ E); simpl; lra.
- - now apply Rleb_Rle in H.
- + destruct Raux.Req_bool eqn:E in H.
- - apply Reqb_Req in E.
- unfold B2R, Defs.F2R in E.
- destruct s; simpl in E.
- * pose proof (IZR_neg m);
- pose proof (Raux.bpow_gt_0 Zaux.radix2 e).
- nra.
- * pose proof (IZR_pos m);
- pose proof (Raux.bpow_gt_0 Zaux.radix2 e).
- nra.
- - now apply Rleb_Rle in H.
- + now destruct Raux.Req_bool eqn:E in H.
- + now destruct Raux.Req_bool eqn:E in H.
- + now destruct Raux.Req_bool eqn:E in H.
- + now destruct Raux.Req_bool eqn:E in H.
- + destruct Raux.Req_bool eqn:E in H.
- - rewrite (Reqb_Req _ _ E) in *.
- now apply Rleb_Rle in H.
- - now apply Rleb_Rle in H.
-Qed.
-
-Definition add (x y : Rx0) :=
- match x with
- | Rx0_NaN => x
- | Rx0_inf true =>
- match y with
- | Rx0_NaN => Rx0_NaN
- | Rx0_inf false => Rx0_NaN
- | _ => x
- end
- | Rx0_inf false =>
- match y with
- | Rx0_NaN => Rx0_NaN
- | Rx0_inf true => Rx0_NaN
- | _ => x
- end
- | Rx0_zero _ =>
- match y with
- | Rx0_zero _ => Rx0_real 0%R
- | _ => y
- end
- | Rx0_real r =>
- match y with
- | Rx0_NaN => Rx0_NaN
- | Rx0_inf _ => y
- | Rx0_zero _ => x
- | Rx0_real r' => Rx0_real (r + r')%R
- end
- end.
-
-Compute (add (Rx0_real R0) (Rx0_zero true)).
-Compute (add (Rx0_real R0) (Rx0_zero false)).
-
-Lemma Req_0_true:
- Raux.Req_bool 0 0 = true.
-Proof.
- now apply Raux.Req_bool_true.
-Qed.
-
-Definition add_Rx0le_mono_l :
- forall (x y z : Rx0),
- add x z <> Rx0_NaN ->
- add y z <> Rx0_NaN ->
- Rx0le x y = true -> Rx0le (add x z) (add y z) = true.
-Proof.
- intros.
- destruct x eqn:Ex, y eqn:Ey, z eqn:Ez; simpl; try easy;
- try (destruct b; try easy; destruct b0; try easy; destruct b1; try easy);
- try (rewrite Req_0_true; apply Raux.Rle_bool_true; lra).
- + destruct Raux.Req_bool eqn:E;
- apply Raux.Rle_bool_true; lra.
- + now destruct Raux.Req_bool eqn:E.
- + now destruct Raux.Req_bool eqn:E.
- + now destruct Raux.Req_bool eqn:E.
- + now destruct Raux.Req_bool eqn:E.
- + destruct Raux.Req_bool eqn:E; now destruct b0.
- + now destruct Raux.Req_bool eqn:E.
- + destruct Raux.Req_bool eqn:E.
- - rewrite (Reqb_Req _ _ E).
- apply Rleb_Rle in H1.
- apply Raux.Rle_bool_true.
- lra.
- - apply Raux.Rle_bool_true.
- apply Rleb_Rle in H1.
- lra.
- + destruct Raux.Req_bool eqn:E.
- - rewrite (Reqb_Req _ _ E).
- apply Raux.Rle_bool_true; lra.
- - apply Raux.Rle_bool_true.
- simpl in H1.
- destruct Raux.Req_bool eqn:E' in H1.
- * rewrite (Reqb_Req _ _ E'); lra.
- * now apply Rleb_Rle in H1.
- + destruct (Raux.Req_bool r 0) eqn:E.
- - rewrite (Reqb_Req _ _ E) in *.
- destruct (Raux.Req_bool (0 + r0) 0) eqn:E'.
- * rewrite Rplus_0_l, (Reqb_Req _ _ E') in *.
- apply Raux.Rle_bool_true; lra.
- * rewrite Rplus_0_l.
- apply Raux.Rle_bool_true; lra.
- - simpl in H1.
- rewrite E in H1.
- apply Rleb_Rle in H1.
- destruct (Raux.Req_bool (r + r0) 0) eqn:E';
- apply Raux.Rle_bool_true; lra.
- + destruct (Raux.Req_bool (r + r0) 0) eqn:E';
- destruct b; auto;
- simpl in H1;
- now destruct Raux.Req_bool.
- + simpl in H1.
- destruct (Raux.Req_bool r 0) eqn:E.
- - rewrite (Reqb_Req _ _ E), Rplus_0_l in *.
- destruct (Raux.Req_bool r1 0) eqn:E'.
- * now rewrite (Reqb_Req _ _ E'), Rplus_0_r in *.
- * apply Rleb_Rle in H1.
- apply Raux.Rle_bool_true; lra.
- - destruct (Raux.Req_bool (r + r1) 0) eqn:E'.
- * apply Reqb_Req in E'.
- assert (r = -r1)%R by lra.
- subst.
- apply Raux.Rle_bool_true.
- apply Rleb_Rle in H1.
- lra.
- * apply Raux.Rle_bool_true.
- apply Rleb_Rle in H1.
- lra.
-Qed.
-
-Definition round (m : mode) (r : Rx0) : Rx0 :=
- match r with
- | Rx0_NaN => Rx0_NaN
- | Rx0_real x =>
- if Raux.Req_bool x 0%R then
- Rx0_zero false
- (* match m with
- | mode_DN => Rx0_zero true
- | _ => Rx0_zero false
- end *)
- else if do_overflow prec emax m x then
- if overflow_to_inf m (sign x) then Rx0_inf (sign x)
- else Rx0_real (B2R (if sign x then Bopp (F_fmax _ _) else (F_fmax _ _)))
- else
- Rx0_real (Generic_fmt.round Zaux.radix2 (SpecFloat.fexp prec emax) (round_mode m) x)
- | _ => r
- end.
-
-Lemma round_Rx0le :
- forall m (x y : Rx0),
- Rx0le x y = true -> Rx0le (round m x) (round m y) = true.
-Proof.
- intros m [ ] [ ] Hxy; try easy; unfold Rx0le, round.
- + destruct Raux.Req_bool eqn:E.
- rewrite (Reqb_Req _ _ E) in *.
- simpl in Hxy.
- * destruct m, b; auto.
- * simpl in Hxy.
- assert (sign r = false).
- apply Rleb_Rle in Hxy.
- unfold sign.
- now apply Raux.Rlt_bool_false.
- rewrite H.
- destruct do_overflow, overflow_to_inf; auto.
- - apply Raux.Rle_bool_true.
- pose proof (F_fmax_ge_0 _ _).
- lra.
- - apply Raux.Rle_bool_true.
- rewrite <- (Generic_fmt.round_0 Zaux.radix2 (SpecFloat.fexp prec emax) (round_mode m)).
- apply Generic_fmt.round_le.
- now apply fexp_correct.
- intuition.
- now apply Rleb_Rle in Hxy.
- - apply Raux.Rle_bool_true.
- rewrite <- (Generic_fmt.round_0 Zaux.radix2 (SpecFloat.fexp prec emax) (round_mode m)).
- apply Generic_fmt.round_le.
- now apply fexp_correct.
- intuition.
- now apply Rleb_Rle in Hxy.
- + destruct Raux.Req_bool eqn:E.
- - now destruct b.
- - destruct do_overflow, overflow_to_inf; auto.
- now destruct b.
- + destruct Raux.Req_bool eqn:E.
- - simpl in Hxy. now destruct (Raux.Req_bool r 0).
- - destruct do_overflow, overflow_to_inf; auto;
- simpl in Hxy; now destruct (Raux.Req_bool r 0).
- + simpl in Hxy.
- destruct (Raux.Rcompare r 0) eqn:E.
- - rewrite (Raux.Rcompare_Eq_inv _ _ E) in *.
- rewrite Req_0_true in *.
- now destruct b.
- - pose proof (Raux.Rcompare_Lt_inv _ _ E).
- assert (Raux.Req_bool r 0 = false).
- apply Raux.Req_bool_false. lra.
- rewrite H0 in *.
- unfold sign.
- rewrite (Raux.Rlt_bool_true _ _ H).
- destruct (do_overflow prec emax m r) eqn:E1, (overflow_to_inf m true) eqn:E2; auto.
- * rewrite B2R_Bopp.
- rewrite <- (R2F_fmax _ _).
- assert (Raux.Req_bool (- R_fmax prec emax) 0 = false).
- apply Raux.Req_bool_false.
- assert (R_fmax prec emax > 0)%R.
- unfold R_fmax.
- unfold FLX.Prec_gt_0, Prec_lt_emax.
- admit.
- admit.
- rewrite H1.
- apply Raux.Rle_bool_true.
- rewrite (R2F_fmax _ _).
- replace 0%R with (@B2R prec emax +0) by auto.
- rewrite <- B2R_Bopp.
- apply Bleb_Rle; auto.
- (* *
-
- simpl in Hxy.
- destruct (Raux.Req_bool r 0) eqn:E.
- - now destruct b.
- - destruct do_overflow eqn:Er, overflow_to_inf; auto.
- * apply Rleb_Rle in Hxy.
- unfold sign.
- destruct (Raux.Req_bool_spec r 0); try easy.
- rewrite Raux.Rlt_bool_true by lra.
- reflexivity.
- * apply Rleb_Rle in Hxy.
- unfold sign.
- destruct (Raux.Req_bool_spec r 0); try easy.
- rewrite Raux.Rlt_bool_true by lra.
- unfold Rx0le.
- destruct Raux.Req_bool. *)
-
-Admitted.
-
-Theorem add_Fle0_mono :
- forall (x y z : float) m,
- Fle0 x y = true ->
- is_nan (Bplus m x z) = false ->
- is_nan (Bplus m y z) = false ->
- Fle0 (Bplus m x z) (Bplus m y z) = true.
-Proof.
- intros.
- fdestruct x; fdestruct y; try (fdestruct z; now destruct m).
- - now apply Fle0_refl.
- - fdestruct z; try now destruct m.
- now apply Fle0_refl.
- - fdestruct z. now destruct m.
- now apply Bplus_le_mono_l.
- - now apply Fle0_refl.
- - fdestruct z. now destruct m.
- now apply Bplus_le_mono_l.
- - fdestruct z.
- now apply Bplus_le_mono_l.
- - fdestruct z. now destruct m.
- simpl (Bplus m -0 _).
- rewrite Fle0_is_Bleb_r by easy.
- replace (B754_finite s0 m1 e1 e2) with
- (Bplus m -0 (B754_finite s0 m1 e1 e2)) by reflexivity.
- now apply Bplus_le_mono_l.
- - fdestruct z. now destruct m.
- simpl (Bplus m +0 _).
- rewrite Fle0_is_Bleb_r by easy.
- replace (B754_finite s0 m1 e1 e2) with
- (Bplus m +0 (B754_finite s0 m1 e1 e2)) by reflexivity.
- now apply Bplus_le_mono_l.
- - fdestruct z.
- simpl (Bplus m +oo _).
- rewrite Fle0_is_Bleb_r by easy.
- now apply infp_max.
- - fdestruct z.
- apply B2Rx0_Fle0.
- apply Fle0_B2Rx0 in H.
-Admitted.
-
-End Fle0.
-
diff --git a/farith2/thry/GenericFloat.v b/farith2/thry/GenericFloat.v
deleted file mode 100644
index bd3de1fa2..000000000
--- a/farith2/thry/GenericFloat.v
+++ /dev/null
@@ -1,482 +0,0 @@
-From Flocq Require Import Core.Core IEEE754.BinarySingleNaN IEEE754.Bits.
-From Coq Require Import Program ZArith Bool Lia Reals Qreals ZBits.
-Require Import Assert Utils Interval Qextended Rextended Op.
-
-Definition cprec mw := (Z.succ mw)%Z.
-
-Definition cemax ew := Zpower 2 (ew - 1).
- (* (if Z.eqb ew 1 then 1 else Z.pow_pos 2 (Z.to_pos (ew - 1)))%Z. *)
-
-Definition check_param mw ew :=
- andb (andb (0 <? mw)%Z (0 <? ew)%Z) (cprec mw <? cemax ew)%Z.
-
-Record Generic { v } : Type := {
- mw : Z;
- ew : Z;
- HG: check_param mw ew = true;
- value : v (cprec mw) (cemax ew);
- }.
-
-Lemma check_param_is_Hprec : forall mw ew, (check_param mw ew = true) -> FLX.Prec_gt_0 (cprec mw).
-Proof.
- intros mw ew H.
- unfold check_param in H.
-rewrite !Bool.andb_true_iff in H.
-rewrite <- !Zlt_is_lt_bool in H.
-intuition.
-unfold FLX.Prec_gt_0.
-unfold cprec.
-lia.
-Qed.
-
-Lemma check_param_is_Hw : forall mw ew, (check_param mw ew = true) -> FLX.Prec_gt_0 mw.
-Proof.
- intros mw ew H.
- unfold check_param in H.
-rewrite !Bool.andb_true_iff in H.
-rewrite <- !Zlt_is_lt_bool in H.
-intuition.
-Qed.
-
-Lemma check_param_is_Hemax : forall mw ew, (check_param mw ew = true) -> Prec_lt_emax (cprec mw) (cemax ew).
-Proof.
- intros mw ew H.
- unfold check_param in H.
-rewrite !Bool.andb_true_iff in H.
-rewrite <- !Zlt_is_lt_bool in H.
-intuition.
-Qed.
-
-Definition prec { v } (f: @Generic v) := cprec (mw f).
-
-Definition emax { v } (f: @Generic v) := cemax (ew f).
-
-Definition Hprec { v } (f: @Generic v) := check_param_is_Hprec (mw f) (ew f) (HG f).
-
-Definition Hemax { v } (f: @Generic v) := check_param_is_Hemax (mw f) (ew f) (HG f).
-
-Definition mk_generic { v } mw ew (H: check_param mw ew = true) (x: forall prec emax, FLX.Prec_gt_0 prec -> Prec_lt_emax prec emax -> v prec emax) : @Generic v :=
- let prec := cprec mw in
- let emax := cemax ew in
- let Hprec : FLX.Prec_gt_0 prec := check_param_is_Hprec _ _ H in
- let Hemax : Prec_lt_emax prec emax := check_param_is_Hemax _ _ H in
- {|
- mw := mw;
- ew := ew;
- HG := H;
- value := x prec emax Hprec Hemax;
- |}.
-
-Program Definition unify { v } (p e p' e' : Z) (f : v p' e') (Hp : p = p') (Hp : e = e') : v p e := f.
-
-Program Definition same_format_cast {v } {p e p' e' : Z} (H : ((p =? p') && (e =? e') = true)%Z) (f : v p' e') : v p e := f.
-Next Obligation.
- apply andb_true_iff in H as [A _].
- now rewrite (proj1 (Z.eqb_eq _ _) A).
-Defined.
-Next Obligation.
- apply andb_true_iff in H as [_ B].
- now rewrite (proj1 (Z.eqb_eq _ _) B).
-Defined.
-
-
-Definition same_format { v1 v2 } (x : @Generic v1) (y : @Generic v2) : bool :=
- Z.eqb (prec x) (prec y) && Z.eqb (emax x) (emax y).
-
-Definition mk_with {v1 v2} (x : @Generic v1) (y:v2 (prec x) (emax x)) : @Generic v2 :=
- {|
- mw := mw x;
- ew := ew x;
- HG := HG x;
- value := y;
- |}.
-
-
-Definition mk_witho {v1 v2 } (x:@Generic v1) (y:option (v2 (prec x) (emax x))) : option (@Generic v2) :=
- match y with
- | Some r => Some (mk_with x r)
- | None => None
- end.
-
-
-Module GenericFloat.
-
- Definition t : Type := @Generic binary_float.
-
- Module F_inhab.
- Definition t : Type := t.
- Program Definition dummy := {|
- mw := 24;
- ew := 128;
- value := BinarySingleNaN.B754_nan;
- HG := _;
- |}.
- Solve All Obligations with easy.
- End F_inhab.
-
- Module AssertF := Assert (F_inhab).
-
- Module B_inhab.
- Definition t : Type := bool.
- Program Definition dummy := true.
- Solve All Obligations with easy.
- End B_inhab.
-
- Module AssertB := Assert (B_inhab).
-
- Definition of_q' prec emax Hprec Hemax (m : mode) (q : Qx) : binary_float prec emax :=
- match Qx_classify q with
- | Qx_ZERO _ _ _ _ => B754_zero false
- | Qx_INF _ _ _ => B754_infinity false
- | Qx_MINF _ _ _ => B754_infinity true
- | Qx_UNDEF _ _ _ => B754_nan
- | Qx_NZERO _ _ _ _ _ =>
- match num q with
- | Z0 => B754_nan (** absurd *)
- | Z.pos pn =>
- SF2B _ (proj1 (Bdiv_correct_aux prec emax Hprec Hemax m false pn 0%Z false (Z.to_pos (den q)) 0%Z))
- | Z.neg nn =>
- SF2B _ (proj1 (Bdiv_correct_aux prec emax Hprec Hemax m true nn 0%Z false (Z.to_pos (den q)) 0%Z))
- end
- end.
-
- (* Lemma of_q_correct' : forall prec emax Hprec Hemax m q, Q2Rx q = B2Rx (of_q' prec emax Hprec Hemax m q). *)
- (* Proof. *)
- (* intros prec emax Hprec Hemax m q. *)
- (* unfold of_q', Q2Rx; destruct (Qx_classify q). *)
- (* - rewrite e, e0. reflexivity. *)
- (* - rewrite e, e0. reflexivity. *)
- (* - rewrite e, e0. reflexivity. *)
- (* - rewrite e, e0. *)
- (* destruct (Z.pos pq =? 0)%Z; try reflexivity. *)
- (* unfold Rdefinitions.Q2R; simpl. *)
- (* now rewrite Rmult_0_l. *)
- (* - rewrite e. destruct s; rewrite e0; simpl. *)
- (* * replace (Q2R (Z.pos nq # pq)) with *)
- (* ((F2R (Float radix2 (cond_Zopp false (Z.pos nq)) 0)) *)
- (* / (F2R (Float radix2 (cond_Zopp false (Z.pos pq)) 0)))%R. *)
- (* exact (Bdiv_correct_aux' mode false nq 0 false pq 0). *)
- (* compute [F2R cond_Zopp Q2R]; simpl. *)
- (* rewrite <- !P2R_INR. *)
- (* rewrite !Rmult_1_r. *)
- (* reflexivity. *)
- (* * replace (Q2R (Z.neg nq # pq)) with *)
- (* ((F2R (Float radix2 (cond_Zopp true (Z.pos nq)) 0)) *)
- (* / (F2R (Float radix2 (cond_Zopp false (Z.pos pq)) 0)))%R. *)
- (* exact (Bdiv_correct_aux' mode true nq 0 false pq 0). *)
- (* compute [F2R cond_Zopp Q2R]; simpl. *)
- (* rewrite <- !P2R_INR. *)
- (* rewrite !Rmult_1_r. *)
- (* reflexivity. *)
- (* Qed. *)
-
- Definition of_q mw ew (m : mode) (q : Qx) : t :=
- AssertF.assert (check_param mw ew)
- (fun H => mk_generic mw ew H (fun prec emax Hprec Hemax => of_q' prec emax Hprec Hemax m q)).
-
- Definition add (m : mode) (x y : t) : t :=
- AssertF.assert (same_format x y) (fun H => mk_with x (@Bplus _ _ (Hprec x) (Hemax x) m (value x) (same_format_cast H (value y)))).
-
- Definition sub (m : mode) (x y : t) : t :=
- AssertF.assert (same_format x y) (fun H => mk_with x (@Bminus _ _ (Hprec x) (Hemax x) m (value x) (same_format_cast H (value y)))).
-
- Definition mul (m : mode) (x y : t) : t :=
- AssertF.assert (same_format x y) (fun H => mk_with x (@Bmult _ _ (Hprec x) (Hemax x) m (value x) (same_format_cast H (value y)))).
-
- Definition div (m : mode) (x y : t) : t :=
- AssertF.assert (same_format x y) (fun H => mk_with x (@Bdiv _ _ (Hprec x) (Hemax x) m (value x) (same_format_cast H (value y)))).
-
- Program Definition fma (m : mode) (x y z : t) : t :=
- AssertF.assert (andb (same_format x y) (same_format x z)) (fun H => mk_with x (@Bfma _ _ (Hprec x) (Hemax x) m (value x) (same_format_cast _ (value y)) (same_format_cast _ (value z)))).
- Next Obligation.
- rewrite !Bool.andb_true_iff in H.
- exact (proj1 H).
- Defined.
- Next Obligation.
- rewrite !Bool.andb_true_iff in H.
- exact (proj2 H).
- Defined.
-
- Definition sqrt (m : mode) (x : t) : t :=
- mk_with x (@Bsqrt _ _ (Hprec x) (Hemax x) m (value x)).
-
- Definition abs (x : t) : t :=
- mk_with x (@Babs _ _ (value x)).
-
- Definition succ (x : t) : t :=
- mk_with x (@Op.Fsucc _ _ (Hprec x) (Hemax x) (value x)).
-
- Definition pred (x : t) : t :=
- mk_with x (@Op.Fpred _ _ (Hprec x) (Hemax x) (value x)).
-
- Definition neg (x : t) : t :=
- mk_with x (@Op.Fneg _ _ (value x)).
-
- Fixpoint least_bit_Pnat (n : positive) :=
- match n with
- | xH => O
- | xO p => S (least_bit_Pnat p)
- | xI p => O
- end.
-
-
- Definition shiftr_pos a p := Wf_nat.iter_nat p _ Z.div2 a.
-
- Lemma shiftr_pos_is_shiftr :
- forall a p, shiftr_pos a p = Z.shiftr a (Z.of_nat p).
- Proof.
- intros.
- destruct p.
- reflexivity.
- unfold shiftr_pos, Z.shiftr, Z.shiftl, Z.of_nat, Z.opp.
- rewrite Pos2Nat.inj_iter.
- rewrite SuccNat2Pos.id_succ.
- reflexivity.
- Qed.
-
- Lemma least_bit_shiftr_pos :
- forall m (b:bool),
- let e' := least_bit_Pnat m in
- let m' := if b then Z.neg m else Z.pos m in
- let m'' := shiftr_pos m' e' in
- Z.odd m'' = true.
- Proof.
- induction m; intro b.
- - destruct b;reflexivity.
- - assert (H:= IHm b);
- destruct b;
- replace (least_bit_Pnat m~0) with (S (least_bit_Pnat m)) in * by reflexivity;
- intros e' m';
- replace (shiftr_pos m' e') with (shiftr_pos (Z.div2 m') (least_bit_Pnat m)) by
- (unfold shiftr_pos, e'; rewrite nat_rect_succ_r; reflexivity).
- * replace (Z.div2 m') with (Z.neg m) by reflexivity.
- exact H.
- * replace (Z.div2 m') with (Z.pos m) by reflexivity.
- exact H.
- - destruct b; reflexivity.
- Qed.
-
-
- Lemma gcd_odd_pow_2:
- forall (m:positive) n,
- match m with xO _ => False | _ => True end ->
- Pos.gcd m (Pos.shiftl 1%positive (Npos n)) = 1%positive.
- Proof.
- destruct m as [p|p|]; intros n H; destruct H; simpl.
- - induction n using Pos.peano_ind.
- * compute [Pos.iter Z.mul Pos.mul].
- unfold Pos.gcd.
- replace (Pos.size_nat 2) with (2)%nat by reflexivity.
- simpl.
- replace (Pos.size_nat p + 2)%nat with (S (S (Pos.size_nat p))) by auto with *.
- reflexivity.
- * rewrite Pos.iter_succ.
- unfold Pos.gcd.
- simpl.
- replace (Pos.size_nat p + S (Pos.size_nat (Pos.iter xO 1%positive n)))%nat
- with (S (Pos.size_nat p + Pos.size_nat (Pos.iter xO 1%positive n))) by auto with *.
- exact IHn.
- - unfold Pos.gcd.
- reflexivity.
- Qed.
-
- Lemma to_q (f:t) : Qx.
- Proof.
- refine (match value f with
- | B754_zero _ => Qx_zero
- | B754_infinity b => if b then Qx_minus_inf else Qx_inf
- | B754_nan => Qx_undef
- | B754_finite b m e _ =>
- let e' := least_bit_Pnat m in
- let m' := if b then Z.neg m else Z.pos m in
- let e'' := (e + (Z.of_nat e'))%Z in
- match e'' with
- | Z0 => Qxmake (shiftr_pos m' e') 1%Z (refl_equal _) _
- | Z.pos _ => Qxmake (Z.shiftl m' e)%Z 1%Z (refl_equal _) _
- | Z.neg p => Qxmake (shiftr_pos m' e') (Z.shiftl 1%Z (Z.pos p)) _ _
- end
- end
- ).
- - rewrite Z.gcd_1_r.
- reflexivity.
- - rewrite Z.gcd_1_r.
- reflexivity.
- - rewrite Z.shiftl_1_l.
- apply Z.leb_le.
- apply Z.lt_le_incl.
- apply Zpower_pos_gt_0.
- reflexivity.
- - assert (Z.shiftl 1 (Z.pos p) =? 0 = false)%Z by
- (rewrite Z.shiftl_1_l;
- apply Z.eqb_neq;
- apply Z.neq_sym;
- apply Z.lt_neq;
- exact (Zpower_pos_gt_0 2%Z p (refl_equal _))).
- rewrite H.
- assert (Z.odd (shiftr_pos m' e') = true) by (exact (least_bit_shiftr_pos m b)).
- destruct (shiftr_pos m' e'); clear H e0 e' m' e''.
- discriminate H0.
- rewrite <- (shift_equiv _ _ (Pos2Z.is_nonneg _)).
- replace (shift (Z.pos p) 1) with (shift_pos p 1%positive) by reflexivity.
- rewrite shift_pos_equiv.
- compute [Z.gcd].
- rewrite gcd_odd_pow_2.
- reflexivity.
- unfold Z.odd in H0.
- destruct p0; [exact I| discriminate H0| exact I].
- rewrite <- (shift_equiv _ _ (Pos2Z.is_nonneg _)).
- replace (shift (Z.pos p) 1) with (shift_pos p 1%positive) by reflexivity.
- rewrite shift_pos_equiv.
- compute [Z.gcd].
- rewrite gcd_odd_pow_2.
- reflexivity.
- unfold Z.odd in H0.
- destruct p0; [exact I| discriminate H0| exact I].
- Defined.
-
- Definition le (x y : t) : bool :=
- AssertB.assert (same_format x y) (fun H => (@Bleb _ _ (value x) (same_format_cast H (value y)))).
-
- Definition lt (x y : t) : bool :=
- AssertB.assert (same_format x y) (fun H => (@Bltb _ _ (value x) (same_format_cast H (value y)))).
-
- Definition eq (x y : t) : bool :=
- AssertB.assert (same_format x y) (fun H => (@Beqb _ _ (value x) (same_format_cast H (value y)))).
-
- Definition ge (x y : t) : bool :=
- AssertB.assert (same_format x y) (fun H => (@Bleb _ _ (same_format_cast H (value y)) (value x))).
-
- Definition gt (x y : t) : bool :=
- AssertB.assert (same_format x y) (fun H => (@Bltb _ _ (same_format_cast H (value y)) (value x))).
-
-(** ** 4. convertions to and from [Z] and [Q]*)
-
- Program Definition of_bits' mw ew (H:check_param mw ew = true) (b : Z) : binary_float (cprec mw) (cemax ew) :=
- match Bits.binary_float_of_bits mw ew _ _ _ b with
- | Binary.B754_nan _ _ _ _ _ => B754_nan
- | Binary.B754_zero _ _ s => B754_zero s
- | Binary.B754_infinity _ _ s => B754_infinity s
- | Binary.B754_finite _ _ s m e H => B754_finite s m e H
- end.
- Next Obligation.
- unfold check_param in H.
- rewrite !Bool.andb_true_iff in H.
- rewrite <- !Zlt_is_lt_bool in H.
- intuition.
- Defined.
- Next Obligation.
- unfold check_param in H.
- rewrite !Bool.andb_true_iff in H.
- rewrite <- !Zlt_is_lt_bool in H.
- intuition.
- Defined.
- Next Obligation.
- unfold check_param in H.
- rewrite !Bool.andb_true_iff in H.
- rewrite <- !Zlt_is_lt_bool in H.
- intuition.
- Defined.
-
- Definition of_bits mw ew (z : Z.t) : t :=
- AssertF.assert (check_param mw ew)
- (fun H =>
- {|
- mw := mw;
- ew := ew;
- HG := H;
- value := of_bits' mw ew H z;
- |}
-).
-
- Definition pl_cst mw := (Zaux.iter_nat xO (Z.to_nat (Z.pred mw)) xH)%Z.
-
- Lemma pl_valid mw (Hw:Prec_gt_0 mw) : (Z.pos (Digits.digits2_pos (pl_cst mw)) <? (cprec mw))%Z = true.
- Proof.
- assert (G:forall n, Digits.digits2_Pnat (Zaux.iter_nat xO n xH)%Z = n).
- - induction n.
- * reflexivity.
- * rewrite iter_nat_S; simpl.
- rewrite IHn; reflexivity.
- - rewrite Digits.Zpos_digits2_pos.
- rewrite <- Digits.Z_of_nat_S_digits2_Pnat.
- unfold pl_cst, cprec. unfold Prec_gt_0 in Hw.
- rewrite G;clear G.
- rewrite Nat2Z.inj_succ.
- rewrite Z2Nat.id; [rewrite Z.ltb_lt | ]; lia.
- Qed.
-
- Definition to_bits (f : t) : Z :=
- match value f with
- | B754_nan =>
- Bits.bits_of_binary_float (mw f) (ew f) (Binary.B754_nan (prec f) (emax f) true (pl_cst (mw f)) (pl_valid (mw f) (check_param_is_Hw _ _ (HG f))))
- | B754_zero s => Bits.bits_of_binary_float (mw f) (ew f) (Binary.B754_zero (prec f) (emax f) s)
- | B754_infinity s => Bits.bits_of_binary_float (mw f) (ew f) (Binary.B754_infinity (prec f) (emax f) s)
- | B754_finite s m e H => Bits.bits_of_binary_float (mw f) (ew f) (Binary.B754_finite (prec f) (emax f) s m e H)
- end.
-
- Definition nan mw ew : t :=
- AssertF.assert (check_param mw ew) (fun H => mk_generic mw ew H (fun _ _ _ _ => B754_nan)).
-
- Definition zero mw ew b : t :=
- AssertF.assert (check_param mw ew) (fun H => mk_generic mw ew H (fun _ _ _ _ => B754_zero b)).
-
- Definition inf mw ew b : t :=
- AssertF.assert (check_param mw ew) (fun H => mk_generic mw ew H (fun _ _ _ _ => B754_infinity b)).
-
-
-End GenericFloat.
-
-Module GenericInterval.
-
- Definition t : Type := @Generic Interval.
-
- Module I_inhab.
- Definition t : Type := t.
- Program Definition dummy : t := {|
- mw := 23;
- ew := 8;
- value := Intv 24 128 -oo +oo true;
- HG := _;
- |}.
- Solve All Obligations with easy.
- End I_inhab.
-
- Module AssertI := Assert (I_inhab).
-
- Module O_inhab.
- Definition t : Type := option t.
- Program Definition dummy : t := None.
- Solve All Obligations with easy.
- End O_inhab.
-
- Module AssertO := Assert (O_inhab).
-
- Definition inter (x:t) (y:t) : option t :=
- AssertO.assert (same_format x y) (fun H =>
- let r := inter (prec x) (emax x) (value x) (same_format_cast H (value y)) in
- match r with
- | Some r => Some (mk_with x (r : Interval _ _))
- | None => None
- end ).
-
- Definition add (m:mode) (x:t) (y:t) : t :=
- AssertI.assert (same_format x y) (fun H =>
- mk_with x (Iadd (prec x) (emax x) (Hprec x) (Hemax x) m (value x) (same_format_cast H (value y)))
- ).
-
- Definition ge (x:t) : option t :=
- mk_witho x (Ige (prec x) (emax x) (value x)).
- Definition gt (x:t) : option t :=
- mk_witho x (Igt (prec x) (emax x) (value x)).
- Definition le (x:t) : option t :=
- mk_witho x (Ile (prec x) (emax x) (value x)).
- Definition lt (x:t) : option t :=
- mk_witho x (Ilt (prec x) (emax x) (value x)).
- Definition singleton (x:GenericFloat.t) : t :=
- mk_with x (singleton _ _ (value x)).
- Definition is_singleton (x:t) : option GenericFloat.t :=
- mk_witho x (is_singleton _ _ (value x)).
- Definition top (mw:Z) (ew:Z) : t :=
- AssertI.assert (check_param mw ew) (fun H => @mk_generic Interval mw ew H (fun prec emax _ _ => top prec emax)).
-
-End GenericInterval.
diff --git a/farith2/thry/Interval.v b/farith2/thry/Interval.v
deleted file mode 100644
index 2a796b9ed..000000000
--- a/farith2/thry/Interval.v
+++ /dev/null
@@ -1,512 +0,0 @@
-From Flocq Require Import IEEE754.BinarySingleNaN.
-From Coq Require Import QArith Psatz Reals Extraction.
-Require Import Utils Correction_thms Rextended.
-
-(*********************************************************
- Interval arithmetic over floatting points
-**********************************************************)
-
-Section Finterval.
-
-Variable prec : Z.
-Variable emax : Z.
-Context (Hprec : FLX.Prec_gt_0 prec).
-Context (Hemax : Prec_lt_emax prec emax).
-
-Definition float := binary_float prec emax.
-
-Inductive Interval' :=
- | Inan : Interval'
- | Intv : forall (lo hi : float) (nan : bool), Interval'.
-
-Definition valid (I : Interval') :=
- match I with
- | Intv lo hi _ => lo <= hi
- | _ => True
- end.
-
-Definition valid_opt (I : option Interval') :=
- match I with
- | Some i => valid i
- | _ => True
- end.
-
-Definition Interval := { I : Interval' | valid I }.
-
-Definition Interval_opt := option Interval.
-
-Program Definition contains (I : Interval') (x : float) : Prop :=
- match I with
- | Inan => is_nan x = true
- | Intv lo hi nan =>
- lo <= x <= hi \/ (is_nan x && nan = true)
- end.
-
-Definition contains_opt' (I : option Interval') (x : float) : Prop :=
- match I with
- | None => False
- | Some i => contains i x
- end.
-
-Definition contains_opt (I : option Interval) (x : float) : Prop :=
- match I with
- | None => False
- | Some i => contains (proj1_sig i) x
- end.
-
-Program Definition to_Interval_opt (I: option Interval') (P:valid_opt I) : Interval_opt :=
- match I with
- | None => None
- | Some J => Some (J:Interval)
- end.
-
-Lemma contains_to_Interval_opt (I: option Interval') (P:valid_opt I):
- forall x, contains_opt (to_Interval_opt I P) x = contains_opt' I x.
-Proof.
- intros x.
- destruct I;reflexivity.
-Qed.
-
-
- Program Definition top : Interval := Intv -oo +oo true.
-
- Program Definition bot : Interval_opt := None.
-
- Lemma top_correct :
- forall (x : float), contains (proj1_sig top) x.
- Proof with auto.
- unfold top, contains; fdestruct x; simpl...
- Qed.
-
- Lemma bot_correct :
- forall (x : float), contains_opt bot x -> False.
- Proof with auto.
- unfold bot, contains; fdestruct x.
- Qed.
-
- Program Definition is_singleton (I : Interval) : option float :=
- match proj1_sig I with
- | Inan => Some NaN
- | Intv a b n =>
- if Beqb a b && (negb (Beqb a (B754_zero false))) && negb n then Some a
- else None
- end.
-
- Program Definition s0 : Interval := Intv (B754_zero false) (B754_zero true) false.
-
- Program Theorem is_singleton_correct :
- forall (I : Interval) (x : float), (is_singleton I = Some x) -> (forall y, contains I y -> x = y).
- Proof.
- intros [[| a b n] H] x; cbn.
- - intros H1; inversion H1; fdestruct y.
- - intros H' y [[H1 H2] | H2].
- + destruct (Beqb a b) eqn:?E, (negb n) eqn:?E, (negb (Beqb a (B754_zero false))) eqn:?; try easy; simpl in *.
- assert (a <= y <= a) by eauto using E, Beqb_symm, Beqb_Bleb, Bleb_trans.
- apply Bleb_antisymm_strict in H0.
- * inversion H'; subst; reflexivity.
- * now apply Bool.negb_true_iff in Heqb0.
- + destruct (Beqb a b) eqn:?E, (negb n) eqn:?E, (negb (Beqb a (B754_zero false))) eqn:?; try easy; simpl in *.
- destruct n; try easy.
- fdestruct y.
- Qed.
-
- Program Definition singleton (x : float) : Interval :=
- match x with
- | B754_nan => Inan
- | _ => Intv x x false
- end.
- Next Obligation.
- apply Bleb_refl.
- fdestruct x.
- Defined.
-
- Program Theorem singleton_correct :
- forall (x : float), Beqb x (B754_zero true) = false -> is_singleton (singleton x) = Some x.
- Proof.
- intros [ [ ] | [ ] | | [ ] ] H; try easy; cbn.
- - rewrite Z.compare_refl, Pcompare_refl; reflexivity.
- - rewrite Z.compare_refl, Pcompare_refl; reflexivity.
- Qed.
-
-Program Definition inter' (I1 I2 : Interval') : option Interval' :=
- match I1, I2 with
- | Inan, Inan => Some Inan
- | Inan, Intv _ _ nan =>
- if nan then Some Inan else None
- | Intv _ _ nan, Inan =>
- if nan then Some (Inan) else None
- | Intv lo1 hi1 nan1, Intv lo2 hi2 nan2 =>
- if Bltb hi1 lo2 || Bltb hi2 lo1 then
- if nan1 && nan2 then Some Inan else None
- else
- Some (Intv (Bmax lo1 lo2) (Bmin hi1 hi2) (nan1 && nan2))
- end.
-
-Ltac ieasy :=
- simpl in *; try easy; try (intuition; fail).
-
-Ltac sdestruct x :=
- try destruct x; simpl; easy.
-
-Program Definition inter (I1 I2 : Interval) : Interval_opt :=
- to_Interval_opt (inter' I1 I2) _.
-Next Obligation.
- destruct I1 as [[|lo1 hi1 nan1] H1], I2 as [[|lo2 hi2 nan2] H2]; ieasy; try (now destruct nan1 || now destruct nan2).
- case (Bltb (hi1) (lo2)) eqn:?, (Bltb (hi2) (lo1)) eqn:?; simpl; try (destruct nan1, nan2; simpl; easy).
- pose proof (le_not_nan_l _ _ H1).
- pose proof (le_not_nan_r _ _ H2).
- pose proof (le_not_nan_r _ _ H1).
- pose proof (le_not_nan_l _ _ H2).
- auto using Bmax_le, Bmin_le, Bltb_false_Bleb.
-Defined.
-
-Lemma contains_opt_inter I1 I2:
- forall x, contains_opt (inter I1 I2) x = contains_opt' (inter' (proj1_sig I1) (proj1_sig I2)) x.
-Proof.
- intros x. unfold inter. rewrite contains_to_Interval_opt.
- reflexivity.
-Qed.
-
-Program Lemma inter_precise_l :
- forall I1 I2, forall x, contains_opt (inter I1 I2) x -> contains I1 x.
-Proof with auto.
- intros [[|lo1 hi1 nan1] H1] [[|lo2 hi2 nan2] H2] x Hx; rewrite contains_opt_inter in Hx; simpl in *...
- + destruct nan2; fdestruct x.
- + right; destruct nan1; fdestruct x.
- + case (Bltb hi1 lo2) eqn:?, (Bltb hi2 lo1) eqn:?; simpl in *;
- try (right; destruct nan1, nan2; simpl in *; fdestruct x; fail).
- destruct Hx as [[Hc1 Hc2] | H ].
- - left; split; [ apply (Bmax_le_inv _ _ _ _ _ Hc1) | apply (Bmin_le_inv _ _ _ _ _ Hc2) ].
- - repeat rewrite andb_true_iff in H; intuition.
-Qed.
-
-Program Lemma inter_precise_r :
- forall I1 I2, forall x, contains_opt (inter I1 I2) x -> contains I2 x.
-Proof with auto.
- intros [[|lo1 hi1 nan1] H1] [[|lo2 hi2 nan2] H2] x Hx; rewrite contains_opt_inter in Hx; simpl in *...
- + right; destruct nan2; fdestruct x.
- + destruct nan1; fdestruct x.
- + case (Bltb hi1 lo2) eqn:?, (Bltb hi2 lo1) eqn:?; simpl in *;
- try (right; destruct nan1, nan2; simpl in *; fdestruct x; fail).
- destruct Hx as [[Hc1 Hc2] | H ].
- - left; split; [ apply (Bmax_le_inv _ _ _ _ _ Hc1) | apply (Bmin_le_inv _ _ _ _ _ Hc2) ].
- - repeat rewrite andb_true_iff in H; intuition.
-Qed.
-
-Program Lemma inter_correct :
- forall (I1 I2 : Interval), forall x, contains I1 x -> contains I2 x -> contains_opt (inter I1 I2) x.
-Proof with auto.
- intros [[|lo1 hi1 nan1] H1] [[|lo2 hi2 nan2] H2] x Hx1 Hx2; rewrite contains_opt_inter; simpl in *...
- - fdestruct x; destruct nan2, Hx2; try easy.
- - fdestruct x; destruct nan1, Hx1; try easy.
- - pose proof (le_not_nan_l _ _ H1).
- pose proof (le_not_nan_r _ _ H1).
- pose proof (le_not_nan_l _ _ H2).
- pose proof (le_not_nan_r _ _ H2).
- destruct Hx1 as [[Hc1 Hc1'] |], Hx2 as [[Hc2 Hc2'] |]; try (fdestruct x ; fail).
- + pose proof (Hlt1 := Bleb_trans _ _ _ Hc2 Hc1').
- apply Bleb_true_Bltb in Hlt1...
- pose proof (Hlt2 := Bleb_trans _ _ _ Hc1 Hc2').
- apply Bleb_true_Bltb in Hlt2...
- rewrite Hlt1, Hlt2; simpl; left; split; auto using Bmax_le, Bmin_le.
- + fdestruct x; destruct nan2, nan1, (Bltb hi1 _), (Bltb hi2); simpl; try easy.
- now right.
-Qed.
-
-Definition Iadd' (m : mode) (I1 I2 : Interval') : Interval' :=
- match I1, I2 with
- | Inan, _ => Inan
- | _, Inan => Inan
- | Intv l h n, Intv l' h' n' =>
- let sum1 := Bplus m l l' in
- let sum2 := Bplus m h h' in
- match is_nan sum1 with
- | true =>
- match is_nan sum2 with
- | true => Inan
- | false => Intv +oo +oo true
- end
- | false =>
- match is_nan sum2 with
- | true => Intv -oo -oo true
- | false => Intv sum1 sum2 (n || n' || (Beqb h +oo && Beqb l' -oo) || (Beqb h' +oo && Beqb l -oo))
- end
- end
- end.
-
-Program Definition Iadd (m : mode) (I1 I2 : Interval) : Interval :=
- Iadd' m I1 I2.
-Next Obligation.
- destruct I1 as [[|l1 h1] H1], I2 as [[|l2 h2] H2]; simpl in *; auto.
- destruct (is_nan (Bplus m l1 l2)) eqn:E1, (is_nan (Bplus m h1 h2)) eqn:E2; try easy; simpl.
- now apply Bplus_le_compat.
-Qed.
-
-Program Lemma Iadd_correct :
- forall m (I1 I2 : Interval) (x y : float), contains I1 x -> contains I2 y -> contains (Iadd m I1 I2) (Bplus m x y).
-Proof with auto.
- intros m [[|l1 h1] H1] [[|l2 h2] H2] x y Hx Hy; simpl in *; try (fdestruct x; fdestruct y; fail).
- case (is_nan (Bplus m l1 l2)) eqn:E1, (is_nan (Bplus m h1 h2)) eqn:E2; intuition; simpl.
- all: try (fdestruct x; fdestruct y; simpl; auto; fail).
- - destruct (Bplus_nan_inv _ _ _ E1); intuition; subst; try easy.
- * rewrite (infp_le_is_infp _ _ _ H0) in *.
- rewrite (infp_le_is_infp _ _ _ H1) in *.
- fdestruct h2.
- rewrite (le_infm_is_infm _ _ _ H5) in *...
- * rewrite (infp_le_is_infp _ _ _ H4) in *.
- rewrite (infp_le_is_infp _ _ _ H2) in *.
- fdestruct h1.
- rewrite (le_infm_is_infm _ _ _ H3) in *...
- - destruct (Bplus_nan_inv _ _ _ E1) as [[ -> -> ] | [ [ -> -> ] | [ -> | -> ]]]; try easy;
- fdestruct x; fdestruct y; simpl...
- - destruct (Bplus_nan_inv _ _ _ E2) as [[ -> -> ] | [ [ -> -> ] | [ -> | -> ]]]; try easy;
- fdestruct x; fdestruct y; simpl...
- - destruct (is_nan (Bplus m x y)) eqn:E.
- + right. destruct (Bplus_nan_inv _ _ _ E) as [ [-> ->] | [ [ -> -> ] | ] ].
- * rewrite (infp_le_is_infp _ _ _ H3) in *.
- rewrite (le_infm_is_infm _ _ _ H4) in *.
- fdestruct l2; simpl; fdestruct h1; simpl; intuition.
- * rewrite (infp_le_is_infp _ _ _ H5) in *.
- rewrite (le_infm_is_infm _ _ _ H0) in *.
- fdestruct h1; simpl; fdestruct l2; simpl; intuition.
- * destruct H as [ -> | -> ]; fdestruct h1.
- + left. split; now apply Bplus_le_compat.
- - right; fdestruct y; fdestruct x; destruct nan0; simpl; intuition.
- - right; fdestruct y; fdestruct x; destruct nan; simpl; intuition.
- - right; fdestruct y; fdestruct x; destruct nan; simpl; intuition.
-Qed.
-
-Notation "'Interval+⊥'" := Interval_opt.
-
-Program Definition Ile (I : Interval) : Interval+⊥ :=
- match I with
- | Inan => None
- | Intv a b n =>
- Some (Intv -oo b n)
- end.
-Next Obligation.
- destruct I as [[|l1 h1] H1]; simpl in *; fdestruct b.
- inversion Heq_I; subst.
- fdestruct l1.
-Defined.
-
-
-Program Theorem Ile_correct :
- forall (I : Interval) (x y : float), contains I y -> x <= y -> contains_opt (Ile I) x.
-Proof.
- intros [[| l1 h1] H1] x y Hx Hxy; simpl in *.
- - fdestruct y; fdestruct x.
- - destruct (is_nan x), Hx as [ [H H'] | ];
- try (left ; idtac; split; [ fdestruct x | apply (Bleb_trans _ _ _ Hxy H')]);
- try (right ; fdestruct y; fdestruct x).
-Qed.
-
-Program Definition Ilt (I : Interval) : Interval+⊥ :=
- match I with
- | Inan => None
- | Intv a b n =>
- Some (Intv -oo b n)
- end.
-Next Obligation.
- destruct I as [[|l1 h1] H1]; simpl in *; fdestruct b;
- inversion Heq_I; subst; fdestruct l1.
-Defined.
-
-
-Program Theorem Ilt_correct :
- forall (I : Interval) (x y : float), contains I y -> Bltb x y = true -> contains_opt (Ilt I) x.
-Proof.
- intros [[| l1 h1] H1] x y Hx Hxy; simpl in *.
- - fdestruct y; fdestruct x.
- - apply Bltb_Bleb in Hxy.
- destruct (is_nan x), Hx as [ [H H'] | ];
- try (left ; idtac; split; [ fdestruct x | apply (Bleb_trans _ _ _ Hxy H')]);
- try (right ; fdestruct y; fdestruct x).
-Qed.
-
-Program Definition Ige (I : Interval) : Interval+⊥ :=
- match I with
- | Inan => None
- | Intv a b n =>
- Some (Intv a +oo n)
- end.
-Next Obligation.
- destruct I as [[|l1 h1] H1]; simpl in *; fdestruct b;
- inversion Heq_I; subst; fdestruct l1.
-Defined.
-
-Program Theorem Ige_correct :
- forall (I : Interval) (x y : float), contains I y -> Bleb y x = true -> contains_opt (Ige I) x.
-Proof.
- intros [[| l1 h1] H1] x y Hx Hxy; simpl in *.
- - fdestruct y; fdestruct x.
- - destruct (is_nan x), Hx as [ [H H'] | ];
- try (left ; idtac; split; [ apply (Bleb_trans _ _ _ H Hxy) | fdestruct x; fdestruct y ]);
- try (right ; fdestruct y; fdestruct x).
-Qed.
-
-Program Definition Igt (I : Interval) : Interval+⊥ :=
- match I with
- | Inan => None
- | Intv a b n =>
- Some (Intv a +oo n)
- end.
-Next Obligation.
- destruct I as [[|l1 h1] H1]; simpl in *; fdestruct b;
- inversion Heq_I; subst; fdestruct l1.
-Defined.
-
-Program Theorem Igt_correct :
- forall (I : Interval) (x y : float), contains I y -> Bltb y x = true -> contains_opt (Igt I) x.
-Proof.
- intros [[| l1 h1] H1] x y Hx Hxy; simpl in *.
- - fdestruct y; fdestruct x.
- - apply Bltb_Bleb in Hxy.
- destruct (is_nan x), Hx as [ [H H'] | ];
- try (left ; idtac; split; [ apply (Bleb_trans _ _ _ H Hxy) | fdestruct x; fdestruct y ]);
- try (right ; fdestruct y; fdestruct x).
-Qed.
-
-Program Definition inter_opt (I1 I2 : Interval+⊥) : Interval+⊥ :=
- match I1, I2 with
- | None, _ => None
- | _, None => None
- | Some i1, Some i2 => inter i1 i2
- end.
-
-Program Definition to_opt (I : Interval) : Interval+⊥ :=
- (Some (proj1_sig I)).
-Next Obligation.
- now destruct I as [[| l h n ] H].
-Defined.
-
-Coercion to_opt : Interval >-> Interval_opt.
-
-Ltac fall_cases x :=
- try (fdestruct x; fail).
-
-Ltac fall_cases2 x y :=
- try (fdestruct x; fdestruct y; fail).
-
-
-Definition Ige_inv (I1 I2 : Interval) : Interval+⊥ * Interval+⊥ :=
- (inter_opt (Ige I2) I1, inter_opt (Ile I1) I2).
-
-Program Theorem Ige_inv_correct :
- forall (I1 I2 : Interval) (x y : float),
- contains I1 x -> contains I2 y ->
- y <= x ->
- contains_opt (fst (Ige_inv I1 I2)) x /\
- contains_opt (snd (Ige_inv I1 I2)) y.
-Proof.
- intros [[|l1 h1 n1] H1] [[|l2 h2 n2] H2] x y Hx Hy Hxy; fall_cases2 x y.
- split; apply inter_correct; simpl in *; auto.
- + destruct Hx as [[Hx Hx'] | Hx], Hy as [[Hy Hy'] | Hy]; fall_cases2 y x.
- left; split; [ apply (Bleb_trans _ _ _ Hy Hxy) | fdestruct x ].
- + destruct Hx as [[Hx Hx'] | Hx], Hy as [[Hy Hy'] | Hy]; fall_cases2 y x.
- left; split; [ fdestruct y; fdestruct x | apply (Bleb_trans _ _ _ Hxy Hx') ].
-Qed.
-
-
-Definition Igt_inv (I1 I2 : Interval) : Interval+⊥ * Interval+⊥ :=
- (inter_opt (Igt I2) I1, inter_opt (Ilt I1) I2).
-
-Program Theorem Igt_inv_correct :
- forall (I1 I2 : Interval) (x y : float),
- contains I1 x -> contains I2 y ->
- Bltb y x = true ->
- contains_opt (fst (Igt_inv I1 I2)) x /\
- contains_opt (snd (Igt_inv I1 I2)) y.
-Proof.
- intros [[|l1 h1 n1] H1] [[|l2 h2 n2] H2] x y Hx Hy Hxy; fall_cases2 x y.
- split; apply inter_correct; simpl in *; auto; destruct Hx as [[Hx Hx'] | Hx], Hy as [[Hy Hy'] | Hy]; auto; fall_cases2 x y.
- + left; split.
- * apply (Bleb_trans _ _ _ Hy (Bltb_Bleb _ _ _ _ Hxy)).
- * fdestruct x.
- + left; split.
- * fdestruct y.
- * apply (Bleb_trans _ _ _ (Bltb_Bleb _ _ _ _ Hxy) Hx').
-Qed.
-
-Definition Ilt_inv (I1 I2 : Interval) : Interval+⊥ * Interval+⊥ :=
- (inter_opt (Ilt I2) I1, inter_opt (Igt I1) I2).
-
-Program Theorem Ilt_inv_correct :
- forall (I1 I2 : Interval) (x y : float),
- contains I1 x -> contains I2 y ->
- Bltb x y = true ->
- contains_opt (fst (Ilt_inv I1 I2)) x /\
- contains_opt (snd (Ilt_inv I1 I2)) y.
-Proof.
- intros [[|l1 h1 n1] H1] [[|l2 h2 n2] H2] x y Hx Hy Hxy; fall_cases2 x y.
- split; apply inter_correct; simpl in *; auto; destruct Hx as [[Hx Hx'] | Hx], Hy as [[Hy Hy'] | Hy]; auto; fall_cases2 x y.
- + left; split; fall_cases x.
- apply (Bleb_trans _ _ _ (Bltb_Bleb _ _ _ _ Hxy) Hy').
- + left; split; fall_cases y.
- apply (Bleb_trans _ _ _ Hx (Bltb_Bleb _ _ _ _ Hxy)).
-Qed.
-
-Definition Ile_inv (I1 I2 : Interval) : Interval+⊥ * Interval+⊥ :=
- (inter_opt (Ile I2) I1, inter_opt (Ige I1) I2).
-
-Program Theorem Ile_inv_correct :
- forall (I1 I2 : Interval) (x y : float),
- contains I1 x -> contains I2 y ->
- x <= y ->
- contains_opt (fst (Ile_inv I1 I2)) x /\
- contains_opt (snd (Ile_inv I1 I2)) y.
-Proof.
- intros [[|l1 h1 n1] H1] [[|l2 h2 n2] H2] x y Hx Hy Hxy; fall_cases2 x y.
- split; apply inter_correct; simpl in *; auto; destruct Hx as [[Hx Hx'] | Hx], Hy as [[Hy Hy'] | Hy]; auto; fall_cases2 x y.
- + left; split; fall_cases x.
- apply (Bleb_trans _ _ _ Hxy Hy').
- + left; split; fall_cases y.
- apply (Bleb_trans _ _ _ Hx Hxy).
-Qed.
-
-Definition Ieq_inv (I1 I2 : Interval) : Interval+⊥ * Interval+⊥ :=
- (inter_opt I1 I2, inter_opt I1 I2).
-
-Program Theorem Ieq_inv_correct :
- forall (I1 I2 : Interval) (x y : float),
- contains I1 x -> contains I2 y ->
- Beqb x y = true ->
- contains_opt (fst (Ieq_inv I1 I2)) x /\
- contains_opt (snd (Ieq_inv I1 I2)) y.
-Proof.
- intros [[|l1 h1 n1] H1] [[|l2 h2 n2] H2] x y Hx Hy Hxy; fall_cases2 x y.
- split; apply inter_correct; simpl in *; auto; destruct Hx as [[Hx Hx'] | Hx], Hy as [[Hy Hy'] | Hy]; auto; fall_cases2 x y.
- + left; split.
- * apply (Bleb_trans l2 y x Hy (Beqb_Bleb _ _ _ _ (Beqb_symm _ _ _ _ Hxy))).
- * apply (Bleb_trans x y h2 (Beqb_Bleb _ _ _ _ Hxy) Hy').
- + left; split.
- * apply (Bleb_trans l1 x y Hx (Beqb_Bleb _ _ _ _ Hxy)).
- * apply (Bleb_trans y x h1 (Beqb_Bleb _ _ _ _ (Beqb_symm _ _ _ _ Hxy)) Hx').
-Qed.
-
-Definition Iopp' (I1 : Interval') : Interval' :=
- match I1 with
- | Inan => Inan
- | Intv l h n =>
- let opp1 := Bopp l in
- let opp2 := Bopp h in
- Intv opp2 opp1 n
- end.
-
-Program Definition Iopp (I1 : Interval) : Interval :=
- Iopp' I1.
-Admit Obligations.
-
-Program Definition union' (I1 I2 : Interval') : Interval' :=
- match I1, I2 with
- | Inan, Inan => Inan
- | Inan, Intv _ _ true => I2
- | Inan, Intv l h false => Intv l h true
- | Intv _ _ true, Inan => I1
- | Intv l h false, Inan => Intv l h true
- | Intv lo1 hi1 nan1, Intv lo2 hi2 nan2 =>
- (Intv (Bmin lo1 lo2) (Bmax hi1 hi2) (nan1 || nan2))
- end.
-
-
-End Finterval.
diff --git a/farith2/thry/Intv32.v b/farith2/thry/Intv32.v
deleted file mode 100644
index 6f3a39f30..000000000
--- a/farith2/thry/Intv32.v
+++ /dev/null
@@ -1,185 +0,0 @@
-From Coq Require Import ZArith Extraction Bool Psatz ExtrOcamlBasic.
-From Flocq Require Import IEEE754.BinarySingleNaN FLX.
-Require Import Utils Interval B32.
-
-
-
-Notation "x '+⊥'" := (option x) (at level 80).
-
-Module Intv32.
- Definition prec := 24%Z.
- Definition emax := 128%Z.
- Definition float32 := B32.t.
-
- Lemma Hprec : Prec_gt_0 prec.
- Proof. unfold Prec_gt_0, prec; lia. Qed.
-
- Lemma Hemax : Prec_lt_emax prec emax.
- Proof. unfold Prec_lt_emax, prec, emax; lia. Qed.
-
- Definition t := Interval prec emax.
-
- Definition t_opt := Interval_opt prec emax.
-
- Program Definition contains : t -> float32 -> Prop := contains prec emax.
-
- Program Definition contains_opt : t_opt -> float32 -> Prop := contains_opt prec emax.
-
- Definition inter (x y : t) : t_opt :=
- @inter prec emax x y.
-
- Definition add : mode -> t -> t -> t :=
- @Iadd prec emax Hprec Hemax.
-
- Program Lemma inter_correct :
- forall (i1 i2 : t) (x : float32),
- contains i1 x -> contains i2 x -> contains_opt (inter i1 i2) x.
- Proof.
- apply (inter_correct prec emax).
- Qed.
-
- Lemma inter_precise :
- forall (i1 i2 : t) (x : float32),
- contains_opt (inter i1 i2) x -> contains i1 x /\ contains i2 x.
- Proof.
- intros; split.
- - apply (inter_precise_l prec emax _ _ _ H).
- - apply (inter_precise_r prec emax _ _ _ H).
- Qed.
-
- Lemma add_correct :
- forall (m : mode) (i1 i2 : t) (x y : float32),
- contains i1 x -> contains i2 y -> contains (add m i1 i2) (@Bplus prec emax Hprec Hemax m x y).
- Proof. apply Iadd_correct. Qed.
-
- Program Definition top : t := Intv prec emax -oo +oo true.
-
- Program Definition bot : t_opt := None.
-
- Lemma top_correct :
- forall (x : float32), contains top x.
- Proof with auto.
- unfold top, contains; fdestruct x; simpl...
- Qed.
-
- Lemma bot_correct :
- forall (x : float32), contains_opt bot x -> False.
- Proof with auto.
- unfold bot, contains; fdestruct x.
- Qed.
-
- Program Definition is_singleton (I : t) : option float32 :=
- match I with
- | Inan _ _ => Some NaN
- | Intv _ _ a b n =>
- if Beqb a b && (negb (Beqb a (B754_zero false))) && negb n then Some a
- else None
- end.
-
- Program Definition s0 : Interval prec emax := Intv _ _ (B754_zero false) (B754_zero true) false.
-
- Program Theorem is_singleton_correct :
- forall (I : t) (x : float32), (is_singleton I = Some x) -> (forall y, contains I y -> x = y).
- Proof.
- intros [[| a b n] H] x; cbn.
- - intros H1; inversion H1; fdestruct y.
- - intros H' y [[H1 H2] | H2].
- + destruct (Beqb a b) eqn:?E, (negb n) eqn:?E, (negb (Beqb a (B754_zero false))) eqn:?; try easy; simpl in *.
- assert (a <= y <= a) by eauto using E, Beqb_symm, Beqb_Bleb, Bleb_trans.
- apply Bleb_antisymm_strict in H0.
- * inversion H'; subst; reflexivity.
- * now apply Bool.negb_true_iff in Heqb0.
- + destruct (Beqb a b) eqn:?E, (negb n) eqn:?E, (negb (Beqb a (B754_zero false))) eqn:?; try easy; simpl in *.
- destruct n; try easy.
- fdestruct y.
- Qed.
-
- Program Definition singleton (x : float32) : t :=
- match x with
- | B754_nan => Inan prec emax
- | _ => Intv _ _ x x false
- end.
- Next Obligation.
- apply Bleb_refl.
- fdestruct x.
- Defined.
-
- Program Example s00 : t := Intv prec emax (B754_zero false) (B754_zero false) false.
- Program Example s01 : t := Intv prec emax (B754_zero false) (B754_zero true) false.
- Program Example s10 : t := Intv prec emax (B754_zero true) (B754_zero false) false.
- Program Example s11 : t := Intv prec emax (B754_zero true) (B754_zero true) false.
-
- (** /!\ Série alternante !!! *)
- (* Compute (inter s10 s00) (* s00*). *)
- (* Compute (inter s00 s10) (* s10 *). *)
- (* Compute (inter s00 s10) (* s10*). *)
- (* Compute (inter s10 s00) (* s00 *). *)
-
-
-
- Program Theorem singleton_correct :
- forall (x : float32), Beqb x (B754_zero true) = false -> is_singleton (singleton x) = Some x.
- Proof.
- intros [ [ ] | [ ] | | [ ] ] H; try easy; cbn.
- - rewrite Z.compare_refl, Pcompare_refl; reflexivity.
- - rewrite Z.compare_refl, Pcompare_refl; reflexivity.
- Qed.
-
- Program Definition ge : t -> t_opt := @Ige prec emax.
- Program Definition le : t -> t_opt := @Ile prec emax.
- Program Definition lt : t -> t_opt := @Ilt prec emax.
- Program Definition gt : t -> t_opt := @Igt prec emax.
-
- Program Definition le_inv : t -> t -> (t_opt * t_opt) := @Ile_inv prec emax.
- Program Definition ge_inv : t -> t -> (t_opt * t_opt) := @Ige_inv prec emax.
- Program Definition lt_inv : t -> t -> (t_opt * t_opt) := @Ilt_inv prec emax.
- Program Definition gt_inv : t -> t -> (t_opt * t_opt) := @Igt_inv prec emax.
- Program Definition eq_inv : t -> t -> (t_opt * t_opt) := @Ieq_inv prec emax.
-
- Theorem le_inv_correct :
- forall (I1 I2 : t) (x y : float32),
- contains I1 x -> contains I2 y -> x <= y ->
- contains_opt (fst (le_inv I1 I2)) x /\ contains_opt (snd (le_inv I1 I2)) y.
- Proof. apply (@Ile_inv_correct prec emax). Qed.
-
- Theorem ge_inv_correct :
- forall (I1 I2 : t) (x y : float32),
- contains I1 x -> contains I2 y -> y <= x ->
- contains_opt (fst (ge_inv I1 I2)) x /\ contains_opt (snd (ge_inv I1 I2)) y.
- Proof. apply (@Ige_inv_correct prec emax). Qed.
-
- Theorem gt_inv_correct :
- forall (I1 I2 : t) (x y : float32),
- contains I1 x -> contains I2 y -> Bltb y x = true ->
- contains_opt (fst (gt_inv I1 I2)) x /\ contains_opt (snd (gt_inv I1 I2)) y.
- Proof. apply (@Igt_inv_correct prec emax). Qed.
-
- Theorem lt_inv_correct :
- forall (I1 I2 : t) (x y : float32),
- contains I1 x -> contains I2 y -> Bltb x y = true ->
- contains_opt (fst (lt_inv I1 I2)) x /\ contains_opt (snd (lt_inv I1 I2)) y.
- Proof. apply (@Ilt_inv_correct prec emax). Qed.
-
- Theorem eq_inv_correct :
- forall (I1 I2 : t) (x y : float32),
- contains I1 x -> contains I2 y -> Beqb x y = true ->
- contains_opt (fst (eq_inv I1 I2)) x /\ contains_opt (snd (eq_inv I1 I2)) y.
- Proof. apply (@Ieq_inv_correct prec emax). Qed.
-
- Theorem le_correct :
- forall (I : t) (x y : float32), contains I y -> x <= y -> contains_opt (le I) x.
- Proof. apply (@Ile_correct prec emax). Qed.
-
- Theorem lt_correct :
- forall (I : t) (x y : float32), contains I y -> Bltb x y = true -> contains_opt (lt I) x.
- Proof. apply (@Ilt_correct prec emax). Qed.
-
- Theorem ge_correct :
- forall (I : t) (x y : float32), contains I y -> y <= x -> contains_opt (ge I) x.
- Proof. apply (@Ige_correct prec emax). Qed.
-
- Theorem gt_correct :
- forall (I : t) (x y : float32), contains I y -> Bltb y x = true -> contains_opt (gt I) x.
- Proof. apply (@Igt_correct prec emax). Qed.
-
-End Intv32.
diff --git a/farith2/thry/Op.v b/farith2/thry/Op.v
deleted file mode 100644
index 7b03f07e2..000000000
--- a/farith2/thry/Op.v
+++ /dev/null
@@ -1,289 +0,0 @@
-From Flocq Require Import Core.Core IEEE754.BinarySingleNaN IEEE754.Bits.
-From Coq Require Import Program ZArith Bool Lia Reals Qreals ZBits SpecFloat.
-Require Import Assert Utils Interval Qextended Rextended.
-
-
-Section Op.
-
-Variable prec : Z.
-Variable emax : Z.
-Context (Hprec : FLX.Prec_gt_0 prec).
-Context (Hemax : Prec_lt_emax prec emax).
-
-Definition float := binary_float prec emax.
-
-Lemma split_bounded_emin:
- forall m e, bounded prec emax m e = true <->
- ( e = emin prec emax /\ (Z.pos (digits2_pos m) <= prec)%Z )
- \/ ( (emin prec emax < e)%Z /\ (e <= emax-prec)%Z /\ (Z.pos (digits2_pos m) = prec)%Z ).
-Proof.
- intros m e; split.
- - intros H.
- unfold bounded in H.
- unfold canonical_mantissa in H.
- unfold SpecFloat.fexp in H.
- destruct (Z_ge_lt_dec (emin prec emax) (Z.pos (digits2_pos m) + e - prec)).
- * left.
- rewrite Z.max_r in H.
- apply andb_prop in H.
- rewrite <- Zeq_is_eq_bool in H.
- rewrite <- Zle_is_le_bool in H.
- split; lia.
- lia.
- * right.
- rewrite Z.max_l in H.
- apply andb_prop in H.
- rewrite <- Zeq_is_eq_bool in H.
- rewrite <- Zle_is_le_bool in H.
- split; [lia | split ; lia ].
- lia.
- - intro H.
- destruct H as [[H1 H2]|[H1 [H2 H3]]]; unfold bounded; unfold canonical_mantissa; unfold SpecFloat.fexp; apply andb_true_intro.
- + split.
- * rewrite Z.max_r.
- rewrite <- Zeq_is_eq_bool.
- lia.
- lia.
- * rewrite <- Zle_is_le_bool.
- unfold emin in H1.
- unfold Prec_gt_0 in Hprec.
- unfold Prec_lt_emax in Hemax.
- lia.
- + split.
- * rewrite Z.max_l.
- rewrite <- Zeq_is_eq_bool.
- lia.
- lia.
- * rewrite <- Zle_is_le_bool.
- unfold emin in H1.
- unfold Prec_gt_0 in Hprec.
- unfold Prec_lt_emax in Hemax.
- lia.
-Qed.
-
-Lemma max_mantissa_has_length_prec:
- Z.pos (digits2_pos (shift_pos (Z.to_pos prec) 1 - 1)) = prec.
-Proof.
- rewrite Zpos_digits2_pos, Pos2Z.inj_sub.
- - rewrite shift_pos_correct, Z.mul_1_r.
- assert (P2pm1 : (0 <= 2 ^ prec - 1)%Z).
- { apply (Zplus_le_reg_r _ _ 1); ring_simplify.
- change 1%Z with (2 ^ 0)%Z; change 2%Z with (radix2 : Z).
- apply Zpower_le; unfold Prec_gt_0 in Hprec; lia. }
- apply Zdigits_unique;
- rewrite Z.pow_pos_fold, Z2Pos.id; [|exact Hprec]; simpl; split.
- + rewrite (Z.abs_eq _ P2pm1).
- replace prec with (prec - 1 + 1)%Z at 2 by ring.
- rewrite Zpower_plus; [| unfold Prec_gt_0 in Hprec; lia|lia].
- simpl; unfold Z.pow_pos; simpl.
- assert (1 <= 2 ^ (prec - 1))%Z; [|lia].
- change 1%Z with (2 ^ 0)%Z; change 2%Z with (radix2 : Z).
- apply Zpower_le; simpl; unfold Prec_gt_0 in Hprec; lia.
- + now rewrite Z.abs_eq; [lia|].
- - change (_ < _)%positive
- with (Z.pos 1 < Z.pos (shift_pos (Z.to_pos prec) 1))%Z.
- rewrite shift_pos_correct, Z.mul_1_r, Z.pow_pos_fold.
- rewrite Z2Pos.id; [|exact Hprec].
- change 1%Z with (2 ^ 0)%Z; change 2%Z with (radix2 : Z).
- apply Zpower_lt; unfold Prec_gt_0 in Hprec; lia.
-Qed.
-
-Lemma min_normal_mantissa_has_length_prec:
- Z.pos (digits2_pos (Z.to_pos (Z.shiftl 1 (prec - 1)%Z)))%positive = prec.
-Proof.
- unfold Prec_gt_0 in Hprec.
- rewrite Zpos_digits2_pos.
- rewrite Z.shiftl_mul_pow2.
- rewrite Z2Pos.id.
- rewrite Z.mul_1_l.
- rewrite Zdigits_Zpower.
- - lia.
- - lia.
- - assert (H2 : (0 < 2)%Z) by lia.
- assert (H3 : (0 <= (prec - 1))%Z) by lia.
- assert (H := (Z.pow_pos_nonneg 2 (prec - 1) H2 H3)%Z).
- lia.
- - lia.
-Qed.
-
-Lemma max_prec_is_canonical:
- forall e, ((SpecFloat.emin prec emax) <= e)%Z -> (e <= emax - prec)%Z ->
- canonical_mantissa prec emax (shift_pos (Z.to_pos prec) 1 - 1) e = true.
-Proof.
- intros e Hege Hele.
- unfold canonical_mantissa; apply Zeq_bool_true.
- assert (H := max_mantissa_has_length_prec).
- set (p := Z.pos (digits2_pos _)) in *.
- unfold SpecFloat.fexp, FLT_exp; rewrite H, Z.max_l; [ring|].
- unfold emin in *.
- (* generalize (prec_gt_0 prec) (prec_lt_emax prec emax). *)
- lia.
-Qed.
-
-Lemma min_normal_prec_is_canonical:
- forall e, ((SpecFloat.emin prec emax) <= e)%Z -> (e <= emax - prec)%Z ->
- canonical_mantissa prec emax (Z.to_pos (Z.shiftl 1 (prec - 1)%Z))%positive e = true.
-Proof.
- intros e Hege Hele.
- unfold canonical_mantissa; apply Zeq_bool_true.
- assert (H := min_normal_mantissa_has_length_prec).
- set (p := Z.pos (digits2_pos _)) in *.
- unfold SpecFloat.fexp, FLT_exp; rewrite H, Z.max_l; [ring|].
- unfold emin in *.
- (* generalize (prec_gt_0 prec) (prec_lt_emax prec emax). *)
- lia.
-Qed.
-
-Lemma Bmax_float_proof :
- valid_binary prec emax
- (S754_finite false (shift_pos (Z.to_pos prec) 1 - 1) (emax - prec))
- = true.
-Proof.
-unfold valid_binary, bounded; apply andb_true_intro; split.
-- apply max_prec_is_canonical.
- + unfold emin.
- unfold Prec_gt_0 in Hprec.
- unfold Prec_lt_emax in Hemax.
- lia.
- + lia.
-- apply Zle_bool_true; unfold emin; unfold Prec_gt_0 in Hprec; lia.
-Qed.
-
-
-Lemma bounded_is_bigger_than_emin:
- forall m0 e, bounded prec emax m0 e = true -> (emin prec emax <= e)%Z.
-Proof.
- intros m0 e H.
- apply andb_prop in H.
- unfold canonical_mantissa in H.
- unfold SpecFloat.fexp in H.
- assert (Hmax := Z.le_max_r (Z.pos (digits2_pos m0) + e - prec) (emin prec emax)).
- rewrite <- Zeq_is_eq_bool in H.
- lia.
-Qed.
-
-Program Definition Fsucc x :=
- match x with
- | B754_zero _ => B754_finite false 1%positive (SpecFloat.emin prec emax) (Bulp_correct_aux _ _ Hprec Hemax)
- | B754_infinity false => x
- | B754_infinity true => Bopp Bmax_float
- | B754_nan => x
- | B754_finite false m e H =>
- let m := (Pos.succ m) in
- if dec (Z.ltb prec (Z.pos(SpecFloat.digits2_pos m)))%Z then
- if dec (Z.eqb e (emax - prec))%Z then
- B754_infinity false
- else B754_finite false (Z.to_pos (Z.shiftl 1 (prec - 1)%Z)) (e+1)%Z _
- else B754_finite false m e _
- | B754_finite true m e H =>
- if dec (e =? (SpecFloat.emin prec emax))%Z then
- if dec (1 <? Z.pos m)%Z then
- B754_finite true (Pos.pred m) e _
- else
- B754_zero true
- else
- let m0 := (Z.pred (Z.pos m))%Z in
- if dec ((Zdigits2 m0) <? prec)%Z then
- B754_finite true (shift_pos (Z.to_pos prec) 1 - 1) (e-1)%Z _
- else
- B754_finite true (Z.to_pos m0) e _
- end.
-
-Next Obligation.
- apply andb_true_intro.
- split.
- - apply min_normal_prec_is_canonical.
- + apply bounded_is_bigger_than_emin in H.
- lia.
- + apply andb_prop in H.
- rewrite Z.leb_le in H.
- lia.
- - rewrite Z.leb_le in *.
- rewrite Z.eqb_neq in H1.
- apply andb_prop in H.
- rewrite Z.leb_le in H.
- lia.
-Qed.
-
-Next Obligation.
- rewrite split_bounded_emin in *.
- destruct H.
- * left.
- apply Z.ltb_nlt in H0.
- split; lia.
- * right.
- apply Z.ltb_nlt in H0.
- split. easy.
- split. easy.
- rewrite Zpos_digits2_pos in *.
- assert (H1:= Zdigits_le radix2 (Z.pos m0) (Z.pos (Pos.succ m0))).
- lia.
-Qed.
-
-Next Obligation.
- rewrite split_bounded_emin.
- left.
- rewrite Z.ltb_lt in *.
- rewrite Z.eqb_eq in *.
- rewrite split_bounded_emin in H.
- destruct H.
- split. lia.
- assert (Zdigits radix2 (Z.pred (Z.pos m)) <= Zdigits radix2 (Z.pos m))%Z.
- apply Zdigits_le; lia.
- rewrite Zpos_digits2_pos in *.
- rewrite Pos2Z.inj_pred in *.
- lia.
- lia.
- lia.
-Qed.
-
-Next Obligation.
- rewrite split_bounded_emin in H.
- destruct H.
- * lia.
- * apply andb_true_intro.
- split.
- - apply max_prec_is_canonical; lia.
- - lia.
-Qed.
-
-Next Obligation.
- replace (match m with | (p~1)%positive => Z.pos p~0 | (p~0)%positive => Z.pos (Pos.pred_double p)
- | 1%positive => 0 end)%Z with (Z.pred (Z.pos m)) in *.
- rewrite split_bounded_emin in H.
- destruct H.
- * lia.
- * rewrite split_bounded_emin.
- right.
- rewrite Z.ltb_ge in *.
- rewrite Z.eqb_neq in *.
- rewrite Zpos_digits2_pos in *.
- destruct (Pos.eq_dec 1 m)%Z.
- + rewrite <- e0 in *.
- unfold Prec_gt_0 in Hprec.
- simpl in H1.
- lia. (* absurd *)
- + rewrite Zdigits2_Zdigits in *.
- assert (Zdigits radix2 (Z.pred (Z.pos m)) <= Zdigits radix2 (Z.pos m))%Z.
- apply Zdigits_le; lia.
- split. lia.
- split. lia.
- rewrite Z2Pos.id.
- lia.
- lia.
- * reflexivity.
-Qed.
-
-Definition Fneg (x:float) : float :=
- match x with
- | B754_nan => B754_nan
- | B754_zero s => B754_zero (negb s)
- | B754_infinity s => B754_infinity (negb s)
- | B754_finite s m e H => B754_finite (negb s) m e H
- end.
-
-
-Definition Fpred x := Fneg (Fsucc (Fneg x)).
-
-
-End Op.
diff --git a/farith2/thry/Qextended.v b/farith2/thry/Qextended.v
deleted file mode 100644
index 31f5fc5bf..000000000
--- a/farith2/thry/Qextended.v
+++ /dev/null
@@ -1,68 +0,0 @@
-From Coq Require Import ZArith Reals Qreals Extraction.
-Require Import Rextended.
-
-(** * A type of rationals suitable for conversions from and to fp
- and compatible with zarith Q
-*)
-
-Record Qx := Qxmake {
- num : Z.t; den : Z.t;
- Hden1 : (0 <=? den)%Z = true;
- Hden2 : (if den =? 0 then orb (orb (num =? -1) (num =? 0)) (num =? 1) else Z.gcd num den =? 1)%Z = true
-}.
-
-Lemma Hden2' :
- forall q, (den q = 0 -> num q = -1 \/ num q = 0 \/ num q = 1)%Z.
-Proof.
- intros q H.
- rewrite <- !Z.eqb_eq in *.
- assert (H2 := Hden2 q).
- rewrite H in H2.
- destruct (num q =? -1)%Z; destruct (num q =? 0)%Z; destruct (num q =? 1)%Z;
- tauto.
-Qed.
-
-Definition Qx_zero := Qxmake 0%Z 1%Z (refl_equal _) (refl_equal _).
-Definition Qx_undef := Qxmake 0%Z 0%Z (refl_equal _) (refl_equal _).
-Definition Qx_inf := Qxmake 1%Z 0%Z (refl_equal _) (refl_equal _).
-Definition Qx_minus_inf := Qxmake (-1)%Z 0%Z (refl_equal _) (refl_equal _).
-Definition Qx_half := Qxmake (1)%Z 2%Z (refl_equal _) (refl_equal _).
-Definition Qx_one := Qxmake (1)%Z 1%Z (refl_equal _) (refl_equal _).
-Definition Qx_two := Qxmake (2)%Z (1)%Z (refl_equal _) (refl_equal _).
-
-Inductive Qx_kind (q : Qx) := (* cf Q of Zarith *)
- | Qx_INF: (num q = 1)%Z -> (den q = 0)%Z -> Qx_kind q
- | Qx_MINF: (num q = -1)%Z -> (den q = 0)%Z -> Qx_kind q
- | Qx_UNDEF: (num q = 0)%Z -> (den q = 0)%Z -> Qx_kind q
- | Qx_ZERO: (num q = 0)%Z -> forall pq, (den q = Z.pos pq)%Z -> Qx_kind q
- | Qx_NZERO: forall nq (s:{num q = Z.pos nq} + {num q = Z.neg nq}) pq, (den q = Z.pos pq)%Z -> Qx_kind q.
-
-Extraction Implicit Qx_ZERO [pq].
-Extraction Implicit Qx_NZERO [nq s pq].
-
-Lemma Qx_classify (q: Qx) : Qx_kind q.
-Proof.
- intros.
- case_eq (den q); [intros Hd | intros pd Hd| intros nd Hd].
- - case_eq (num q); [intros Hn | intros pn Hn| intros nn Hn].
- * exact (Qx_UNDEF q Hn Hd).
- * assert (H: num q = ( 1)%Z) by (destruct (Hden2' q Hd) as [H|[H|H]]; rewrite Hn in *;
- [discriminate H| discriminate H | assumption ]).
- exact (Qx_INF q H Hd).
- * assert (H: num q = (-1)%Z) by (destruct (Hden2' q Hd) as [H|[H|H]]; rewrite Hn in *;
- [assumption| discriminate H | discriminate H]).
- exact (Qx_MINF q H Hd).
- - case_eq (num q); [intros Hn | intros nq Hn| intros nq Hn].
- * exact (Qx_ZERO q Hn pd Hd).
- * exact (Qx_NZERO q nq (left Hn) pd Hd).
- * exact (Qx_NZERO q nq (right Hn) pd Hd).
- - assert (A := Hden1 q).
- rewrite Hd in A.
- discriminate A.
-Defined.
-
-Definition Q2Rx q : Rx :=
- if (den q =? 0)%Z then
- if (num q =? 0)%Z then Real (0%R)
- else Inf (num q <? 0)%Z
- else Real (Q2R (Qmake (num q) (Z.to_pos (den q)))).
diff --git a/farith2/thry/Rextended.v b/farith2/thry/Rextended.v
deleted file mode 100644
index b0bab092f..000000000
--- a/farith2/thry/Rextended.v
+++ /dev/null
@@ -1,741 +0,0 @@
-(*********************************************************
- Extension of R with special values +oo, -oo
-**********************************************************)
-
-From Flocq Require Import IEEE754.BinarySingleNaN.
-From Coq Require Import ZArith Psatz Reals SpecFloat.
-Require Import Utils.
-
-Set Implicit Arguments.
-
-(**
- Inject BinarySingleNan in R extended with infinities
-*)
-Section Rextended.
-
-Variable prec : Z.
-Variable emax : Z.
-Context (Hprec : FLX.Prec_gt_0 prec).
-Context (Hemax : Prec_lt_emax prec emax).
-
-Definition float := binary_float prec emax.
-
-(** Reals extended with +oo, -oo *)
-Inductive Rx : Type :=
- | Real : R -> Rx
- | Inf : bool -> Rx.
-
-Definition R_imax : R := Raux.bpow Zaux.radix2 emax.
-
-Definition R_fmax : R := Raux.bpow Zaux.radix2 emax - Raux.bpow Zaux.radix2 (emax - prec).
-
-Program Definition F_fmax : float := B754_finite false (Z.to_pos (Zpower 2 prec - 1)%Z) (emax - prec) _.
-Next Obligation.
- refine (binary_overflow_correct prec emax _ _ mode_ZR false).
-Defined.
-
-Lemma R2F_fmax:
- R_fmax = B2R (F_fmax).
-Proof.
- unfold FLX.Prec_gt_0 in Hprec.
- unfold Prec_lt_emax in Hemax.
- assert (0 < emax)%Z by lia.
- unfold R_fmax, F_fmax, B2R, Defs.F2R; simpl.
- destruct prec eqn:E; try easy.
- rewrite Z2Pos.id.
- - rewrite <- E, minus_IZR.
- replace 2%Z with (Zaux.radix_val Zaux.radix2) by auto.
- rewrite Raux.IZR_Zpower by lia.
- rewrite Rmult_minus_distr_r.
- rewrite <- Raux.bpow_plus.
- replace (prec + (emax - prec))%Z with emax by lia.
- lra.
- - assert (1 < 2 ^ (Z.pos p))%Z.
- + replace 2%Z with (Zaux.radix_val Zaux.radix2) by auto.
- apply Zaux.Zpower_gt_1; lia.
- + lia.
-Qed.
-
-Lemma F_fmax_max :
- forall (x : float), is_finite x = true -> Bleb x F_fmax = true.
-Proof.
- intros [ [ ] | [ ] | | [ ] m e Hbound'] Fx; auto.
- apply Rle_Bleb; auto.
- rewrite <- R2F_fmax.
- now apply bounded_le_emax_minus_prec.
-Qed.
-
-Lemma F_fmax_min :
- forall (x : float), is_finite x = true -> Bleb (Bopp F_fmax) x = true.
-Proof.
- intros [ [ ] | [ ] | | [ ] m e Hbound'] Fx; auto.
- apply Rle_Bleb; auto.
- rewrite pos_Bopp_neg, B2R_Bopp, B2R_Bopp, <- R2F_fmax.
- apply Ropp_le_contravar.
- now apply bounded_le_emax_minus_prec.
-Qed.
-
-Lemma Rimax_Rfmax :
- (R_fmax < R_imax)%R.
-Proof.
- apply minus_pos_lt, Raux.bpow_gt_0.
-Qed.
-
-Definition leb (x y : Rx) :=
- match x with
- | Inf true => true
- | Inf false =>
- match y with
- | Inf s => negb s
- | _ => false
- end
- | Real r1 =>
- match y with
- | Inf b => negb b
- | Real r2 => Raux.Rle_bool r1 r2
- end
- end.
-
-Definition fexp := SpecFloat.fexp prec emax.
-
-Definition do_overflow (m : mode) (x : R) : bool :=
- let fexp := SpecFloat.fexp prec emax in
- let rsum := Generic_fmt.round Zaux.radix2 fexp (round_mode m) x in
- Raux.Rle_bool R_imax (Rabs rsum).
-
-Definition dont_overflow (m : mode) (x : R) : bool :=
- let fexp := SpecFloat.fexp prec emax in
- let rsum := Generic_fmt.round Zaux.radix2 fexp (round_mode m) x in
- Raux.Rlt_bool (Rabs rsum) R_imax.
-
-Lemma do_overflow_false :
- forall m r, do_overflow m r = false -> dont_overflow m r = true.
-Proof.
- intros. unfold do_overflow, dont_overflow in *.
- now rewrite <- Raux.negb_Rlt_bool, H.
-Qed.
-
-Lemma do_overflow_true :
- forall m r, do_overflow m r = true -> dont_overflow m r = false.
-Proof.
- intros. unfold do_overflow, dont_overflow in *.
- now rewrite <- Raux.negb_Rlt_bool, H.
-Qed.
-
-Lemma dont_overflow_true :
- forall m r, dont_overflow m r = true -> do_overflow m r = false.
-Proof.
- intros. unfold do_overflow, dont_overflow in *.
- now rewrite <- Raux.negb_Rle_bool, Bool.negb_false_iff.
-Qed.
-
-Lemma dont_overflow_false :
- forall m r, dont_overflow m r = false -> do_overflow m r = true.
-Proof.
- intros. unfold do_overflow, dont_overflow in *.
- now rewrite <- Bool.negb_false_iff, Raux.negb_Rlt_bool.
-Qed.
-
-Lemma F2R_congr :
- forall m1 e1 m2 e2, m1 = m2 -> e1 = e2 ->
- @Defs.F2R Zaux.radix2 {| Defs.Fnum := m1; Defs.Fexp := e1 |} =
- @Defs.F2R Zaux.radix2 {| Defs.Fnum := m2; Defs.Fexp := e2 |}.
-Proof. congruence. Qed.
-
-Definition round (m : mode) (r : Rx) : Rx :=
- match r with
- | Real x =>
- if do_overflow m x then
- if overflow_to_inf m (sign x) then Inf (sign x)
- else Real (B2R (if sign x then Bopp F_fmax else F_fmax))
- else
- Real (Generic_fmt.round Zaux.radix2 (SpecFloat.fexp prec emax) (round_mode m) x)
- | _ => r
- end.
-
-(* Lemma about_Zceil :
- forall (r : R), (0 < r)%R -> (0 < Raux.Zceil r)%Z.
-Proof.
- intros.
- Search (_ <= Raux.Zceil _)%Z.
- unfold Raux.Zceil, Raux.Zfloor.
- apply Z.opp_lt_mono.
- rewrite Z.opp_involutive.
- simpl.
- pose proof (archimed r).
- destruct H0. *)
-
-Lemma about_Zneg :
- forall z, (Z.neg z = - Z.pos z)%Z.
-Proof. reflexivity. Qed.
-
-(**
- TODO : In fact, this one can be obtained from Flocq's bounded_canonical_lt_emax
-*)
-Lemma dont_overflow_inv :
- forall m (r : R),
- do_overflow m r = false ->
- exists (f : float), Generic_fmt.round Zaux.radix2 (SpecFloat.fexp prec emax) (round_mode m) r = B2R f /\ is_finite f = true.
-Proof.
- (*Check bounded_canonical_lt_emax.
- intros mode r Hr.
- apply do_overflow_false in Hr.
- unfold dont_overflow in Hr.
- apply Rltb_Rlt in Hr.
- unfold R_imax in Hr.
- set (r' := Generic_fmt.round Zaux.radix2 (SpecFloat.fexp prec emax) (round_mode mode) r).
- set (e := Generic_fmt.cexp Zaux.radix2 (SpecFloat.fexp prec emax) r').
- set (m' := Generic_fmt.scaled_mantissa Zaux.radix2 (SpecFloat.fexp prec emax) r').
- destruct (Zaux.Zcompare_spec (round_mode mode (Generic_fmt.scaled_mantissa Zaux.radix2 (SpecFloat.fexp prec emax) r')) 0%Z).
- + assert (Generic_fmt.generic_format Zaux.radix2 (SpecFloat.fexp prec emax) r').
- unfold r'. apply Generic_fmt.generic_format_round; intuition.
- now apply fexp_correct.
- elim (Generic_fmt.canonical_generic_format Zaux.radix2 (SpecFloat.fexp prec emax) (Generic_fmt.round Zaux.radix2 (SpecFloat.fexp prec emax) (round_mode mode) r) H0).
- intros [ ] [H1 H2].
- set (m := Z.to_pos (Z.abs Fnum)).
- assert (Hbound : SpecFloat.bounded prec emax m e = true).
- apply bounded_canonical_lt_emax; auto.
- unfold m. admit.
- Check (binary_normalize). *)
- intros mode r Hr.
- apply do_overflow_false in Hr.
- unfold dont_overflow in Hr.
- apply Rltb_Rlt in Hr.
- set (e := Generic_fmt.cexp Zaux.radix2 (SpecFloat.fexp prec emax) r).
- set (m' := Generic_fmt.scaled_mantissa Zaux.radix2 (SpecFloat.fexp prec emax) r).
- set (m := Z.to_pos (Z.abs (round_mode mode m'))).
- destruct (Zaux.Zcompare_spec (round_mode mode (Generic_fmt.scaled_mantissa Zaux.radix2 (SpecFloat.fexp prec emax) r)) 0%Z).
- + assert (Hbound : SpecFloat.bounded prec emax m e = true) by admit.
- eexists (B754_finite true m e Hbound); split; auto.
- unfold Generic_fmt.round; simpl.
- apply F2R_congr; try easy.
- unfold m, m'.
- rewrite about_Zneg.
- rewrite Z2Pos.id; lia.
- + eexists (B754_zero _); split; auto.
- unfold Generic_fmt.round, Defs.F2R.
- rewrite H. simpl. lra.
- + eexists (B754_finite false m e _); split; auto.
- unfold Generic_fmt.round; simpl.
- apply F2R_congr; try easy.
- unfold m, m'.
- rewrite Z2Pos.id; lia.
-Admitted.
-
-Lemma R_imax_gt_0: (R_imax > 0)%R.
- apply Raux.bpow_gt_0.
-Qed.
-
-Lemma F_fmax_ge_0: (B2R F_fmax >= 0)%R.
- simpl.
- unfold Defs.F2R; simpl.
- apply Rle_ge, Rmult_le_pos.
- + apply IZR_le; lia.
- + left; apply Raux.bpow_gt_0.
-Qed.
-
-Ltac fformat :=
- try intuition; try apply fexp_correct.
-
-Theorem generic_format_Rimax :
- Generic_fmt.generic_format Zaux.radix2 fexp R_imax.
-Proof.
- intros.
- red; unfold Defs.F2R, R_imax; simpl.
- rewrite <- Generic_fmt.scaled_mantissa_generic.
- + unfold Generic_fmt.scaled_mantissa.
- rewrite Rmult_assoc, Rmult_comm.
- rewrite <- Raux.bpow_plus.
- rewrite (Zplus_comm)%R.
- rewrite Zegal_left by lia; simpl; lra.
- + apply (Generic_fmt.generic_format_bpow Zaux.radix2 fexp emax).
- unfold fexp, SpecFloat.fexp, SpecFloat.emin.
- unfold FLX.Prec_gt_0 in *.
- unfold Prec_lt_emax in *.
- lia.
-Qed.
-
-Theorem round_Rimax :
- forall m, Generic_fmt.round Zaux.radix2 fexp (round_mode m) R_imax = R_imax.
-Proof.
- intros.
- apply Generic_fmt.round_generic; intuition.
- apply generic_format_Rimax.
-Qed.
-
-Lemma Rltb_lt :
- forall x y, Raux.Rlt_bool x y = true -> (x < y)%R.
-Proof.
- intros.
- pose proof (Hp := Raux.Rlt_bool_spec x y).
- rewrite H in Hp.
- now inversion Hp.
-Qed.
-
-Lemma Rimax_float :
- exists m e, R_imax = Defs.F2R (Defs.Float Zaux.radix2 m e).
-Proof.
- exists 1%Z.
- unfold R_imax, Defs.F2R; simpl.
- eexists.
- symmetry.
- apply Rmult_1_l.
-Qed.
-
-Lemma incr_R_fmax_R_imax :
- @Defs.F2R Zaux.radix2 {| Defs.Fnum := (Zpower 2 prec - 1 + 1)%Z ; Defs.Fexp := (emax - prec) |} = R_imax.
-Proof.
- unfold Defs.F2R, R_imax; simpl.
- replace (2 ^ prec - 1 + 1)%Z with (2 ^ prec)%Z by lia.
- rewrite (Raux.IZR_Zpower Zaux.radix2).
- + rewrite <- Raux.bpow_plus.
- replace (prec + (emax - prec))%Z with (emax) by lia.
- reflexivity.
- + unfold FLX.Prec_gt_0 in Hprec.
- unfold Prec_lt_emax in Hemax.
- lia.
-Qed.
-
-Theorem do_overflow_iff:
- forall m x,
- let fexp := SpecFloat.fexp prec emax in
- let rx := Generic_fmt.round Zaux.radix2 fexp (round_mode m) x in
- do_overflow m x = true <-> (Raux.Rle_bool R_imax rx = true \/ Raux.Rle_bool rx (-R_imax)%R = true).
-Proof.
- intros; split; intros.
- - unfold do_overflow in H.
- unfold Rabs in H.
- destruct Rcase_abs.
- + apply Rleb_Rle in H.
- right. apply Raux.Rle_bool_true.
- apply Ropp_le_contravar in H.
- replace (rx) with (--rx)%R by lra.
- subst rx; auto.
- + apply Rleb_Rle in H.
- left. apply Raux.Rle_bool_true.
- auto.
- - destruct H; apply Raux.Rle_bool_true; apply Rleb_Rle in H.
- + eauto using Rle_trans, H, Rle_abs.
- + apply Ropp_le_contravar in H.
- replace (--R_imax)%R with R_imax in H by lra.
- pose proof R_imax_gt_0.
- assert (0 <= -rx)%R by lra.
- assert (0 > rx)%R by lra.
- assert (-rx > rx)%R by lra.
- assert (Rabs rx = - rx)%R by auto using Rabs_left.
- rewrite <- H4 in H.
- auto.
-Qed.
-
-Lemma overflow_is_le :
- forall m r1 r2,
- (r1 <= r2)%R ->
- (0 <= r1)%R ->
- do_overflow m r1 = true ->
- do_overflow m r2 = true.
-Proof.
- intros m r1 r2 Hle Hr1 Ho.
- rewrite do_overflow_iff in Ho. destruct Ho as [H | H].
- - apply Rleb_Rle in H.
- rewrite do_overflow_iff. left.
- apply Raux.Rle_bool_true.
- eapply Generic_fmt.round_le in Hle.
- + eapply Rle_trans; [apply H | apply Hle].
- + now apply fexp_correct.
- + intuition.
- - apply Rleb_Rle in H.
- assert (-R_imax < 0)%R.
- { assert (R_imax > 0)%R by apply R_imax_gt_0. lra. }
- pose proof H0.
- apply Rlt_le in H1.
- eapply Generic_fmt.round_le in Hr1.
- + erewrite Generic_fmt.round_0 in Hr1.
- assert (0 < 0)%R.
- eapply Rle_lt_trans.
- apply Hr1.
- eapply Rle_lt_trans.
- apply H.
- apply H0.
- lra.
- intuition.
- + now apply fexp_correct.
- + intuition.
-Qed.
-
-Lemma overflow_is_ge :
- forall m r1 r2,
- (r1 <= r2)%R ->
- (r2 <= 0)%R ->
- do_overflow m r2 = true ->
- do_overflow m r1 = true.
-Proof.
- intros m r1 r2 Hle Hr1 Ho.
- rewrite do_overflow_iff in Ho. destruct Ho as [H | H].
- - apply Rleb_Rle in H.
- rewrite <- (round_Rimax m) in H.
- eapply (Generic_fmt.round_le Zaux.radix2 fexp (round_mode m)) in Hr1; intuition.
- rewrite Generic_fmt.round_0 in Hr1.
- assert (Generic_fmt.round Zaux.radix2 fexp (round_mode m) R_imax <= 0)%R.
- + eapply Rle_trans.
- * apply H.
- * apply Hr1.
- + pose proof R_imax_gt_0.
- rewrite (round_Rimax m) in H0.
- lra.
- + intuition.
- - apply Rleb_Rle in H.
- rewrite do_overflow_iff. right.
- apply Raux.Rle_bool_true.
- apply (Generic_fmt.round_le Zaux.radix2 fexp (round_mode m)) in Hle.
- eapply Rle_trans.
- + apply Hle.
- + apply H.
-Qed.
-
-Lemma round_0:
- forall m,
- Real 0 = round m (Real 0).
-Proof.
- intros m.
- unfold round.
- assert (H: do_overflow m 0 = false).
- { unfold do_overflow, R_imax.
- rewrite Generic_fmt.round_0 by fformat.
- rewrite Rabs_R0.
- apply Raux.Rle_bool_false.
- apply Raux.bpow_gt_0.
- }
- rewrite H.
- now rewrite Generic_fmt.round_0 by fformat.
-Qed.
-
-Theorem round_le:
- forall (m : mode) (r1 r2 : Rx), leb r1 r2 = true -> leb (round m r1) (round m r2) = true.
-Proof.
- intros m [ r1 | [] ] [r2 | []] H; try easy.
- Ltac fbounded :=
- match goal with
- | [ Ho1 : do_overflow _ _ = false |- _ ] =>
- apply Raux.Rle_bool_true;
- destruct (dont_overflow_inv _ _ Ho1) as (f & [?Hreq ?Hf]);
- rewrite ?Hreq; first [now apply Bleb_Rle, F_fmax_min | now apply Bleb_Rle, F_fmax_max ]
- end.
- Ltac freals :=
- match goal with
- | [ H : Raux.Rle_bool _ _ = true |- _ ] =>
- apply Raux.Rle_bool_true; apply Rleb_Rle in H;
- now apply Generic_fmt.round_le; fformat
- end.
- Ltac finfinites :=
- simpl; now destruct overflow_to_inf eqn:?, do_overflow eqn:?, sign eqn:?.
- Ltac absurd_sign :=
- match goal with
- | [ Hs2 : sign _ = true, Hs1 : sign _ = false, H : Raux.Rle_bool _ _ = true |- _ ] =>
- now rewrite (pos_Rleb_neg _ _ Hs1 Hs2) in H
- end.
- Ltac absurd_mode :=
- match goal with
- | [ m : mode |- _] => now destruct m
- end.
- Ltac absurd_overflow :=
- match goal with
- | [ H : Raux.Rle_bool _ _ = true,
- Hs : sign _ = false,
- Ho1 : do_overflow _ _ = true,
- Ho2 : do_overflow _ _ = false
- |- _
- ] => apply Rleb_Rle in H; now rewrite (overflow_is_le _ H (sign_pos_inv _ Hs) Ho1) in Ho2
- | [ H : Raux.Rle_bool _ _ = true,
- Hs : sign _ = true,
- Ho1 : do_overflow _ _ = false,
- Ho2 : do_overflow _ _ = true
- |- _
- ] => apply Rleb_Rle in H; now rewrite (overflow_is_ge _ H (sign_neg_inv _ Hs) Ho2) in Ho1
- | [ H : Raux.Rle_bool _ _ = false,
- Hs : sign _ = true,
- Ho1 : do_overflow _ _ = true,
- Ho2 : do_overflow _ _ = false
- |- _
- ] => apply Rleb_Rle in H; now rewrite (overflow_is_ge _ H (sign_neg_inv _ Hs) Ho2) in Ho1
- | [ H1 : overflow_to_inf _ _ = true, H2 : overflow_to_inf _ _ = false |- _ ] =>
- now rewrite H1 in H2
- end.
- Ltac absurd_case :=
- match goal with
- | [r1 : R, r2 : R |- _ ] =>
- try absurd_mode; try absurd_sign; absurd_overflow
- end.
- Ltac sign_analysis :=
- match goal with
- | [r1 : R, r2 : R |- _ ] =>
- destruct (sign r1) eqn:Hs1, (sign r2) eqn:Hs2; auto
- end.
- - simpl in H. unfold round.
- destruct (do_overflow m r1) eqn:Ho1;
- destruct (do_overflow m r2) eqn:Ho2;
- destruct (overflow_to_inf m (sign r1)) eqn:Hi1;
- destruct (overflow_to_inf m (sign r2)) eqn:Hi2;
- (try freals); sign_analysis; try absurd_case; try fbounded ; simpl.
- + unfold Raux.Rle_bool.
- destruct Raux.Rcompare eqn:E; try easy.
- apply Raux.Rcompare_Gt_inv in E; lra.
- + unfold Raux.Rle_bool.
- destruct Raux.Rcompare eqn:E; try easy.
- apply Raux.Rcompare_Gt_inv in E.
- unfold Defs.F2R in E; simpl in E.
- apply Rmult_lt_reg_r in E.
- * apply lt_IZR in E; lia.
- * apply Raux.bpow_gt_0.
- + unfold Raux.Rle_bool.
- destruct Raux.Rcompare eqn:E; try easy.
- apply Raux.Rcompare_Gt_inv in E; lra.
- (* + apply Raux.Rle_bool_true.
- apply do_overflow_false in Ho2.
- unfold dont_overflow in Ho2.
- apply Rltb_Rlt in Ho2.
- apply Raux.Rabs_lt_inv in Ho2.
- destruct Ho2 as [Ho2 Ho2'].
- Search ()
- assert (- R_imax)
- assert (R_imax < (Generic_fmt.round Zaux.radix2 (SpecFloat.fexp prec emax)
- (round_mode m) r2))%R.
-
- unfold R_imax in Ho2.
-
- destruct (dont_overflow_inv _ _ Ho2) as (f & [?Hreq ?Hf]).
- unfold Generic_fmt.round, Defs.F2R; simpl.
- Raux.bpow_simplify.
- unfold FLX.Prec_gt_0 in Hprec.
- unfold Prec_lt_emax in Hemax.
- rewrite <- Raux.IZR_Zpower by lia.
- rewrite <- mult_IZR.
- rewrite <- Raux.IZR_Zpower.
- unfold Generic_fmt.cexp.
- rewrite <- mult_IZR.
- apply IZR_le.
- rewrite Hreq.
- unfold Generic_fmt.round. apply F2R_congr. *)
- - finfinites.
-Qed.
-
-Lemma round_inf :
- forall m b, round m (Inf b) = Inf b.
-Proof. reflexivity. Qed.
-
-
-Example leb_infp_true :
- forall x, leb x (Inf false) = true.
-Proof. now induction x as [ | [ ] ]. Qed.
-
-Example leb_infm_true :
- forall x, leb (Inf true) x = true.
-Proof. now induction x as [ | [ ] ]. Qed.
-
-Example leb_real :
- forall r1 r2, leb (Real r1) (Real r2) = Raux.Rle_bool r1 r2.
-Proof. reflexivity. Qed.
-
-Example leb_refl :
- forall x, leb x x = true.
-Proof.
- induction x as [ | [ ] ]; auto.
- apply Raux.Rle_bool_true; lra.
-Qed.
-
-Definition add (x y : Rx) : Rx :=
- match x with
- | Inf true => x
- | Inf false =>
- match y with
- | Inf true => Inf true
- | _ => x
- end
- | Real r =>
- match y with
- | Inf _ => y
- | Real r' => Real (r + r')%R
- end
- end.
-
-Lemma leb_trans :
- forall x y z : Rx, leb x y = true -> leb y z = true -> leb x z = true.
-Proof.
- intros [ rx | [ ] ] [ ry | [ ] ] [ rz | [ ] ] Hxy Hyz; simpl in *; try easy.
- apply Rleb_Rle in Hxy.
- apply Rleb_Rle in Hyz.
- apply Raux.Rle_bool_true.
- lra.
-Qed.
-
-Lemma add_leb_mono_l :
- forall x y z : Rx,
- leb x y = true -> leb (add x z) (add y z) = true.
-Proof.
- intros [ ] [ ] [ ] H.
- - simpl in *.
- apply Rleb_Rle in H.
- apply Raux.Rle_bool_true.
- lra.
- - now destruct b.
- - now destruct b.
- - now destruct b, b0.
- - now destruct b.
- - now destruct b, b0.
- - now destruct b, b0.
- - now destruct b, b0, b1.
-Qed.
-
-Lemma add_leb_mono_r :
- forall x y z : Rx,
- leb x y = true -> leb (add z x) (add z y) = true.
-Proof.
- intros [ | [ ]] [ | [ ]] [ | [ ]] H; try easy.
- simpl in *.
- apply Rleb_Rle in H.
- apply Raux.Rle_bool_true.
- lra.
-Qed.
-
-Lemma add_real :
- forall (r1 r2 : R), add (Real r1) (Real r2) = Real (r1 + r2)%R.
-Proof. reflexivity. Qed.
-
-Lemma add_0_l:
- forall r : Rx, add (Real 0) r = r.
-Proof. destruct r; simpl; intuition. Qed.
-
-Lemma add_0_r:
- forall r : Rx, add r (Real 0) = r.
-Proof. destruct r; try destruct b; simpl; intuition. Qed.
-
-Definition mult (x y : Rx) : Rx :=
- match x, y with
- | Inf sx, Inf sy => Inf (xorb sx sy)
- | Real rx, Inf sy => Inf (xorb (sign rx) sy)
- | Inf sx, Real ry => Inf (xorb sx (sign ry))
- | Real rx, Real ry => Real (rx * ry)%R
- end.
-
-Lemma mult_leb_mono_l :
- forall x y z : Rx,
- leb (Real 0) z = true ->
- leb x y = true -> leb (mult x z) (mult y z) = true.
-Admitted.
-
-Definition B2Rx (x : float) :=
- match x with
- | B754_infinity b => Inf b
- | _ => Real (B2R x)
- end.
-
-
-Lemma B2Rx_finite :
- forall (f : float),
- is_finite f = true -> B2Rx f = Real (B2R f).
-Proof. now destruct f. Qed.
-
-Lemma bounded_dont_overflow :
- forall mode s m e (H : SpecFloat.bounded prec emax m e = true),
- dont_overflow mode (B2R (B754_finite s m e H)) = true.
-Proof.
- intros.
- unfold dont_overflow.
- apply Raux.Rlt_bool_true.
- apply Raux.Rabs_lt; split.
- + rewrite Generic_fmt.round_generic by (intuition; apply generic_format_B2R).
- rewrite <- Ropp_involutive.
- apply Ropp_lt_contravar.
- rewrite <- B2R_Bopp; simpl (Bopp _).
- apply (Rle_lt_trans _ R_fmax).
- - rewrite R2F_fmax. auto using Bleb_Rle, F_fmax_max.
- - apply Rimax_Rfmax.
- + rewrite Generic_fmt.round_generic by (intuition; apply generic_format_B2R).
- apply (Rle_lt_trans _ R_fmax).
- - rewrite R2F_fmax. auto using Bleb_Rle, F_fmax_max.
- - apply Rimax_Rfmax.
-Qed.
-
-Lemma round_id :
- forall m (f : float),
- B2Rx f = round m (B2Rx f).
-Proof.
- intros m; destruct f as [ [ ] | [ ] | | ]; try easy.
- + simpl (B2Rx _); apply round_0.
- + simpl (B2Rx _); apply round_0.
- + simpl (B2Rx _); apply round_0.
- + unfold B2Rx, round.
- rewrite (dont_overflow_true _ _ (bounded_dont_overflow m s m0 e e0)).
- now rewrite Generic_fmt.round_generic by (intuition; apply generic_format_B2R).
-Qed.
-
-Lemma B2Rx_le :
- forall (x y : float),
- is_nan x = false ->
- is_nan y = false ->
- leb (B2Rx x) (B2Rx y) = true ->
- Bleb x y = true.
-Proof.
- intros x y Hx Hy Hxy.
- fdestruct x; fdestruct y;
- repeat (unfold B2Rx in Hxy);
- unfold leb in Hxy;
- apply Rle_Bleb; try easy;
- now apply Rleb_Rle.
-Qed.
-
-Ltac fdestruct f :=
- destruct f as [ [ ] | [ ] | | ] eqn:?E; try easy.
-
-Lemma B2Rx_B2R :
- forall (x : float),
- is_finite x = true ->
- B2Rx x = Real (B2R x).
-Proof. now intros [ ] Fx. Qed.
-
-Lemma le_B2Rx :
- forall (x y : float),
- Bleb x y = true ->
- leb (B2Rx x) (B2Rx y) = true.
-Proof.
- Ltac by_comparison :=
- match goal with
- | [ x : _, y : _, E : _, E0 : _, H : _ |- _ ] =>
- rewrite <- E, <- E0 in H;
- unfold Bleb, SpecFloat.SFleb in H;
- replace (SpecFloat.SFcompare (B2SF _) (B2SF _)) with (Bcompare x y) in H by auto;
- rewrite E, E0 in *;
- rewrite Bcompare_correct in H by auto;
- rewrite B2Rx_B2R by auto;
- rewrite B2Rx_B2R, leb_real by auto;
- destruct (Raux.Rcompare _) eqn:Cmp in H; try easy;
- [ apply Raux.Rcompare_Eq_inv in Cmp | apply Raux.Rcompare_Lt_inv in Cmp ];
- apply Raux.Rle_bool_true; lra
- end.
- Ltac by_computation :=
- simpl; apply Raux.Rle_bool_true; lra.
- intros.
- fdestruct x; fdestruct y; try by_computation; by_comparison.
-Qed.
-
-Definition SF2Rx (x : SpecFloat.spec_float) :=
- match x with
- | S754_infinity b => Inf b
- | _ => Real (SF2R Zaux.radix2 x)
- end.
-
-Lemma B2Rx_SF2Bx :
- forall (x : SpecFloat.spec_float) (Hx : SpecFloat.valid_binary prec emax x = true),
- B2Rx (SF2B x Hx) = SF2Rx x.
-Proof.
- destruct x; trivial.
-Qed.
-
-End Rextended.
-
-Arguments round {prec} {emax} {Hprec} {Hemax}.
-Arguments round_le {prec} {emax} {Hprec} {Hemax}.
-Arguments B2Rx {prec} {emax}.
-Arguments B2Rx_le {prec} {emax}.
-Arguments le_B2Rx {prec} {emax}.
-Arguments B2Rx_B2R {prec} {emax}.
-Arguments B2Rx_finite {prec} {emax}.
diff --git a/farith2/thry/Tactics.v b/farith2/thry/Tactics.v
deleted file mode 100644
index 6a9577937..000000000
--- a/farith2/thry/Tactics.v
+++ /dev/null
@@ -1,2 +0,0 @@
-From Flocq Require Import IEEE754.BinarySingleNaN.
-From Coq Require Import QArith Psatz Reals.
diff --git a/farith2/thry/Utils.v b/farith2/thry/Utils.v
deleted file mode 100644
index 91aacfaee..000000000
--- a/farith2/thry/Utils.v
+++ /dev/null
@@ -1,705 +0,0 @@
-From Flocq Require Import IEEE754.BinarySingleNaN.
-From Coq Require Import ZArith Lia Reals Psatz Bool.
-(* From F Require Import Rextended. *)
-
-(**
- Usefull facts & definitions about R
-*)
-Section Rutils.
-
-Definition sign (r : R) :=
- Raux.Rlt_bool r 0.
-
-Lemma sign_pos_inv :
- forall r, sign r = false -> (0 <= r)%R.
-Proof.
- intros.
- unfold sign in H.
- now destruct (Raux.Rlt_bool_spec r 0).
-Qed.
-
-Lemma sign_neg_inv :
- forall r, sign r = true -> (r <= 0)%R.
-Proof.
- intros.
- unfold sign in H. left.
- now destruct (Raux.Rlt_bool_spec r 0).
-Qed.
-
-Lemma sign_neg_inv_strict:
- forall r, sign r = true -> (r < 0)%R.
-Proof.
- intros.
- unfold sign in H.
- now destruct (Raux.Rlt_bool_spec r 0).
-Qed.
-
-Lemma minus_pos_lt :
- forall r1 r2, (0 < r2)%R -> (r1 - r2 < r1)%R.
-Proof.
- intros; lra.
-Qed.
-
-Lemma IZR_neg :
- (forall x, IZR (Z.neg x) < 0)%R.
-Proof.
- induction x; try lra;
- apply (Rgt_trans _ (IZR (Z.neg x))); auto;
- apply IZR_lt; lia.
-Qed.
-
-Lemma IZR_pos :
- (forall x, IZR (Z.pos x) > 0)%R.
-Proof.
- induction x; try lra;
- apply (Rgt_trans _ (IZR (Z.pos x))); auto;
- apply IZR_lt; lia.
-Qed.
-
-Lemma pos_Rleb_neg :
- forall r1 r2,
- sign r1 = false ->
- sign r2 = true ->
- Raux.Rle_bool r1 r2 = false.
-Proof.
- intros. unfold sign in *.
- destruct (Raux.Rlt_bool_spec r1 0); try easy.
- destruct (Raux.Rlt_bool_spec r2 0); try easy.
- apply Raux.Rle_bool_false; lra.
-Qed.
-
-Lemma Rleb_Rle :
- forall r1 r2, Raux.Rle_bool r1 r2 = true -> (r1 <= r2)%R.
-Proof.
- intros.
- now destruct (Raux.Rle_bool_spec r1 r2).
-Qed.
-
-Lemma Reqb_Req :
- forall r1 r2, Raux.Req_bool r1 r2 = true -> (r1 = r2)%R.
-Proof.
- intros.
- now destruct (Raux.Req_bool_spec r1 r2).
-Qed.
-
-Lemma Rltb_Rlt :
- forall r1 r2, Raux.Rlt_bool r1 r2 = true -> (r1 < r2)%R.
-Proof.
- intros.
- now destruct (Raux.Rlt_bool_spec r1 r2).
-Qed.
-
-Lemma Rsign_split :
- forall (r : R), (r < 0 \/ r = 0 \/ r > 0)%R.
-Proof.
- intros. lra.
-Qed.
-
-End Rutils.
-
-(*********************************************************
- Simple & usefull results on floats
-**********************************************************)
-
-#[global] Notation "x <= y" := (Bleb x y = true).
-#[global] Notation "x <= y <= z" := (Bleb x y = true /\ Bleb y z = true).
-#[global] Notation "'+oo'" := (B754_infinity false).
-#[global] Notation "'-oo'" := (B754_infinity true).
-#[global] Notation "'NaN'" := (B754_nan).
-
-Ltac fdestruct f :=
- destruct f as [ [ ] | [ ] | | ]; try easy.
-
-Section Utils.
-
-Variable prec : Z.
-Variable emax : Z.
-Context (Hprec : FLX.Prec_gt_0 prec).
-Context (Hemax : Prec_lt_emax prec emax).
-
-Definition float := binary_float prec emax.
-
-Definition is_inf (x : float) :=
- match x with
- | B754_infinity _ => true
- | _ => false
- end.
-
-Definition is_infp (x : float) :=
- match x with
- | B754_infinity s => negb s
- | _ => false
- end.
-
-Definition is_infm (x : float) :=
- match x with
- | B754_infinity s => s
- | _ => false
- end.
-
-Lemma le_not_nan :
- forall x y : float, Bleb x y = true -> is_nan x = false /\ is_nan y = false.
-Proof. now intros [ ] [ ]. Qed.
-
-Lemma le_not_nan_l :
- forall x y : float, Bleb x y = true -> is_nan x = false.
-Proof.
- intros.
- exact (proj1 (le_not_nan x y H)).
-Qed.
-
-Lemma le_not_nan_r :
- forall x y : float, Bleb x y = true -> is_nan y = false.
-Proof.
- intros.
- exact (proj2 (le_not_nan x y H)).
-Qed.
-
-Lemma infm_min :
- forall (x : float), is_nan x = false -> -oo <= x.
-Proof. fdestruct x. Qed.
-
-Lemma infp_max :
- forall (x : float), is_nan x = false -> x <= +oo.
-Proof. fdestruct x. Qed.
-
-Lemma infp_le_is_infp :
- forall x : float, +oo <= x -> x = +oo.
-Proof.
- now intros [ [ ] | [ ] | | ] H.
-Qed.
-
-Lemma le_infm_is_infm :
- forall x : float, x <= -oo -> x = -oo.
-Proof.
- now intros [ [ ] | [ ] | | ] H.
-Qed.
-
-Lemma is_infm_inv:
- forall x : float, is_infm x = true -> x = -oo.
-Proof. now intros [ [ ] | [ ] | | ]. Qed.
-
-Lemma is_infp_inv:
- forall x : float, is_infp x = true -> x = +oo.
-Proof. now intros [ [ ] | [ ] | | ]. Qed.
-
-Lemma is_nan_inv:
- forall x : float, is_nan x = true -> x = NaN.
-Proof. now intros [ ]. Qed.
-
-Lemma le_infp_finite:
- forall x : float, is_finite x = true -> +oo <= x -> False.
-Proof. now intros [ ]. Qed.
-
-Lemma le_infm_finite:
- forall x : float, is_finite x = true -> x <= -oo -> False.
-Proof. now intros [ ]. Qed.
-
-Lemma Bplus_finites_not_nan :
- forall m (x y : float),
- is_finite x = true ->
- is_finite y = true ->
- is_nan (Bplus m x y) = false.
-Proof.
- intros m [[ ] | [ ] | | ] [ [ ] | [ ] | | ] Fx Fy; try easy.
- - now destruct m.
- - now destruct m.
- - unfold Bplus.
- auto using (is_nan_binary_normalize prec emax).
-Qed.
-
-Lemma Bplus_nan_inv :
- forall (m : mode) (x y:float), is_nan (Bplus m x y) = true ->
- x = +oo /\ y = -oo \/ x = -oo /\ y = +oo \/ x = NaN \/ y = NaN.
-Proof.
- intros; fdestruct x; fdestruct y; auto.
- - now destruct m.
- - now destruct m.
- - now rewrite Bplus_finites_not_nan in H.
-Qed.
-
-Lemma Bplus_not_nan_inv :
- forall (m : mode) (x y:float), is_nan (Bplus m x y) = false ->
- ~(x = +oo /\ y = -oo) /\ ~(x = -oo /\ y = +oo) /\ (is_nan x = false) /\ (is_nan y = false).
-Proof.
- intros; repeat split; fdestruct x; fdestruct y.
-Qed.
-
-(* Lemma Bplus_nan_if :
- forall m (x y : float),
- is_nan x = false ->
- is_nan y = false ->
- is_nan (Bplus m x y) = true ->
- (x = +oo /\ y = -oo) \/ (x = -oo /\ y = +oo).
-Proof.
- intros.
- fdestruct x; fdestruct y; try now destruct m; intuition.
- assert (is_nan (Bplus m (B754_finite s m0 e e0) (B754_finite s0 m1 e1 e2)) = false) by auto using Bplus_finites_not_nan.
- rewrite H1 in H2; discriminate.
-Qed. *)
-
-Lemma Bplus_zero :
- forall m b (x : float),
- B2R (Bplus m (B754_zero b) x) = B2R x.
-Proof.
- intros ? [ ] [ [ ] | [ ] | | ]; try easy.
- - simpl; destruct m; reflexivity.
- - simpl; destruct m; reflexivity.
-Qed.
-
-Lemma pos_Bopp_neg :
- forall m e Hb, @B754_finite prec emax true m e Hb = Bopp (B754_finite false m e Hb).
-Proof. reflexivity. Qed.
-
-Lemma neg_Bopp_pos :
- forall m e Hb, @B754_finite prec emax false m e Hb = Bopp (B754_finite true m e Hb).
-Proof. reflexivity. Qed.
-
-Lemma Rle_Bleb :
- forall (x y : float),
- is_finite x = true ->
- is_finite y = true ->
- (B2R x <= B2R y)%R ->
- Bleb x y = true.
-Proof.
- intros x y Fx Fy Hxy.
- unfold Bleb, SpecFloat.SFleb.
- replace (SpecFloat.SFcompare (_ x) (_ y)) with (Bcompare x y) by auto.
- rewrite (Bcompare_correct _ _ x y Fx Fy).
- destruct Raux.Rcompare eqn:E; try easy.
- apply Raux.Rcompare_Gt_inv in E; lra.
-Qed.
-
-Lemma Rlt_Bltb :
- forall (x y : float),
- is_finite x = true ->
- is_finite y = true ->
- (B2R x < B2R y)%R ->
- Bltb x y = true.
-Proof.
- intros x y Fx Fy Hxy.
- unfold Bltb, SpecFloat.SFltb.
- replace (SpecFloat.SFcompare (_ x) (_ y)) with (Bcompare x y) by auto.
- rewrite (Bcompare_correct _ _ x y Fx Fy).
- destruct Raux.Rcompare eqn:E; auto.
- - apply Raux.Rcompare_Eq_inv in E; lra.
- - apply Raux.Rcompare_Gt_inv in E; lra.
-Qed.
-
-Lemma Bleb_Rle :
- forall x y : float, is_finite x = true -> is_finite y = true ->
- Bleb x y = true -> (B2R x <= B2R y)%R.
-Proof.
- intros x y Fx Fy H.
- unfold Bleb, SpecFloat.SFleb in H.
- replace (SpecFloat.SFcompare (_ x) (_ y)) with (Bcompare x y) in H by auto.
- rewrite (Bcompare_correct _ _ x y Fx Fy) in H.
- destruct (Raux.Rcompare) eqn:E in H; try easy.
- + apply Raux.Rcompare_Eq_inv in E; lra.
- + apply Raux.Rcompare_Lt_inv in E; lra.
-Qed.
-
-Lemma Bltb_Rlt :
- forall x y : float, is_finite x = true -> is_finite y = true ->
- Bltb x y = true -> (B2R x < B2R y)%R.
-Proof.
- intros x y Fx Fy H.
- unfold Bltb, SpecFloat.SFltb in H.
- replace (SpecFloat.SFcompare (_ x) (_ y)) with (Bcompare x y) in H by auto.
- rewrite (Bcompare_correct _ _ x y Fx Fy) in H.
- destruct (Raux.Rcompare) eqn:E in H; try easy.
- apply Raux.Rcompare_Lt_inv in E; lra.
-Qed.
-
-Lemma Bleb_trans :
- forall (x y z : float), x <= y -> y <= z -> x <= z.
-Proof.
- intros x y z Hxy Hyz.
- fdestruct x; fdestruct y; fdestruct z;
- apply Rle_Bleb; auto;
- apply Bleb_Rle in Hxy; auto;
- apply Bleb_Rle in Hyz; auto;
- lra.
-Qed.
-
-Lemma Bltb_trans :
- forall (x y z : float), Bltb x y = true -> Bltb y z = true -> Bltb x z = true.
-Proof.
- intros x y z Hxy Hyz.
- fdestruct x; fdestruct y; fdestruct z;
- apply Rlt_Bltb; auto;
- apply Bltb_Rlt in Hxy; auto;
- apply Bltb_Rlt in Hyz; auto;
- lra.
-Qed.
-
-Lemma Bltb_Bleb_trans :
- forall x y z : float, Bltb x y = true -> y <= z -> Bltb x z = true.
-Proof.
- intros x y z Hxy Hyz.
- fdestruct x; fdestruct y; fdestruct z;
- apply Rlt_Bltb; auto;
- apply Bltb_Rlt in Hxy; auto;
- apply Bleb_Rle in Hyz; auto;
- lra.
-Qed.
-
-Lemma Bleb_Bltb_trans :
- forall x y z : float, Bleb x y = true -> Bltb y z = true -> Bltb x z = true.
-Proof.
- intros x y z Hxy Hyz.
- fdestruct x; fdestruct y; fdestruct z;
- apply Rlt_Bltb; auto;
- apply Bleb_Rle in Hxy; auto;
- apply Bltb_Rlt in Hyz; auto;
- lra.
-Qed.
-
-Lemma Beqb_refl :
- forall x : float, is_nan x = false -> Beqb x x = true.
-Proof.
- intros; fdestruct x.
- unfold Beqb; cbn.
- destruct s;
- rewrite (Zaux.Zcompare_Eq e e) by reflexivity;
- now rewrite (Pcompare_refl m).
-Qed.
-
-Lemma Beqb_nan_l :
- forall (x : float), Beqb NaN x = false.
-Proof. fdestruct x. Qed.
-
-Lemma Beqb_nan_r :
- forall (x : float), Beqb x NaN = false.
-Proof. fdestruct x. Qed.
-
-Lemma Beqb_Bleb :
- forall x y : float, Beqb x y = true -> Bleb x y = true.
-Proof.
- intros x y Hxy.
- fdestruct x; fdestruct y; rewrite Beqb_correct in Hxy; auto;
- apply Rle_Bleb; auto; right;
- now apply Reqb_Req in Hxy.
-Qed.
-
-
-Lemma Bleb_refl :
- forall x:float, is_nan x = false -> Bleb x x = true.
-Proof.
- intros x Hx; fdestruct x.
- apply Rle_Bleb; auto; lra.
-Qed.
-
-Lemma Bltb_Bleb :
- forall x y : float, Bltb x y = true -> Bleb x y = true.
-Proof.
- intros x y Hxy.
- fdestruct x; fdestruct y;
- apply Rle_Bleb; auto;
- apply Bltb_Rlt in Hxy; auto;
- lra.
-Qed.
-
-Axiom proof_irr :
- forall m e (H H' : SpecFloat.bounded prec emax m e = true), H = H'.
-
-Lemma Bleb_antisymm_strict :
- forall x y : float, x <= y <= x -> Beqb x (B754_zero true) = false -> x = y.
-Proof.
- intros x y [H1 H2].
- fdestruct x; fdestruct y;
- try (destruct s; try easy);
- try (destruct s0; try easy).
- - intros _.
- cbn in H1, H2.
- destruct (e ?= e1)%Z eqn:E1; rewrite (Z.compare_antisym _ _), E1 in H2; simpl in H2; try discriminate.
- rewrite <- ZC4 in H1.
- destruct (Pos.compare_cont Eq m0 m) eqn:E2; try easy.
- apply (Pcompare_Eq_eq _ _) in E2; subst.
- apply (Z.compare_eq) in E1; subst; cbn.
- rewrite (proof_irr _ _ e0 e2).
- reflexivity.
- - intros _.
- cbn in H1, H2.
- rewrite ZC4 in H2.
- destruct (e1 ?= e)%Z eqn:E1; rewrite (Z.compare_antisym _ _), E1 in H1; simpl in H2; try discriminate.
- destruct (Pos.compare_cont Eq m m0) eqn:E2; try easy.
- + apply (Pcompare_Eq_eq _ _) in E2; subst.
- apply (Z.compare_eq) in E1; subst; cbn.
- rewrite (proof_irr _ _ e0 e2).
- reflexivity.
-Qed.
-
-
-Lemma Bleb_antisymm :
- forall x y : float, x <= y <= x -> Beqb x y = true.
-Proof.
- intros x y [H1 H2].
- fdestruct x; fdestruct y;
- try (destruct s; try easy);
- try (destruct s0; try easy).
- - cbn in H1, H2.
- destruct (e ?= e1)%Z eqn:E1; rewrite (Z.compare_antisym _ _), E1 in H2; simpl in H2; try discriminate.
- rewrite <- ZC4 in H1.
- destruct (Pos.compare_cont Eq m0 m) eqn:E2; try easy.
- apply (Pcompare_Eq_eq _ _) in E2; subst.
- apply (Z.compare_eq) in E1; subst; cbn.
- now rewrite Z.compare_refl, Pcompare_refl.
- - cbn in H1, H2.
- destruct (e ?= e1)%Z eqn:E1; rewrite (Z.compare_antisym _ _), E1 in H2; simpl in H2; try discriminate.
- destruct (Pos.compare_cont Eq m m0) eqn:E2; try easy.
- + apply (Pcompare_Eq_eq) in E2; subst.
- apply (Z.compare_eq) in E1; subst; cbn.
- now rewrite Z.compare_refl, Pcompare_refl.
- + destruct (Pos.compare_cont Eq m0 m) eqn:E3; try easy.
- * apply Pos.compare_nge_iff in E2.
- apply Pos.compare_eq_iff in E3.
- intuition.
- * apply Pos.compare_nge_iff in E2.
- apply Pos.compare_nge_iff in E3.
- intuition.
-Qed.
-
-Lemma Beqb_symm :
- forall x y : float, Beqb x y = true -> Beqb y x = true.
-Proof.
- intros x y Hxy.
- fdestruct x; fdestruct y; unfold Beqb in Hxy; simpl in *; try (now destruct s).
- unfold SpecFloat.SFeqb in Hxy; simpl in *.
- destruct s, s0; auto.
- * rewrite <- ZC4 in Hxy.
- destruct (e ?= e1)%Z eqn:E1, (Pos.compare_cont Eq m0 m) eqn:E2; simpl in *; try discriminate.
- rewrite Z.compare_eq_iff in E1; subst.
- apply Pcompare_Eq_eq in E2; subst.
- rewrite Beqb_correct; auto; simpl.
- unfold Raux.Req_bool.
- rewrite Raux.Rcompare_Eq; reflexivity.
- * destruct (e ?= e1)%Z eqn:E1, (Pos.compare_cont Eq m m0) eqn:E2; simpl in *; try discriminate.
- rewrite Z.compare_eq_iff in E1; subst.
- apply Pcompare_Eq_eq in E2; subst.
- rewrite Beqb_correct; auto; simpl.
- unfold Raux.Req_bool.
- rewrite Raux.Rcompare_Eq; reflexivity.
-Qed.
-
-Lemma Beqb_trans :
- forall x y z : float, Beqb x y = true -> Beqb y z = true -> Beqb x z = true.
-Proof.
- intros x y z H1 H2.
- apply Bleb_antisymm; split.
- - apply (Bleb_trans _ _ _ (Beqb_Bleb _ _ H1) (Beqb_Bleb _ _ H2)).
- - apply (Bleb_trans _ _ _ (Beqb_Bleb _ _ (Beqb_symm _ _ H2)) (Beqb_Bleb _ _ (Beqb_symm _ _ H1))).
-Qed.
-
-Lemma Bleb_false_Bltb :
- forall x y:float, is_nan x = false -> is_nan y = false -> Bleb x y = false -> Bltb y x = true.
-Proof.
- intros x y Hx Hy Hxy.
- destruct x as [ | [ ] | | ] eqn:Ex, y as [ | [ ] | | ] eqn:Ey; try easy; rewrite <- Ex, <- Ey in *;
- unfold Bleb, SpecFloat.SFleb in Hxy;
- replace (SpecFloat.SFcompare (B2SF _) (B2SF _)) with (Bcompare x y) in Hxy by auto;
- assert (Fx: is_finite x = true) by (rewrite Ex; auto);
- assert (Fy: is_finite y = true) by (rewrite Ey; auto);
- rewrite (Bcompare_correct _ _ x y Fx Fy) in Hxy; auto;
- destruct (Raux.Rcompare _ _) eqn:E; try easy;
- apply Raux.Rcompare_Gt_inv in E;
- apply Rlt_Bltb; auto.
-Qed.
-
-Lemma Bltb_false_Bleb :
- forall x y:float, is_nan x = false -> is_nan y = false -> Bltb x y = false -> Bleb y x = true.
-Proof.
- intros x y Hx Hy Hxy.
- destruct x as [ | [ ] | | ] eqn:Ex, y as [ | [ ] | | ] eqn:Ey; try easy; rewrite <- Ex, <- Ey in *;
- unfold Bltb, SpecFloat.SFltb in Hxy;
- replace (SpecFloat.SFcompare (B2SF _) (B2SF _)) with (Bcompare x y) in Hxy by auto;
- assert (Fx: is_finite x = true) by (rewrite Ex; auto);
- assert (Fy: is_finite y = true) by (rewrite Ey; auto);
- rewrite (Bcompare_correct _ _ x y Fx Fy) in Hxy; auto;
- destruct (Raux.Rcompare _ _) eqn:E; try easy;
- (apply Raux.Rcompare_Eq_inv in E || apply Raux.Rcompare_Gt_inv in E);
- apply Rle_Bleb; auto; lra.
-Qed.
-
-Lemma Bltb_true_Bleb :
- forall x y:float, is_nan x = false -> is_nan y = false -> Bltb x y = true -> Bleb y x = false.
-Proof.
- intros x y Hx Hy Hxy.
- destruct x as [ | [ ] | | ] eqn:Ex, y as [ | [ ] | | ] eqn:Ey; try easy; rewrite <- Ex, <- Ey in *;
- assert (Fx: is_finite x = true) by (rewrite Ex; auto);
- assert (Fy: is_finite y = true) by (rewrite Ey; auto);
- apply (Bltb_Rlt _ _ Fx Fy) in Hxy;
- apply not_true_is_false; intros Hcontr;
- apply (Bleb_Rle _ _ Fy Fx) in Hcontr;
- lra.
-Qed.
-
-Lemma Bleb_true_Bltb :
- forall x y:float, is_nan x = false -> is_nan y = false -> Bleb x y = true -> Bltb y x = false.
-Proof.
- intros x y Hx Hy Hxy.
- destruct x as [ | [ ] | | ] eqn:Ex, y as [ | [ ] | | ] eqn:Ey; try easy; rewrite <- Ex, <- Ey in *;
- assert (Fx: is_finite x = true) by (rewrite Ex; auto);
- assert (Fy: is_finite y = true) by (rewrite Ey; auto);
- apply (Bleb_Rle _ _ Fx Fy) in Hxy;
- apply not_true_is_false; intros Hcontr;
- apply (Bltb_Rlt _ _ Fy Fx) in Hcontr;
- lra.
-Qed.
-
-Definition Bmax (f1 f2 : float) : float :=
- if is_nan f1 || is_nan f2 then NaN
- else if Bleb f1 f2 then f2
- else f1.
-
-Definition Bmin (f1 f2 : float) : float :=
- if is_nan f1 || is_nan f2 then NaN
- else if Bleb f1 f2 then f1
- else f2.
-
-Lemma Bmax_max_1 :
- forall x y, (Bmax x y = x \/ Bmax x y = y).
-Proof.
- intros [ ] [ ]; unfold Bmax; destruct Bleb; intuition.
-Qed.
-
-Lemma Bmax_max_2 :
- forall x y, is_finite x = true -> is_finite y = true -> x <= Bmax x y /\ y <= Bmax x y.
-Proof.
- intros x y Fx Fy; unfold Bmax.
- assert (HnanX: is_nan x = false) by fdestruct x.
- assert (HnanY: is_nan y = false) by fdestruct y.
- rewrite HnanX, HnanY; simpl.
- split.
- - destruct (Bleb x y) eqn:?; auto.
- apply Bleb_refl; fdestruct x.
- - destruct (Bleb x y) eqn:E.
- + apply Bleb_refl; fdestruct y.
- + apply Bleb_false_Bltb in E; auto.
- now apply Bltb_Bleb in E.
-Qed.
-
-Lemma Bmax_le :
- forall x y z : float, x <= z -> y <= z -> Bmax x y <= z.
-Proof.
- intros x y z Hxz Hyz.
- assert (HnanX: is_nan x = false) by fdestruct x.
- assert (HnanY: is_nan y = false) by fdestruct y.
- unfold Bmax.
- rewrite HnanX, HnanY; simpl.
- now destruct (Bleb x y).
-Qed.
-
-Lemma Bmax_not_nan_inv :
- forall x y, is_nan (Bmax x y) = false -> is_nan x = false /\ is_nan y = false.
-Proof.
- intros; split.
- + fdestruct x.
- + fdestruct x; fdestruct y.
-Qed.
-
-Lemma Bmin_not_nan_inv :
- forall x y, is_nan (Bmin x y) = false -> is_nan x = false /\ is_nan y = false.
-Proof.
- intros; split.
- + fdestruct x.
- + fdestruct x; fdestruct y.
-Qed.
-
-Lemma Bmax_le_inv :
- forall x y z : float, Bmax x y <= z -> x <= z /\ y <= z.
-Proof.
- intros x y z Hxyz.
- assert (is_nan (Bmax x y) = false) by (fdestruct (Bmax x y)).
- unfold Bmax in Hxyz.
- apply Bmax_not_nan_inv in H.
- destruct H as [H1 H2].
- rewrite H1, H2 in Hxyz.
- simpl in *.
- destruct (Bleb x y) eqn:E; split; auto.
- - now apply (Bleb_trans x y z).
- - apply Bleb_false_Bltb in E; auto.
- apply Bltb_Bleb in E; auto.
- now apply (Bleb_trans y x z).
-Qed.
-
-Lemma Bmin_min_1 :
- forall x y, (Bmin x y = x \/ Bmin x y = y).
-Proof.
- intros [ ] [ ]; unfold Bmin; destruct Bleb; intuition.
-Qed.
-
-Lemma Bmin_min_2 :
- forall x y, is_finite x = true -> is_finite y = true -> Bmin x y <= x /\ Bmin x y <= y.
-Proof.
- intros x y Fx Fy; unfold Bmin.
- assert (HnanX: is_nan x = false) by fdestruct x.
- assert (HnanY: is_nan y = false) by fdestruct y.
- rewrite HnanX, HnanY; simpl.
- split.
- - destruct (Bleb x y) eqn:?.
- + apply Bleb_refl; fdestruct x.
- + assert (Hx : is_nan x = false) by (fdestruct x).
- assert (Hy : is_nan y = false) by (fdestruct y).
- apply Bleb_false_Bltb in Heqb; auto.
- apply Bltb_Rlt in Heqb; auto.
- apply Rle_Bleb; auto.
- lra.
- - destruct (Bleb x y) eqn:E; auto.
- apply Bleb_refl; fdestruct y.
-Qed.
-
-Lemma Bmin_le :
- forall x y z : float, z <= x -> z <= y -> z <= Bmin x y.
-Proof.
- intros x y z Hxz Hyz.
- assert (HnanX: is_nan x = false) by (fdestruct z; fdestruct x).
- assert (HnanY: is_nan y = false) by (fdestruct z; fdestruct y).
- unfold Bmin.
- rewrite HnanX, HnanY; simpl.
- now destruct (Bleb x y).
-Qed.
-
-Lemma Bmin_le_inv :
- forall x y z : float, z <= Bmin x y -> z <= x /\ z <= y.
-Proof.
- intros x y z Hxyz.
- assert (is_nan (Bmin x y) = false) by (fdestruct (Bmin x y); fdestruct z).
- unfold Bmin in Hxyz.
- apply Bmin_not_nan_inv in H.
- destruct H as [H1 H2].
- rewrite H1, H2 in Hxyz.
- simpl in *.
- destruct (Bleb x y) eqn:E; split; auto.
- - now apply (Bleb_trans z x y).
- - apply Bleb_false_Bltb in E; auto.
- apply Bltb_Bleb in E.
- now apply (Bleb_trans z y x).
-Qed.
-
-Lemma Bpred_not_nan :
- forall (x : float), is_nan x = false -> is_nan (Bpred x) = false.
-Proof.
- intros x <-.
- apply is_nan_Bpred.
-Qed.
-
-End Utils.
-
-Arguments le_not_nan {prec} {emax}.
-Arguments le_not_nan_l {prec} {emax}.
-Arguments le_not_nan_r {prec} {emax}.
-Arguments is_nan_inv {prec} {emax}.
-Arguments is_infm {prec} {emax}.
-Arguments is_infp {prec} {emax}.
-Arguments is_inf {prec} {emax}.
-Arguments Bplus_not_nan_inv {prec} {emax} {Hprec} {Hemax}.
-Arguments Bplus_nan_inv {prec} {emax} {Hprec} {Hemax}.
-Arguments Bmin {prec} {emax}.
-Arguments Bmax {prec} {emax}.
-Arguments Bmax_max_1 {prec} {emax}.
-Arguments Bmax_max_2 {prec} {emax}.
-Arguments Bmin_min_1 {prec} {emax}.
-Arguments Bmin_min_2 {prec} {emax}.
-Arguments Bleb_trans {prec} {emax}.
-Arguments Bltb_Bleb_trans {prec} {emax}.
diff --git a/farith2/thry/dune b/farith2/thry/dune
deleted file mode 100644
index 7df2fa582..000000000
--- a/farith2/thry/dune
+++ /dev/null
@@ -1,7 +0,0 @@
-(coq.theory
- (name Farith2)
-; (package farith2)
- (synopsis "Manipulation of float with arbitrary precision extracted from the Flocq library")
-; (modules <ordered_set_lang>)
-; (theories Flocq)
-)
diff --git a/qcheck b/qcheck
deleted file mode 160000
index 224d3699b..000000000
--- a/qcheck
+++ /dev/null
@@ -1 +0,0 @@
-Subproject commit 224d3699b8b438b140aaf1af7acd8b56fad8334d
diff --git a/src_colibri2/tests/solve/colibri/sat/scale_1.smt2 b/src_colibri2/tests/solve/colibri/sat/scale_1.smt2
index a55be943c..7382f729b 100644
--- a/src_colibri2/tests/solve/colibri/sat/scale_1.smt2
+++ b/src_colibri2/tests/solve/colibri/sat/scale_1.smt2
@@ -1,10 +1,10 @@
(set-info :smt-lib-version 2.6)
-(set-info :status-colibri2 steplimitreached)
;;; Processed by pysmt to remove constant-real bitvector literals
(set-logic QF_FP)
(set-info :source |SPARK inspired floating point problems by Florian Schanda and Martin Brain|)
(set-info :category "crafted")
(set-info :status sat)
+(set-info :status-colibri2 steplimitreached)
(define-fun is_finite ((f Float32)) Bool (or (fp.isNormal f) (fp.isZero f) (fp.isSubnormal f)))
(declare-fun a () Float32)
(assert (is_finite a))
diff --git a/src_colibri2/theories/FP/dom_interval.ml b/src_colibri2/theories/FP/dom_interval.ml
index 2dc82a1e0..af585916d 100644
--- a/src_colibri2/theories/FP/dom_interval.ml
+++ b/src_colibri2/theories/FP/dom_interval.ml
@@ -26,7 +26,7 @@ let debug =
Debug.register_info_flag ~desc:"for intervals for the arithmetic theory"
"FP.interval"
-module D = Farith2.I
+module D = Farith.I
let dom =
Dom.Kind.create
@@ -177,7 +177,7 @@ let init env =
Ground.register_converter env converter;
Daemon.attach_reg_value env Fp_value.key (fun d value ->
let v = Fp_value.value value in
- if not (Farith2.F.is_zero v) then (
+ if not (Farith.F.is_zero v) then (
(* An ugly way to fix a bug with the singleton {0} *)
let s = D.singleton v in
Debug.dprintf4 debug "[FP] set dom %a for %a" D.pp s Node.pp
diff --git a/src_colibri2/theories/FP/dune b/src_colibri2/theories/FP/dune
index 30caa47cd..cbb3f787c 100644
--- a/src_colibri2/theories/FP/dune
+++ b/src_colibri2/theories/FP/dune
@@ -4,7 +4,7 @@
(synopsis "theory of floatting points for colibri2")
(libraries
containers
- farith2
+ farith
colibri2.stdlib
colibri2.popop_lib
colibri2.theories.bool
diff --git a/src_colibri2/theories/FP/fp_value.ml b/src_colibri2/theories/FP/fp_value.ml
index 1bdb8211f..fcf0e4b94 100644
--- a/src_colibri2/theories/FP/fp_value.ml
+++ b/src_colibri2/theories/FP/fp_value.ml
@@ -22,8 +22,8 @@ open Colibri2_popop_lib
open Popop_stdlib
module F = struct
- include Farith2.F
- include MkDatatype (Farith2.F)
+ include Farith.F
+ include MkDatatype (Farith.F)
let name = "Fp_value"
end
@@ -97,7 +97,7 @@ let compute_ground d t =
| { app = { builtin = Expr.Fp_to_fp (_ew1, _prec1, ew2, prec2); _ }; args; _ }
->
let m, f1 = IArray.extract2_exn args in
- !<(F.of_q ~ew:ew2 ~mw:(prec2 - 1) !>>m (F.to_q !>f1))
+ !<(F.round ~ew:ew2 ~mw:(prec2 - 1) !>>m !>f1)
| { app = { builtin = Expr.Sbv_to_fp (n, ew, prec); _ }; args; _ } ->
let m, bv = IArray.extract2_exn args in
!<(F.of_q ~ew ~mw:(prec - 1) !>>m
@@ -332,11 +332,11 @@ let converter d (f : Ground.t) =
attach_interp d f
| { app = { builtin = Expr.Fp_geq (_ew, _prec); _ }; args; _ } ->
let a, b = IArray.extract2_exn args in
- cmp Farith2.F.ge a b;
+ cmp Farith.F.ge a b;
attach_interp d f
| { app = { builtin = Expr.Fp_eq (_ew, _prec); _ }; args; _ } ->
let a, b = IArray.extract2_exn args in
- cmp Farith2.F.eq a b;
+ cmp Farith.F.eq a b;
attach_interp d f
| _ -> ()
diff --git a/src_colibri2/theories/FP/fp_value.mli b/src_colibri2/theories/FP/fp_value.mli
index 04557f872..9f36a116e 100644
--- a/src_colibri2/theories/FP/fp_value.mli
+++ b/src_colibri2/theories/FP/fp_value.mli
@@ -18,7 +18,7 @@
(* for more details (enclosed in the file licenses/LGPLv2.1). *)
(*************************************************************************)
-include Value.S with type s = Farith2.F.t
+include Value.S with type s = Farith.F.t
(** Foating points values *)
val init : Egraph.wt -> unit
diff --git a/src_colibri2/theories/FP/rounding_mode.ml b/src_colibri2/theories/FP/rounding_mode.ml
index 55775b37c..1d57e4153 100644
--- a/src_colibri2/theories/FP/rounding_mode.ml
+++ b/src_colibri2/theories/FP/rounding_mode.ml
@@ -22,103 +22,92 @@ open Colibri2_popop_lib
open Popop_stdlib
module FarithModes = struct
- let string_of_mode = function
- | Farith2.NE -> "RoundNearestTiesToEven"
- | Farith2.NA -> "RoundNearestTiesToAway"
- | Farith2.UP -> "RoundTowardPositive"
- | Farith2.DN -> "RoundTowardNegative"
- | Farith2.ZR -> "RoundTowardZero"
+ let string_of_mode : Farith.Mode.t -> string = function
+ | NE -> "RoundNearestTiesToEven"
+ | NA -> "RoundNearestTiesToAway"
+ | UP -> "RoundTowardPositive"
+ | DN -> "RoundTowardNegative"
+ | ZR -> "RoundTowardZero"
- type t = Farith2.mode
+ type t = Farith.Mode.t
let hash = Hashtbl.hash
-
let compare = Stdlib.compare
-
- let equal = Stdlib.(=)
-
+ let equal = Stdlib.( = )
let hash_fold_t s t = Base.Hash.fold_int s (hash t)
-
let sexp_of_t t = Base.Sexp.Atom (string_of_mode t)
-
let pp fmt t = Format.pp_print_string fmt (string_of_mode t)
end
-module Modes = Value.Register(struct
- include FarithModes
- module M = Map.Make(FarithModes)
- module S = Extset.MakeOfMap(M)
- module H = XHashtbl.Make(FarithModes)
- let name = "RoundingMode"
- end)
+module Modes = Value.Register (struct
+ include FarithModes
+ module M = Map.Make (FarithModes)
+ module S = Extset.MakeOfMap (M)
+ module H = XHashtbl.Make (FarithModes)
+
+ let name = "RoundingMode"
+end)
include Modes
let rounding_mode_sequence =
let open Base.Sequence.Generator in
- (
- yield Farith2.NE >>= fun () ->
- yield Farith2.NA >>= fun () ->
- yield Farith2.UP >>= fun () ->
- yield Farith2.DN >>= fun () ->
- yield Farith2.ZR
- ) |> run
+ yield Farith.Mode.NE
+ >>= (fun () ->
+ yield Farith.Mode.NA >>= fun () ->
+ yield Farith.Mode.UP >>= fun () ->
+ yield Farith.Mode.DN >>= fun () -> yield Farith.Mode.ZR)
+ |> run
let init_ty d =
Interp.Register.ty d (fun d ty ->
match ty with
- | {app={builtin = Expr.RoundingMode;_};_} ->
- let seq =
- let open Interp.SeqLim in
- let+ e = of_seq d rounding_mode_sequence in
- (e |> index |> nodevalue)
- in
- Some seq
- | _ -> None
- )
+ | { app = { builtin = Expr.RoundingMode; _ }; _ } ->
+ let seq =
+ let open Interp.SeqLim in
+ let+ e = of_seq d rounding_mode_sequence in
+ e |> index |> nodevalue
+ in
+ Some seq
+ | _ -> None)
let interp d n = Opt.get_exn Impossible (Egraph.get_value d n)
let compute_cst t =
- let (!<) v = `Some (Modes.nodevalue (Modes.index v)) in
+ let ( !< ) v = `Some (Modes.nodevalue (Modes.index v)) in
match Ground.sem t with
- | { app = {builtin = Expr.RoundNearestTiesToEven; _}; _} ->
- !< Farith2.NE
- | { app = {builtin = Expr.RoundNearestTiesToAway; _}; _} ->
- !< Farith2.NA
- | { app = {builtin = Expr.RoundTowardNegative; _}; _} ->
- !< Farith2.DN
- | { app = {builtin = Expr.RoundTowardPositive; _}; _} ->
- !< Farith2.UP
- | { app = {builtin = Expr.RoundTowardZero; _}; _} ->
- !< Farith2.ZR
+ | { app = { builtin = Expr.RoundNearestTiesToEven; _ }; _ } -> !<Farith.Mode.NE
+ | { app = { builtin = Expr.RoundNearestTiesToAway; _ }; _ } -> !<Farith.Mode.NA
+ | { app = { builtin = Expr.RoundTowardNegative; _ }; _ } -> !<Farith.Mode.DN
+ | { app = { builtin = Expr.RoundTowardPositive; _ }; _ } -> !<Farith.Mode.UP
+ | { app = { builtin = Expr.RoundTowardZero; _ }; _ } -> !<Farith.Mode.ZR
| _ -> `None
let converter d f =
let r = Ground.node f in
let cst c = node (index c) in
- let merge n = Egraph.register d n; Egraph.merge d r n in
+ let merge n =
+ Egraph.register d n;
+ Egraph.merge d r n
+ in
match Ground.sem f with
- | { app = {builtin = Expr.RoundNearestTiesToEven; _}; _} ->
- merge (cst Farith2.NE)
- | { app = {builtin = Expr.RoundNearestTiesToAway; _}; _} ->
- merge (cst Farith2.NA)
- | { app = {builtin = Expr.RoundTowardNegative; _}; _} ->
- merge (cst Farith2.DN)
- | { app = {builtin = Expr.RoundTowardPositive; _}; _} ->
- merge (cst Farith2.UP)
- | { app = {builtin = Expr.RoundTowardZero; _}; _} ->
- merge (cst Farith2.ZR)
+ | { app = { builtin = Expr.RoundNearestTiesToEven; _ }; _ } ->
+ merge (cst Farith.Mode.NE)
+ | { app = { builtin = Expr.RoundNearestTiesToAway; _ }; _ } ->
+ merge (cst Farith.Mode.NA)
+ | { app = { builtin = Expr.RoundTowardNegative; _ }; _ } ->
+ merge (cst Farith.Mode.DN)
+ | { app = { builtin = Expr.RoundTowardPositive; _ }; _ } ->
+ merge (cst Farith.Mode.UP)
+ | { app = { builtin = Expr.RoundTowardZero; _ }; _ } -> merge (cst Farith.Mode.ZR)
| _ -> ()
-let init_check d = Interp.Register.check d (fun d t ->
- let check r =
- Value.equal r (interp d (Ground.node t))
- in
- match compute_cst t with
- | `None -> NA
- | `Some v -> Interp.check_of_bool (check v)
- )
+let init_check d =
+ Interp.Register.check d (fun d t ->
+ let check r = Value.equal r (interp d (Ground.node t)) in
+ match compute_cst t with
+ | `None -> NA
+ | `Some v -> Interp.check_of_bool (check v))
let init env =
Ground.register_converter env converter;
diff --git a/src_colibri2/theories/FP/rounding_mode.mli b/src_colibri2/theories/FP/rounding_mode.mli
index 047ea2a1c..ac883c3be 100644
--- a/src_colibri2/theories/FP/rounding_mode.mli
+++ b/src_colibri2/theories/FP/rounding_mode.mli
@@ -18,6 +18,6 @@
(* for more details (enclosed in the file licenses/LGPLv2.1). *)
(*************************************************************************)
-include Value.S with type s = Farith2.mode
+include Value.S with type s = Farith.Mode.t
val init : Egraph.wt -> unit
--
GitLab