From 9aacc59135071a979623ab177819cdbe9ce27056 Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Tue, 8 Sep 2020 18:29:00 +0200 Subject: Upgrade to Flocq 4.0. --- Makefile | 5 +- extraction/extraction.v | 7 +- flocq/Calc/Bracket.v | 57 +- flocq/Calc/Div.v | 5 +- flocq/Calc/Operations.v | 5 +- flocq/Calc/Plus.v | 171 ++ flocq/Calc/Round.v | 3 +- flocq/Calc/Sqrt.v | 5 +- flocq/Core/Core.v | 3 +- flocq/Core/Defs.v | 5 +- flocq/Core/Digits.v | 26 +- flocq/Core/FIX.v | 5 +- flocq/Core/FLT.v | 9 +- flocq/Core/FLX.v | 7 +- flocq/Core/FTZ.v | 6 +- flocq/Core/Float_prop.v | 12 +- flocq/Core/Generic_fmt.v | 9 +- flocq/Core/Raux.v | 43 +- flocq/Core/Round_NE.v | 5 +- flocq/Core/Round_pred.v | 3 + flocq/Core/Ulp.v | 12 +- flocq/Core/Zaux.v | 102 +- flocq/IEEE754/Binary.v | 2722 +++++++------------------------ flocq/IEEE754/BinarySingleNaN.v | 3421 +++++++++++++++++++++++++++++++++++++++ flocq/IEEE754/Bits.v | 48 +- flocq/IEEE754/SpecFloatCompat.v | 435 ----- flocq/Prop/Div_sqrt_error.v | 3 +- flocq/Prop/Double_rounding.v | 65 +- flocq/Prop/Mult_error.v | 10 +- flocq/Prop/Plus_error.v | 10 +- flocq/Prop/Relative.v | 4 +- flocq/Prop/Round_odd.v | 3 +- flocq/Prop/Sterbenz.v | 4 +- flocq/Version.v | 2 +- lib/Floats.v | 74 +- lib/IEEE754_extra.v | 206 ++- 36 files changed, 4637 insertions(+), 2875 deletions(-) create mode 100644 flocq/Calc/Plus.v create mode 100644 flocq/IEEE754/BinarySingleNaN.v delete mode 100644 flocq/IEEE754/SpecFloatCompat.v diff --git a/Makefile b/Makefile index 2bc39c33..103a6cb3 100644 --- a/Makefile +++ b/Makefile @@ -84,13 +84,12 @@ GPATH=$(DIRS) ifeq ($(LIBRARY_FLOCQ),local) FLOCQ=\ - SpecFloatCompat.v \ Raux.v Zaux.v Defs.v Digits.v Float_prop.v FIX.v FLT.v FLX.v FTZ.v \ Generic_fmt.v Round_pred.v Round_NE.v Ulp.v Core.v \ - Bracket.v Div.v Operations.v Round.v Sqrt.v \ + Bracket.v Div.v Operations.v Plus.v Round.v Sqrt.v \ Div_sqrt_error.v Mult_error.v Plus_error.v \ Relative.v Sterbenz.v Round_odd.v Double_rounding.v \ - Binary.v Bits.v + BinarySingleNaN.v Binary.v Bits.v else FLOCQ= endif diff --git a/extraction/extraction.v b/extraction/extraction.v index 8c2a52a2..2319be17 100644 --- a/extraction/extraction.v +++ b/extraction/extraction.v @@ -148,7 +148,12 @@ Extraction Blacklist List String Int. Extract Inlined Constant Defs.F2R => "fun _ -> assert false". Extract Inlined Constant Binary.FF2R => "fun _ -> assert false". Extract Inlined Constant Binary.B2R => "fun _ -> assert false". -Extract Inlined Constant Binary.round_mode => "fun _ -> assert false". +Extract Inlined Constant BinarySingleNaN.round_mode => "fun _ -> assert false". +Extract Inlined Constant BinarySingleNaN.SF2R => "fun _ -> assert false". +Extract Inlined Constant BinarySingleNaN.B2R => "fun _ -> assert false". +Extract Inlined Constant Binary.BSN.round_mode => "fun _ -> assert false". +Extract Inlined Constant Binary.BSN.SF2R => "fun _ -> assert false". +Extract Inlined Constant Binary.BSN.B2R => "fun _ -> assert false". Extract Inlined Constant Bracket.inbetween_loc => "fun _ -> assert false". (* Needed in Coq 8.4 to avoid problems with Function definitions. *) diff --git a/flocq/Calc/Bracket.v b/flocq/Calc/Bracket.v index 838cadfa..9ab55165 100644 --- a/flocq/Calc/Bracket.v +++ b/flocq/Calc/Bracket.v @@ -19,13 +19,14 @@ COPYING file for more details. (** * Locations: where a real number is positioned with respect to its rounded-down value in an arbitrary format. *) -From Coq Require Import Lia. -Require Import Raux Defs Float_prop. -Require Import SpecFloatCompat. +From Coq Require Import ZArith Reals Lia. +From Coq Require SpecFloat. -Notation location := location (only parsing). -Notation loc_Exact := loc_Exact (only parsing). -Notation loc_Inexact := loc_Inexact (only parsing). +Require Import Zaux Raux Defs Float_prop. + +Notation location := SpecFloat.location (only parsing). +Notation loc_Exact := SpecFloat.loc_Exact (only parsing). +Notation loc_Inexact := SpecFloat.loc_Inexact (only parsing). Section Fcalc_bracket. @@ -533,16 +534,35 @@ Qed. End Fcalc_bracket_step. -Section Fcalc_bracket_scale. +Section Bracket_plus. -Lemma inbetween_mult_aux : - forall x d s, - ((x * s + d * s) / 2 = (x + d) / 2 * s)%R. +Theorem inbetween_plus_compat : + forall x d u l t, + inbetween x d u l -> + inbetween (x + t) (d + t) (u + t) l. Proof. -intros x d s. -field. +intros x d u l t [Hx|l' Hx Hl] ; constructor. +now rewrite Hx. +now split ; apply Rplus_lt_compat_r. +replace ((x + t + (d + t)) / 2)%R with ((x + d) / 2 + t)%R by field. +now rewrite Rcompare_plus_r. Qed. +Theorem inbetween_plus_reg : + forall x d u l t, + inbetween (x + t) (d + t) (u + t) l -> + inbetween x d u l. +Proof. +intros x d u l t H. +generalize (inbetween_plus_compat _ _ _ _ (Ropp t) H). +assert (K: forall y, (y + t + -t = y)%R) by (intros y ; ring). +now rewrite 3!K. +Qed. + +End Bracket_plus. + +Section Fcalc_bracket_scale. + Theorem inbetween_mult_compat : forall x d u l s, (0 < s)%R -> @@ -552,7 +572,7 @@ Proof. intros x d u l s Hs [Hx|l' Hx Hl] ; constructor. now rewrite Hx. now split ; apply Rmult_lt_compat_r. -rewrite inbetween_mult_aux. +replace ((x * s + d * s) / 2)%R with ((x + d) / 2 * s)%R by field. now rewrite Rcompare_mult_r. Qed. @@ -562,12 +582,11 @@ Theorem inbetween_mult_reg : inbetween (x * s) (d * s) (u * s) l -> inbetween x d u l. Proof. -intros x d u l s Hs [Hx|l' Hx Hl] ; constructor. -apply Rmult_eq_reg_r with (1 := Hx). -now apply Rgt_not_eq. -now split ; apply Rmult_lt_reg_r with s. -rewrite <- Rcompare_mult_r with (1 := Hs). -now rewrite inbetween_mult_aux in Hl. +intros x d u l s Hs H. +generalize (inbetween_mult_compat _ _ _ _ _ (Rinv_0_lt_compat s Hs) H). +assert (K: forall y, (y * s * /s = y)%R). +{ intros y. field. now apply Rgt_not_eq. } +now rewrite 3!K. Qed. End Fcalc_bracket_scale. diff --git a/flocq/Calc/Div.v b/flocq/Calc/Div.v index 48e3bb51..88d99a1f 100644 --- a/flocq/Calc/Div.v +++ b/flocq/Calc/Div.v @@ -19,8 +19,9 @@ COPYING file for more details. (** * Helper function and theorem for computing the rounded quotient of two floating-point numbers. *) -From Coq Require Import Lia. -Require Import Raux Defs Generic_fmt Float_prop Digits Bracket. +From Coq Require Import ZArith Reals Lia. + +Require Import Zaux Raux Defs Generic_fmt Float_prop Digits Bracket. Set Implicit Arguments. Set Strongly Strict Implicit. diff --git a/flocq/Calc/Operations.v b/flocq/Calc/Operations.v index ac93d412..bcc93f6a 100644 --- a/flocq/Calc/Operations.v +++ b/flocq/Calc/Operations.v @@ -19,8 +19,9 @@ COPYING file for more details. (** * Basic operations on floats: alignment, addition, multiplication *) -From Coq Require Import Lia. -Require Import Raux Defs Float_prop. +From Coq Require Import ZArith Reals Lia. + +Require Import Zaux Raux Defs Float_prop. Set Implicit Arguments. Set Strongly Strict Implicit. diff --git a/flocq/Calc/Plus.v b/flocq/Calc/Plus.v new file mode 100644 index 00000000..bd338af8 --- /dev/null +++ b/flocq/Calc/Plus.v @@ -0,0 +1,171 @@ +(** +This file is part of the Flocq formalization of floating-point +arithmetic in Coq: http://flocq.gforge.inria.fr/ + +Copyright (C) 2010-2021 Sylvie Boldo +#
# +Copyright (C) 2010-2021 Guillaume Melquiond + +This library is free software; 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; either +version 3 of the License, or (at your option) any later version. + +This library 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 +COPYING file for more details. +*) + +(** * Helper function and theorem for computing the rounded sum of two floating-point numbers. *) + +From Coq Require Import ZArith Reals Lia. + +Require Import Core Bracket Operations Round. + +Section Plus. + +Variable beta : radix. +Notation bpow e := (bpow beta e). + +Variable fexp : Z -> Z. + +Context { monotone_exp : Monotone_exp fexp }. + +Definition Fplus_core m1 e1 m2 e2 e := + let k := (e - e2)%Z in + let '(m2', _, l) := + if Zlt_bool 0 k then truncate_aux beta (m2, e2, loc_Exact) k + else (m2 * Zpower beta (-k), e, loc_Exact)%Z in + let m1' := (m1 * Zpower beta (e1 - e))%Z in + (m1' + m2', l)%Z. + +Theorem Fplus_core_correct : + forall m1 e1 m2 e2 e, + (e <= e1)%Z -> + let '(m, l) := Fplus_core m1 e1 m2 e2 e in + inbetween_float beta m e (F2R (Float beta m1 e1) + F2R (Float beta m2 e2)) l. +Proof. +intros m1 e1 m2 e2 e He1. +unfold Fplus_core. +case Zlt_bool_spec ; intros He2. +- unfold truncate_aux. + unfold inbetween_float, F2R. simpl. + rewrite 3!plus_IZR. + rewrite Rplus_assoc. + rewrite 2!Rmult_plus_distr_r. + replace (IZR (m1 * Zpower beta (e1 - e)) * bpow e)%R with (IZR m1 * bpow e1)%R. + 2: { + rewrite mult_IZR, IZR_Zpower by lia. + rewrite Rmult_assoc, <- bpow_plus. + apply (f_equal (fun v => IZR m1 * bpow v)%R). + ring. + } + rewrite <- 3!(Rplus_comm _ (IZR m1 * bpow e1)). + apply inbetween_plus_compat. + set (k := (e - e2)%Z). + rewrite <- (plus_IZR _ 1). + replace e with (e2 + k)%Z by (unfold k ; ring). + apply inbetween_float_new_location. + exact He2. + now constructor 1. +- constructor 1. + unfold F2R. simpl. + rewrite plus_IZR, Rmult_plus_distr_r. + rewrite 2!mult_IZR, 2!IZR_Zpower by lia. + rewrite 2!Rmult_assoc, <- 2!bpow_plus. + apply (f_equal2 (fun v w => IZR m1 * bpow v + IZR m2 * bpow w)%R) ; ring. +Qed. + +Definition Fplus (f1 f2 : float beta) := + let (m1, e1) := f1 in + let (m2, e2) := f2 in + if Zeq_bool m1 0 then + (m2, e2, loc_Exact) + else if Zeq_bool m2 0 then + (m1, e1, loc_Exact) + else + let p1 := (Zdigits beta m1 + e1)%Z in + let p2 := (Zdigits beta m2 + e2)%Z in + if Zle_bool 2 (Z.abs (p1 - p2)) then + let e := Z.min (Z.max e1 e2) (fexp (Z.max p1 p2 - 1)) in + let (m, l) := + if Zlt_bool e1 e then + Fplus_core m2 e2 m1 e1 e + else + Fplus_core m1 e1 m2 e2 e in + (m, e, l) + else + let (m, e) := Fplus f1 f2 in + (m, e, loc_Exact). + +Theorem Fplus_correct : + forall x y, + let '(m, e, l) := Fplus x y in + (l = loc_Exact \/ e <= cexp beta fexp (F2R x + F2R y))%Z /\ + inbetween_float beta m e (F2R x + F2R y) l. +Proof. +intros [m1 e1] [m2 e2]. +unfold Fplus. +case Zeq_bool_spec ; intros Hm1. +{ rewrite Hm1. + split. + now left. + rewrite F2R_0, Rplus_0_l. + now constructor 1. } +case Zeq_bool_spec ; intros Hm2. +{ rewrite Hm2. + split. + now left. + rewrite F2R_0, Rplus_0_r. + now constructor 1. } +set (p1 := (Zdigits beta m1 + e1)%Z). +set (p2 := (Zdigits beta m2 + e2)%Z). +set (e := Z.min (Z.max e1 e2) (fexp (Z.max p1 p2 - 1))). +case Zle_bool_spec ; intros Hp ; cycle 1. +{ rewrite <- F2R_plus. + destruct Operations.Fplus as [m' e']. + split. + now left. + now constructor 1. } +set (z := (F2R _ + F2R _)%R). +assert (Hz: (e <= cexp beta fexp z)%Z). +{ apply Z.le_trans with (fexp (Z.max p1 p2 - 1)). + apply Z.le_min_r. + unfold cexp. + apply monotone_exp. + unfold z. + revert Hp. + unfold p1, p2. + rewrite <- 2!mag_F2R_Zdigits by easy. + clear -Hm1 Hm2. + destruct (Zle_or_lt (mag beta (F2R (Float beta m1 e1))) (mag beta (F2R (Float beta m2 e2)))) as [Hp'|Hp']. + - rewrite Z.max_r by easy. + rewrite Z.abs_neq by (clear -Hp'; lia). + rewrite Rplus_comm. + intros H. + apply mag_plus_ge. + now apply F2R_neq_0. + clear -H ; lia. + - rewrite Z.max_l, Z.abs_eq by (clear -Hp'; lia). + intros H. + apply mag_plus_ge. + now apply F2R_neq_0. + clear -H ; lia. } +case Zlt_bool_spec ; intros He. +- assert (He': (e <= e2)%Z) by (clear -He ; lia). + generalize (Fplus_core_correct m2 e2 m1 e1 e He'). + rewrite Rplus_comm. + fold z. + destruct Fplus_core as [m' l]. + refine (fun H => conj _ H). + now right. +- assert (He': (e <= e1)%Z) by (clear -He ; lia). + generalize (Fplus_core_correct m1 e1 m2 e2 e He'). + fold z. + destruct Fplus_core as [m' l]. + refine (fun H => conj _ H). + now right. +Qed. + +End Plus. diff --git a/flocq/Calc/Round.v b/flocq/Calc/Round.v index 704a1ab2..40da2f08 100644 --- a/flocq/Calc/Round.v +++ b/flocq/Calc/Round.v @@ -19,7 +19,8 @@ COPYING file for more details. (** * Helper function for computing the rounded value of a real number. *) -From Coq Require Import Lia. +From Coq Require Import ZArith Reals Lia. + Require Import Core Digits Float_prop Bracket. Section Fcalc_round. diff --git a/flocq/Calc/Sqrt.v b/flocq/Calc/Sqrt.v index 4d267d21..3c885bba 100644 --- a/flocq/Calc/Sqrt.v +++ b/flocq/Calc/Sqrt.v @@ -19,8 +19,9 @@ COPYING file for more details. (** * Helper functions and theorems for computing the rounded square root of a floating-point number. *) -From Coq Require Import Lia. -Require Import Raux Defs Digits Generic_fmt Float_prop Bracket. +From Coq Require Import ZArith Reals Lia. + +Require Import Zaux Raux Defs Digits Generic_fmt Float_prop Bracket. Set Implicit Arguments. Set Strongly Strict Implicit. diff --git a/flocq/Core/Core.v b/flocq/Core/Core.v index 78a140e1..6ec5728e 100644 --- a/flocq/Core/Core.v +++ b/flocq/Core/Core.v @@ -18,5 +18,4 @@ COPYING file for more details. *) (** To ease the import *) -Require Export Raux Defs Float_prop Round_pred Generic_fmt Round_NE. -Require Export FIX FLX FLT Ulp. +Require Export Zaux Raux Defs Digits Float_prop Round_pred Generic_fmt Round_NE FIX FLX FLT Ulp. diff --git a/flocq/Core/Defs.v b/flocq/Core/Defs.v index 27342df9..4a199e01 100644 --- a/flocq/Core/Defs.v +++ b/flocq/Core/Defs.v @@ -18,7 +18,10 @@ COPYING file for more details. *) (** * Basic definitions: float and rounding property *) -Require Import Raux. + +From Coq Require Import ZArith Reals. + +Require Import Raux Zaux. Section Def. diff --git a/flocq/Core/Digits.v b/flocq/Core/Digits.v index a18ff8d6..b491b436 100644 --- a/flocq/Core/Digits.v +++ b/flocq/Core/Digits.v @@ -18,12 +18,12 @@ COPYING file for more details. *) From Coq Require Import Lia ZArith Zquot. +From Coq Require SpecFloat. Require Import Zaux. -Require Import SpecFloatCompat. -Notation digits2_pos := digits2_pos (only parsing). -Notation Zdigits2 := Zdigits2 (only parsing). +Notation digits2_pos := SpecFloat.digits2_pos (only parsing). +Notation Zdigits2 := SpecFloat.Zdigits2 (only parsing). (** Number of bits (radix 2) of a positive integer. @@ -594,12 +594,12 @@ destruct (Zle_or_lt k2' k) as [Hk''|Hk'']. now apply Zdigit_slice_out. rewrite Zdigit_slice by now split. apply Zdigit_slice_out. -zify ; lia. -rewrite Zdigit_slice by (zify ; lia). +lia. +rewrite Zdigit_slice by lia. rewrite (Zdigit_slice n (k1 + k1')) by now split. rewrite Zdigit_slice. now rewrite Zplus_assoc. -zify ; lia. +lia. unfold Zslice. rewrite Z.min_r. now rewrite Zle_bool_false. @@ -821,6 +821,18 @@ Proof. now intros [|n|n]. Qed. +Theorem Zdigits_opp : + forall n, Zdigits (Z.opp n) = Zdigits n. +Proof. +now intros [|n|n]. +Qed. + +Theorem Zdigits_cond_Zopp : + forall s n, Zdigits (cond_Zopp s n) = Zdigits n. +Proof. +now intros [|] [|n|n]. +Qed. + Theorem Zdigits_gt_0 : forall n, n <> Z0 -> (0 < Zdigits n)%Z. Proof. @@ -933,7 +945,7 @@ intros x y Zx Hxy. assert (Hx := Zdigits_correct x). assert (Hy := Zdigits_correct y). apply (Zpower_lt_Zpower beta). -zify ; lia. +lia. Qed. Theorem lt_Zdigits : diff --git a/flocq/Core/FIX.v b/flocq/Core/FIX.v index 779d94cb..e365951a 100644 --- a/flocq/Core/FIX.v +++ b/flocq/Core/FIX.v @@ -19,8 +19,9 @@ COPYING file for more details. (** * Fixed-point format *) -From Coq Require Import Lia. -Require Import Raux Defs Round_pred Generic_fmt Ulp Round_NE. +From Coq Require Import ZArith Reals Lia. + +Require Import Zaux Raux Defs Round_pred Generic_fmt Ulp Round_NE. Section RND_FIX. diff --git a/flocq/Core/FLT.v b/flocq/Core/FLT.v index 7301328d..ee0b5d90 100644 --- a/flocq/Core/FLT.v +++ b/flocq/Core/FLT.v @@ -18,9 +18,10 @@ COPYING file for more details. *) (** * Floating-point format with gradual underflow *) -Require Import Raux Defs Round_pred Generic_fmt Float_prop. -Require Import FLX FIX Ulp Round_NE. -Require Import Psatz. + +From Coq Require Import ZArith Reals Psatz. + +Require Import Zaux Raux Defs Round_pred Generic_fmt Float_prop FLX FIX Ulp Round_NE. Section RND_FLT. @@ -336,7 +337,7 @@ rewrite <- bpow_plus. right; apply f_equal. replace (e - 1 + (1 - prec))%Z with (e - prec)%Z by ring. apply Z.max_l; simpl. -assert (emin+prec-1 < e)%Z; try lia. +cut (emin+prec-1 < e)%Z. lia. apply lt_bpow with beta. apply Rle_lt_trans with (1:=Hx). now apply He. diff --git a/flocq/Core/FLX.v b/flocq/Core/FLX.v index 78bffba5..c1abf639 100644 --- a/flocq/Core/FLX.v +++ b/flocq/Core/FLX.v @@ -18,9 +18,10 @@ COPYING file for more details. *) (** * Floating-point format without underflow *) -Require Import Raux Defs Round_pred Generic_fmt Float_prop. -Require Import FIX Ulp Round_NE. -Require Import Psatz. + +From Coq Require Import ZArith Reals Psatz. + +Require Import Zaux Raux Defs Round_pred Generic_fmt Float_prop FIX Ulp Round_NE. Section RND_FLX. diff --git a/flocq/Core/FTZ.v b/flocq/Core/FTZ.v index d6bae6ea..e2c7ebad 100644 --- a/flocq/Core/FTZ.v +++ b/flocq/Core/FTZ.v @@ -19,9 +19,9 @@ COPYING file for more details. (** * Floating-point format with abrupt underflow *) -From Coq Require Import Lia. -Require Import Raux Defs Round_pred Generic_fmt. -Require Import Float_prop Ulp FLX. +From Coq Require Import ZArith Reals Lia. + +Require Import Zaux Raux Defs Round_pred Generic_fmt Float_prop Ulp FLX. Section RND_FTZ. diff --git a/flocq/Core/Float_prop.v b/flocq/Core/Float_prop.v index a1f48d04..36a2a315 100644 --- a/flocq/Core/Float_prop.v +++ b/flocq/Core/Float_prop.v @@ -19,8 +19,9 @@ COPYING file for more details. (** * Basic properties of floating-point formats: lemmas about mantissa, exponent... *) -From Coq Require Import Lia. -Require Import Raux Defs Digits. +From Coq Require Import ZArith Reals Lia. + +Require Import Zaux Raux Defs Digits. Section Float_prop. @@ -381,10 +382,9 @@ rewrite <-IZR_Zpower. 2: now apply Zle_left. now apply IZR_lt. elim Zlt_not_le with (1 := Hm). simpl. -cut (e' - e < 0)%Z. 2: lia. -clear. -case (e' - e)%Z ; try easy. -intros p _. +assert (H: (e' - e < 0)%Z) by lia. +clear -H. +destruct (e' - e)%Z ; try easy. apply Zabs_pos. Qed. diff --git a/flocq/Core/Generic_fmt.v b/flocq/Core/Generic_fmt.v index af1bf3c1..b3b71b19 100644 --- a/flocq/Core/Generic_fmt.v +++ b/flocq/Core/Generic_fmt.v @@ -19,8 +19,9 @@ COPYING file for more details. (** * What is a real number belonging to a format, and many properties. *) -From Coq Require Import Lia. -Require Import Raux Defs Round_pred Float_prop. +From Coq Require Import ZArith Reals Lia. + +Require Import Zaux Raux Defs Round_pred Float_prop. Section Generic. @@ -427,7 +428,7 @@ rewrite Gx. replace (Ztrunc (scaled_mantissa x)) with Z0. apply F2R_0. cut (Z.abs (Ztrunc (scaled_mantissa x)) < 1)%Z. -clear ; zify ; lia. +clear ; lia. apply lt_IZR. rewrite abs_IZR. now rewrite <- scaled_mantissa_generic. @@ -1804,7 +1805,7 @@ Theorem Znearest_imp : Proof. intros x n Hd. cut (Z.abs (Znearest x - n) < 1)%Z. -clear ; zify ; lia. +clear ; lia. apply lt_IZR. rewrite abs_IZR, minus_IZR. replace (IZR (Znearest x) - IZR n)%R with (- (x - IZR (Znearest x)) + (x - IZR n))%R by ring. diff --git a/flocq/Core/Raux.v b/flocq/Core/Raux.v index 221d84d6..a418bf19 100644 --- a/flocq/Core/Raux.v +++ b/flocq/Core/Raux.v @@ -18,9 +18,10 @@ COPYING file for more details. *) (** * Missing definitions/lemmas *) -Require Import Psatz. -Require Export Reals ZArith. -Require Export Zaux. + +From Coq Require Import Psatz Reals ZArith. + +Require Import Zaux. Section Rmissing. @@ -1317,9 +1318,9 @@ rewrite Ropp_inv_permute with (1 := Zy'). rewrite <- 2!opp_IZR. rewrite <- Zmod_opp_opp. apply H. -clear -Hy. lia. +clear -Hy ; lia. apply H. -clear -Zy Hy. lia. +clear -Zy Hy ; lia. (* *) split. pattern (IZR (x / y)) at 1 ; rewrite <- Rplus_0_r. @@ -1912,7 +1913,7 @@ apply bpow_le. now apply Zlt_le_weak. apply IZR_le. clear -Zm. -zify ; lia. +lia. Qed. Lemma mag_mult : @@ -2040,6 +2041,33 @@ replace (ex - 1 - 1)%Z with (ex - 2)%Z by ring. now apply Rabs_ge; right. Qed. +Theorem mag_plus_ge : + forall x y, + (x <> 0)%R -> + (mag y <= mag x - 2)%Z -> + (mag x - 1 <= mag (x + y))%Z. +Proof. +intros x y Zx. +destruct (Req_dec y 0) as [Zy|Zy]. +{ intros _. + rewrite Zy, Rplus_0_r. + lia. } +rewrite <- (mag_abs x), <- (mag_abs y). +intros Hm. +assert (H: Rabs x <> Rabs y). +{ intros H. + apply Zlt_not_le with (2 := Hm). + rewrite H. + lia. } +apply mag_minus_lb in Hm ; try now apply Rabs_pos_lt. +apply Z.le_trans with (1 := Hm). +apply mag_le_abs. +now apply Rminus_eq_contra. +rewrite <- (Ropp_involutive y). +rewrite Rabs_Ropp. +apply Rabs_triang_inv2. +Qed. + Lemma mag_div : forall x y : R, x <> 0%R -> y <> 0%R -> @@ -2335,8 +2363,7 @@ refine (Rle_not_lt _ _ (lub (/ (INR (S N) + 1))%R _) _). intros Hy. refine (H _ _ Py). apply INR_lt in Hy. - clear -Hy HyN. - lia. + clear -Hy HyN ; lia. now apply Rlt_le, Rinv_0_lt_compat. rewrite S_INR, HN. ring_simplify (IZR (up (/ l)) - 1 + 1)%R. diff --git a/flocq/Core/Round_NE.v b/flocq/Core/Round_NE.v index b7387a62..6a6fb0fb 100644 --- a/flocq/Core/Round_NE.v +++ b/flocq/Core/Round_NE.v @@ -19,8 +19,9 @@ COPYING file for more details. (** * Rounding to nearest, ties to even: existence, unicity... *) -From Coq Require Import Lia. -Require Import Raux Defs Round_pred Generic_fmt Float_prop Ulp. +From Coq Require Import ZArith Reals Lia. + +Require Import Zaux Raux Defs Round_pred Generic_fmt Float_prop Ulp. Notation ZnearestE := (Znearest (fun x => negb (Z.even x))). diff --git a/flocq/Core/Round_pred.v b/flocq/Core/Round_pred.v index b7b6778f..c811aec8 100644 --- a/flocq/Core/Round_pred.v +++ b/flocq/Core/Round_pred.v @@ -18,6 +18,9 @@ COPYING file for more details. *) (** * Roundings: properties and/or functions *) + +From Coq Require Import Reals. + Require Import Raux Defs. Section RND_prop. diff --git a/flocq/Core/Ulp.v b/flocq/Core/Ulp.v index c42b3e65..2459e35b 100644 --- a/flocq/Core/Ulp.v +++ b/flocq/Core/Ulp.v @@ -18,8 +18,10 @@ COPYING file for more details. *) (** * Unit in the Last Place: our definition using fexp and its properties, successor and predecessor *) -Require Import Reals Psatz. -Require Import Raux Defs Round_pred Generic_fmt Float_prop. + +From Coq Require Import ZArith Reals Psatz. + +Require Import Zaux Raux Defs Round_pred Generic_fmt Float_prop. Section Fcore_ulp. @@ -1100,7 +1102,7 @@ exfalso ; lra. intros n Hn H. assert (fexp (mag beta eps) = fexp n). apply valid_exp; try assumption. -assert(mag beta eps-1 < fexp n)%Z;[idtac|lia]. +cut (mag beta eps-1 < fexp n)%Z. lia. apply lt_bpow with beta. apply Rle_lt_trans with (2:=proj2 H). destruct (mag beta eps) as (e,He). @@ -1165,7 +1167,7 @@ lra. intros n Hn H. assert (fexp (mag beta eps) = fexp n). apply valid_exp; try assumption. -assert(mag beta eps-1 < fexp n)%Z;[idtac|lia]. +cut (mag beta eps-1 < fexp n)%Z. lia. apply lt_bpow with beta. apply Rle_lt_trans with (2:=H). destruct (mag beta eps) as (e,He). @@ -1919,7 +1921,7 @@ rewrite ulp_neq_0; trivial. apply f_equal. unfold cexp. apply valid_exp; trivial. -assert (mag beta x -1 < fexp n)%Z;[idtac|lia]. +cut (mag beta x -1 < fexp n)%Z. lia. apply lt_bpow with beta. destruct (mag beta x) as (e,He). simpl. diff --git a/flocq/Core/Zaux.v b/flocq/Core/Zaux.v index 5ca3971f..b14c4e93 100644 --- a/flocq/Core/Zaux.v +++ b/flocq/Core/Zaux.v @@ -18,11 +18,10 @@ COPYING file for more details. *) From Coq Require Import ZArith Lia Zquot. +From Coq Require SpecFloat. -Require Import SpecFloatCompat. - -Notation cond_Zopp := cond_Zopp (only parsing). -Notation iter_pos := iter_pos (only parsing). +Notation cond_Zopp := SpecFloat.cond_Zopp (only parsing). +Notation iter_pos := SpecFloat.iter_pos (only parsing). Section Zmissing. @@ -535,6 +534,39 @@ now apply He. now intros _ _. Qed. +Theorem Zeq_bool_diag : + forall x, Zeq_bool x x = true. +Proof. +intros x. +now apply Zeq_bool_true. +Qed. + +Theorem Zeq_bool_opp : + forall x y, + Zeq_bool (Z.opp x) y = Zeq_bool x (Z.opp y). +Proof. +intros x y. +case Zeq_bool_spec. +- intros <-. + apply eq_sym, Zeq_bool_true. + apply eq_sym, Z.opp_involutive. +- intros H. + case Zeq_bool_spec. + 2: easy. + intros ->. + contradict H. + apply Z.opp_involutive. +Qed. + +Theorem Zeq_bool_opp' : + forall x y, + Zeq_bool (Z.opp x) (Z.opp y) = Zeq_bool x y. +Proof. +intros x y. +rewrite Zeq_bool_opp. +apply f_equal, Z.opp_involutive. +Qed. + End Zeq_bool. Section Zle_bool. @@ -575,6 +607,32 @@ now apply Z.le_lt_trans with y. apply refl_equal. Qed. +Theorem Zle_bool_opp_l : + forall x y, + Zle_bool (Z.opp x) y = Zle_bool (Z.opp y) x. +Proof. +intros x y. +case Zle_bool_spec ; intros Hxy ; + case Zle_bool_spec ; intros Hyx ; try easy ; lia. +Qed. + +Theorem Zle_bool_opp : + forall x y, + Zle_bool (Z.opp x) (Z.opp y) = Zle_bool y x. +Proof. +intros x y. +now rewrite Zle_bool_opp_l, Z.opp_involutive. +Qed. + +Theorem Zle_bool_opp_r : + forall x y, + Zle_bool x (Z.opp y) = Zle_bool y (Z.opp x). +Proof. +intros x y. +rewrite <- (Z.opp_involutive x) at 1. +apply Zle_bool_opp. +Qed. + End Zle_bool. Section Zlt_bool. @@ -635,6 +693,33 @@ now rewrite Zle_bool_false. now rewrite Zle_bool_true. Qed. +Theorem Zlt_bool_opp_l : + forall x y, + Zlt_bool (Z.opp x) y = Zlt_bool (Z.opp y) x. +Proof. +intros x y. +rewrite <- 2! negb_Zle_bool. +apply f_equal, Zle_bool_opp_r. +Qed. + +Theorem Zlt_bool_opp_r : + forall x y, + Zlt_bool x (Z.opp y) = Zlt_bool y (Z.opp x). +Proof. +intros x y. +rewrite <- 2! negb_Zle_bool. +apply f_equal, Zle_bool_opp_l. +Qed. + +Theorem Zlt_bool_opp : + forall x y, + Zlt_bool (Z.opp x) (Z.opp y) = Zlt_bool y x. +Proof. +intros x y. +rewrite <- 2! negb_Zle_bool. +apply f_equal, Zle_bool_opp. +Qed. + End Zlt_bool. Section Zcompare. @@ -717,6 +802,15 @@ now apply Zlt_le_weak. now apply Z.abs_eq. Qed. +Theorem Zeq_bool_cond_Zopp : + forall s m n, + Zeq_bool (cond_Zopp s m) n = Zeq_bool m (cond_Zopp s n). +Proof. +intros [|] m n ; simpl. +apply Zeq_bool_opp. +easy. +Qed. + End cond_Zopp. Section fast_pow_pos. diff --git a/flocq/IEEE754/Binary.v b/flocq/IEEE754/Binary.v index 4516f0a0..335d9b38 100644 --- a/flocq/IEEE754/Binary.v +++ b/flocq/IEEE754/Binary.v @@ -18,8 +18,17 @@ COPYING file for more details. *) (** * IEEE-754 arithmetic *) -Require Import Core Digits Round Bracket Operations Div Sqrt Relative. -Require Import Psatz. + +From Coq Require Import ZArith Reals Psatz SpecFloat. + +Require Import Core Round Bracket Operations Div Sqrt Relative BinarySingleNaN. + +Module BSN := BinarySingleNaN. + +Arguments BSN.B754_zero {prec emax}. +Arguments BSN.B754_infinity {prec emax}. +Arguments BSN.B754_nan {prec emax}. +Arguments BSN.B754_finite {prec emax}. Section AnyRadix. @@ -29,12 +38,106 @@ Inductive full_float := | F754_nan (s : bool) (m : positive) | F754_finite (s : bool) (m : positive) (e : Z). +Definition FF2SF x := + match x with + | F754_zero s => S754_zero s + | F754_infinity s => S754_infinity s + | F754_nan _ _ => S754_nan + | F754_finite s m e => S754_finite s m e + end. + Definition FF2R beta x := match x with | F754_finite s m e => F2R (Float beta (cond_Zopp s (Zpos m)) e) | _ => 0%R end. +Lemma SF2R_FF2SF : + forall beta x, + SF2R beta (FF2SF x) = FF2R beta x. +Proof. +now intros beta [s|s|s m|s m e]. +Qed. + +Definition SF2FF x := + match x with + | S754_zero s => F754_zero s + | S754_infinity s => F754_infinity s + | S754_nan => F754_nan false xH + | S754_finite s m e => F754_finite s m e + end. + +Lemma FF2SF_SF2FF : + forall x, + FF2SF (SF2FF x) = x. +Proof. +now intros [s|s| |s m e]. +Qed. + +Lemma FF2R_SF2FF : + forall beta x, + FF2R beta (SF2FF x) = SF2R beta x. +Proof. +now intros beta [s|s| |s m e]. +Qed. + +Definition is_nan_FF f := + match f with + | F754_nan _ _ => true + | _ => false + end. + +Lemma is_nan_SF2FF : + forall x, + is_nan_FF (SF2FF x) = is_nan_SF x. +Proof. +now intros [s|s| |s m e]. +Qed. + +Lemma is_nan_FF2SF : + forall x, + is_nan_SF (FF2SF x) = is_nan_FF x. +Proof. +now intros [s|s|s m|s m e]. +Qed. + +Lemma SF2FF_FF2SF : + forall x, + is_nan_FF x = false -> + SF2FF (FF2SF x) = x. +Proof. +now intros [s|s|s m|s m e] H. +Qed. + +Definition sign_FF x := + match x with + | F754_nan s _ => s + | F754_zero s => s + | F754_infinity s => s + | F754_finite s _ _ => s + end. + +Definition is_finite_FF f := + match f with + | F754_finite _ _ _ => true + | F754_zero _ => true + | _ => false + end. + +Lemma is_finite_SF2FF : + forall x, + is_finite_FF (SF2FF x) = is_finite_SF x. +Proof. +now intros [| | |]. +Qed. + +Lemma sign_SF2FF : + forall x, + sign_FF (SF2FF x) = sign_SF x. +Proof. +now intros [| | |]. +Qed. + End AnyRadix. Section Binary. @@ -46,22 +149,22 @@ Arguments exist {A} {P}. For instance, binary32 is defined by [prec = 24] and [emax = 128]. *) Variable prec emax : Z. Context (prec_gt_0_ : Prec_gt_0 prec). -Hypothesis Hmax : (prec < emax)%Z. +Context (prec_lt_emax_ : Prec_lt_emax prec emax). -Let emin := (3 - emax - prec)%Z. -Let fexp := FLT_exp emin prec. +Notation emin := (emin prec emax) (only parsing). +Notation fexp := (fexp prec emax) (only parsing). Instance fexp_correct : Valid_exp fexp := FLT_exp_valid emin prec. Instance fexp_monotone : Monotone_exp fexp := FLT_exp_monotone emin prec. -Definition canonical_mantissa m e := - Zeq_bool (fexp (Zpos (digits2_pos m) + e)) e. +Notation canonical_mantissa := (canonical_mantissa prec emax). -Definition bounded m e := - andb (canonical_mantissa m e) (Zle_bool e (emax - prec)). +Notation bounded := (SpecFloat.bounded prec emax). Definition nan_pl pl := Zlt_bool (Zpos (digits2_pos pl)) prec. +Notation valid_binary_SF := (valid_binary prec emax). + Definition valid_binary x := match x with | F754_finite _ m e => bounded m e @@ -69,6 +172,14 @@ Definition valid_binary x := | _ => true end. +Lemma valid_binary_SF2FF : + forall x, + is_nan_SF x = false -> + valid_binary (SF2FF x) = valid_binary_SF x. +Proof. +now intros [sx|sx| |sx mx ex] H. +Qed. + (** Basic type used for representing binary FP numbers. Note that there is exactly one such object per FP datum. *) @@ -80,6 +191,14 @@ Inductive binary_float := | B754_finite (s : bool) (m : positive) (e : Z) : bounded m e = true -> binary_float. +Definition B2BSN (x : binary_float) : BSN.binary_float prec emax := + match x with + | B754_zero s => BSN.B754_zero s + | B754_infinity s => BSN.B754_infinity s + | B754_nan _ _ _ => BSN.B754_nan + | B754_finite s m e H => BSN.B754_finite s m e H + end. + Definition FF2B x := match x as x return valid_binary x = true -> binary_float with | F754_finite s m e => B754_finite s m e @@ -102,6 +221,42 @@ Definition B2R f := | _ => 0%R end. +Definition B2SF (x : binary_float) := + match x with + | B754_finite s m e _ => S754_finite s m e + | B754_infinity s => S754_infinity s + | B754_zero s => S754_zero s + | B754_nan _ _ _ => S754_nan + end. + +Lemma B2SF_B2BSN : + forall x, + BSN.B2SF (B2BSN x) = B2SF x. +Proof. +now intros [sx|sx|sx px Px|sx mx ex Bx]. +Qed. + +Lemma B2SF_FF2B : + forall x Bx, + B2SF (FF2B x Bx) = FF2SF x. +Proof. +now intros [sx|sx|sx px|sx mx ex] Bx. +Qed. + +Lemma B2R_B2BSN : + forall x, BSN.B2R (B2BSN x) = B2R x. +Proof. +intros x. +now destruct x. +Qed. + +Lemma FF2SF_B2FF : + forall x, + FF2SF (B2FF x) = B2SF x. +Proof. +now intros [sx|sx|sx plx|sx mx ex]. +Qed. + Theorem FF2R_B2FF : forall x, FF2R radix2 (B2FF x) = B2R x. @@ -239,6 +394,13 @@ Definition is_finite_strict f := | _ => false end. +Lemma is_finite_strict_B2BSN : + forall x, BSN.is_finite_strict (B2BSN x) = is_finite_strict x. +Proof. +intros x. +now destruct x. +Qed. + Theorem B2R_inj: forall x y : binary_float, is_finite_strict x = true -> @@ -287,14 +449,6 @@ Definition Bsign x := | B754_finite s _ _ _ => s end. -Definition sign_FF x := - match x with - | F754_nan s _ => s - | F754_zero s => s - | F754_infinity s => s - | F754_finite s _ _ => s - end. - Theorem Bsign_FF2B : forall x H, Bsign (FF2B x H) = sign_FF x. @@ -309,12 +463,12 @@ Definition is_finite f := | _ => false end. -Definition is_finite_FF f := - match f with - | F754_finite _ _ _ => true - | F754_zero _ => true - | _ => false - end. +Lemma is_finite_B2BSN : + forall x, BSN.is_finite (B2BSN x) = is_finite x. +Proof. +intros x. +now destruct x. +Qed. Theorem is_finite_FF2B : forall x Hx, @@ -323,11 +477,11 @@ Proof. now intros [| | |]. Qed. -Theorem is_finite_FF_B2FF : +Theorem is_finite_B2FF : forall x, is_finite_FF (B2FF x) = is_finite x. Proof. -now intros [| |? []|]. +now intros [| | |]. Qed. Theorem B2R_Bsign_inj: @@ -356,11 +510,12 @@ Definition is_nan f := | _ => false end. -Definition is_nan_FF f := - match f with - | F754_nan _ _ => true - | _ => false - end. +Lemma is_nan_B2BSN : + forall x, + BSN.is_nan (B2BSN x) = is_nan x. +Proof. +now intros [s|s|s p H|s m e H]. +Qed. Theorem is_nan_FF2B : forall x Hx, @@ -369,7 +524,7 @@ Proof. now intros [| | |]. Qed. -Theorem is_nan_FF_B2FF : +Theorem is_nan_B2FF : forall x, is_nan_FF (B2FF x) = is_nan x. Proof. @@ -383,12 +538,12 @@ Definition build_nan (x : { x | is_nan x = true }) : binary_float. Proof. apply (B754_nan (Bsign (proj1_sig x)) (get_nan_pl (proj1_sig x))). destruct x as [x H]. +assert (K: false = true -> nan_pl 1 = true) by (intros K ; now elim Bool.diff_false_true). simpl. revert H. -assert (H: false = true -> nan_pl 1 = true) by now destruct (nan_pl 1). -destruct x; try apply H. +destruct x as [sx|sx|sx px Px|sx mx ex Bx]; try apply K. intros _. -apply e. +apply Px. Defined. Theorem build_nan_correct : @@ -417,6 +572,103 @@ Proof. easy. Qed. +Definition BSN2B (nan : {x : binary_float | is_nan x = true }) (x : BSN.binary_float prec emax) : binary_float := + match x with + | BSN.B754_nan => build_nan nan + | BSN.B754_zero s => B754_zero s + | BSN.B754_infinity s => B754_infinity s + | BSN.B754_finite s m e H => B754_finite s m e H + end. + +Lemma B2BSN_BSN2B : + forall nan x, + B2BSN (BSN2B nan x) = x. +Proof. +now intros nan [s|s| |s m e H]. +Qed. + +Lemma B2R_BSN2B : + forall nan x, B2R (BSN2B nan x) = BSN.B2R x. +Proof. +now intros nan [s|s| |s m e H]. +Qed. + +Lemma is_finite_BSN2B : + forall nan x, is_finite (BSN2B nan x) = BSN.is_finite x. +Proof. +now intros nan [s|s| |s m e H]. +Qed. + +Lemma is_nan_BSN2B : + forall nan x, is_nan (BSN2B nan x) = BSN.is_nan x. +Proof. +now intros nan [s|s| |s m e H]. +Qed. + +Lemma Bsign_B2BSN : + forall x, is_nan x = false -> BSN.Bsign (B2BSN x) = Bsign x. +Proof. +now intros [s|s| |s m e H]. +Qed. + +Lemma Bsign_BSN2B : + forall nan x, BSN.is_nan x = false -> + Bsign (BSN2B nan x) = BSN.Bsign x. +Proof. +now intros nan [s|s| |s m e H]. +Qed. + +Definition BSN2B' (x : BSN.binary_float prec emax) : BSN.is_nan x = false -> binary_float. +Proof. +destruct x as [sx|sx| |sx mx ex Bx] ; intros H. +exact (B754_zero sx). +exact (B754_infinity sx). +now elim Bool.diff_true_false. +exact (B754_finite sx mx ex Bx). +Defined. + +Lemma B2BSN_BSN2B' : + forall x Nx, + B2BSN (BSN2B' x Nx) = x. +Proof. +now intros [s|s| |s m e H] Nx. +Qed. + +Lemma B2R_BSN2B' : + forall x Nx, + B2R (BSN2B' x Nx) = BSN.B2R x. +Proof. +now intros [sx|sx| |sx mx ex Bx] Nx. +Qed. + +Lemma B2FF_BSN2B' : + forall x Nx, + B2FF (BSN2B' x Nx) = SF2FF (BSN.B2SF x). +Proof. +now intros [sx|sx| |sx mx ex Bx] Nx. +Qed. + +Lemma Bsign_BSN2B' : + forall x Nx, + Bsign (BSN2B' x Nx) = BSN.Bsign x. +Proof. +now intros [sx|sx| |sx mx ex Bx] Nx. +Qed. + +Lemma is_finite_BSN2B' : + forall x Nx, + is_finite (BSN2B' x Nx) = BSN.is_finite x. +Proof. +now intros [sx|sx| |sx mx ex Bx] Nx. +Qed. + +Lemma is_nan_BSN2B' : + forall x Nx, + is_nan (BSN2B' x Nx) = false. +Proof. +now intros [sx|sx| |sx mx ex Bx] Nx. +Qed. + Definition erase (x : binary_float) : binary_float. Proof. destruct x as [s|s|s pl H|s m e H]. @@ -533,85 +785,19 @@ Qed. [Some c] means ordered as per [c]; [None] means unordered. *) Definition Bcompare (f1 f2 : binary_float) : option comparison := - match f1, f2 with - | B754_nan _ _ _,_ | _,B754_nan _ _ _ => None - | B754_infinity s1, B754_infinity s2 => - Some match s1, s2 with - | true, true => Eq - | false, false => Eq - | true, false => Lt - | false, true => Gt - end - | B754_infinity s, _ => Some (if s then Lt else Gt) - | _, B754_infinity s => Some (if s then Gt else Lt) - | B754_finite s _ _ _, B754_zero _ => Some (if s then Lt else Gt) - | B754_zero _, B754_finite s _ _ _ => Some (if s then Gt else Lt) - | B754_zero _, B754_zero _ => Some Eq - | B754_finite s1 m1 e1 _, B754_finite s2 m2 e2 _ => - Some match s1, s2 with - | true, false => Lt - | false, true => Gt - | false, false => - match Z.compare e1 e2 with - | Lt => Lt - | Gt => Gt - | Eq => Pcompare m1 m2 Eq - end - | true, true => - match Z.compare e1 e2 with - | Lt => Gt - | Gt => Lt - | Eq => CompOpp (Pcompare m1 m2 Eq) - end - end - end. + BSN.Bcompare (B2BSN f1) (B2BSN f2). Theorem Bcompare_correct : forall f1 f2, is_finite f1 = true -> is_finite f2 = true -> Bcompare f1 f2 = Some (Rcompare (B2R f1) (B2R f2)). Proof. - Ltac apply_Rcompare := - match goal with - | [ |- Lt = Rcompare _ _ ] => symmetry; apply Rcompare_Lt - | [ |- Eq = Rcompare _ _ ] => symmetry; apply Rcompare_Eq - | [ |- Gt = Rcompare _ _ ] => symmetry; apply Rcompare_Gt - end. - unfold Bcompare; intros f1 f2 H1 H2. - destruct f1, f2; try easy; apply f_equal; clear H1 H2. - now rewrite Rcompare_Eq. - destruct s0 ; apply_Rcompare. - now apply F2R_lt_0. - now apply F2R_gt_0. - destruct s ; apply_Rcompare. - now apply F2R_lt_0. - now apply F2R_gt_0. - simpl. - apply andb_prop in e0; destruct e0; apply (canonical_canonical_mantissa false) in H. - apply andb_prop in e2; destruct e2; apply (canonical_canonical_mantissa false) in H1. - pose proof (Zcompare_spec e e1); unfold canonical, Fexp in H1, H. - assert (forall m1 m2 e1 e2, - let x := (IZR (Zpos m1) * bpow radix2 e1)%R in - let y := (IZR (Zpos m2) * bpow radix2 e2)%R in - (cexp radix2 fexp x < cexp radix2 fexp y)%Z -> (x < y)%R). - { - intros; apply Rnot_le_lt; intro; apply (mag_le radix2) in H5. - apply Zlt_not_le with (1 := H4). - now apply fexp_monotone. - now apply (F2R_gt_0 _ (Float radix2 (Zpos m2) e2)). - } - assert (forall m1 m2 e1 e2, (IZR (- Zpos m1) * bpow radix2 e1 < IZR (Zpos m2) * bpow radix2 e2)%R). - { - intros; apply (Rlt_trans _ 0%R). - now apply (F2R_lt_0 _ (Float radix2 (Zneg m1) e0)). - now apply (F2R_gt_0 _ (Float radix2 (Zpos m2) e2)). - } - unfold F2R, Fnum, Fexp. - destruct s, s0; try (now apply_Rcompare; apply H5); inversion H3; - try (apply_Rcompare; apply H4; rewrite H, H1 in H7; assumption); - try (apply_Rcompare; do 2 rewrite opp_IZR, Ropp_mult_distr_l_reverse; - apply Ropp_lt_contravar; apply H4; rewrite H, H1 in H7; assumption); - rewrite H7, Rcompare_mult_r, Rcompare_IZR by (apply bpow_gt_0); reflexivity. + intros f1 f2 H1 H2. + unfold Bcompare. + rewrite BSN.Bcompare_correct. + now rewrite 2!B2R_B2BSN. + now rewrite is_finite_B2BSN. + now rewrite is_finite_B2BSN. Qed. Theorem Bcompare_swap : @@ -619,12 +805,7 @@ Theorem Bcompare_swap : Bcompare y x = match Bcompare x y with Some c => Some (CompOpp c) | None => None end. Proof. intros. - destruct x as [ ? | [] | ? ? | [] mx ex Bx ]; - destruct y as [ ? | [] | ? ? | [] my ey By ]; simpl; try easy. -- rewrite <- (Zcompare_antisym ex ey). destruct (ex ?= ey)%Z; try easy. - now rewrite (Pcompare_antisym mx my). -- rewrite <- (Zcompare_antisym ex ey). destruct (ex ?= ey)%Z; try easy. - now rewrite Pcompare_antisym. + apply BSN.Bcompare_swap. Qed. Theorem bounded_le_emax_minus_prec : @@ -633,44 +814,7 @@ Theorem bounded_le_emax_minus_prec : (F2R (Float radix2 (Zpos mx) ex) <= bpow radix2 emax - bpow radix2 (emax - prec))%R. Proof. -intros mx ex Hx. -destruct (andb_prop _ _ Hx) as (H1,H2). -generalize (Zeq_bool_eq _ _ H1). clear H1. intro H1. -generalize (Zle_bool_imp_le _ _ H2). clear H2. intro H2. -generalize (mag_F2R_Zdigits radix2 (Zpos mx) ex). -destruct (mag radix2 (F2R (Float radix2 (Zpos mx) ex))) as (e',Ex). -unfold mag_val. -intros H. -elim Ex; [|now apply Rgt_not_eq, F2R_gt_0]; intros _. -rewrite <-F2R_Zabs; simpl; clear Ex; intros Ex. -generalize (Rmult_lt_compat_r (bpow radix2 (-ex)) _ _ (bpow_gt_0 _ _) Ex). -unfold F2R; simpl; rewrite Rmult_assoc, <-!bpow_plus. -rewrite H; [|intro H'; discriminate H']. -rewrite <-Z.add_assoc, Z.add_opp_diag_r, Z.add_0_r, Rmult_1_r. -rewrite <-(IZR_Zpower _ _ (Zdigits_ge_0 _ _)); clear Ex; intro Ex. -generalize (Zlt_le_succ _ _ (lt_IZR _ _ Ex)); clear Ex; intro Ex. -generalize (IZR_le _ _ Ex). -rewrite succ_IZR; clear Ex; intro Ex. -generalize (Rplus_le_compat_r (-1) _ _ Ex); clear Ex; intro Ex. -ring_simplify in Ex; revert Ex. -rewrite (IZR_Zpower _ _ (Zdigits_ge_0 _ _)); intro Ex. -generalize (Rmult_le_compat_r (bpow radix2 ex) _ _ (bpow_ge_0 _ _) Ex). -intro H'; apply (Rle_trans _ _ _ H'). -rewrite Rmult_minus_distr_r, Rmult_1_l, <-bpow_plus. -revert H1; unfold fexp, FLT_exp; intro H1. -generalize (Z.le_max_l (Z.pos (digits2_pos mx) + ex - prec) emin). -rewrite H1; intro H1'. -generalize (proj1 (Z.le_sub_le_add_r _ _ _) H1'). -rewrite Zpos_digits2_pos; clear H1'; intro H1'. -apply (Rle_trans _ _ _ (Rplus_le_compat_r _ _ _ (bpow_le _ _ _ H1'))). -replace emax with (emax - prec - ex + (ex + prec))%Z at 1 by ring. -replace (emax - prec)%Z with (emax - prec - ex + ex)%Z at 2 by ring. -do 2 rewrite (bpow_plus _ (emax - prec - ex)). -rewrite <-Rmult_minus_distr_l. -rewrite <-(Rmult_1_l (_ + _)). -apply Rmult_le_compat_r. -{ apply Rle_0_minus, bpow_le; unfold Prec_gt_0 in prec_gt_0_; lia. } -change 1%R with (bpow radix2 0); apply bpow_le; lia. +now apply BSN.bounded_le_emax_minus_prec. Qed. Theorem bounded_lt_emax : @@ -678,26 +822,7 @@ Theorem bounded_lt_emax : bounded mx ex = true -> (F2R (Float radix2 (Zpos mx) ex) < bpow radix2 emax)%R. Proof. -intros mx ex Hx. -destruct (andb_prop _ _ Hx) as (H1,H2). -generalize (Zeq_bool_eq _ _ H1). clear H1. intro H1. -generalize (Zle_bool_imp_le _ _ H2). clear H2. intro H2. -generalize (mag_F2R_Zdigits radix2 (Zpos mx) ex). -destruct (mag radix2 (F2R (Float radix2 (Zpos mx) ex))) as (e',Ex). -unfold mag_val. -intros H. -apply Rlt_le_trans with (bpow radix2 e'). -change (Zpos mx) with (Z.abs (Zpos mx)). -rewrite F2R_Zabs. -apply Ex. -apply Rgt_not_eq. -now apply F2R_gt_0. -apply bpow_le. -rewrite H. 2: discriminate. -revert H1. clear -H2. -rewrite Zpos_digits2_pos. -unfold fexp, FLT_exp. -intros ; zify ; lia. +now apply bounded_lt_emax. Qed. Theorem bounded_ge_emin : @@ -705,47 +830,25 @@ Theorem bounded_ge_emin : bounded mx ex = true -> (bpow radix2 emin <= F2R (Float radix2 (Zpos mx) ex))%R. Proof. -intros mx ex Hx. -destruct (andb_prop _ _ Hx) as [H1 _]. -apply Zeq_bool_eq in H1. -generalize (mag_F2R_Zdigits radix2 (Zpos mx) ex). -destruct (mag radix2 (F2R (Float radix2 (Zpos mx) ex))) as [e' Ex]. -unfold mag_val. -intros H. -assert (H0 : Zpos mx <> 0%Z) by easy. -rewrite Rabs_pos_eq in Ex by now apply F2R_ge_0. -refine (Rle_trans _ _ _ _ (proj1 (Ex _))). -2: now apply F2R_neq_0. -apply bpow_le. -rewrite H by easy. -revert H1. -rewrite Zpos_digits2_pos. -generalize (Zdigits radix2 (Zpos mx)) (Zdigits_gt_0 radix2 (Zpos mx) H0). -unfold fexp, FLT_exp. -clear -prec_gt_0_. -unfold Prec_gt_0 in prec_gt_0_. -clearbody emin. -intros ; zify ; lia. +now apply bounded_ge_emin. Qed. Theorem abs_B2R_le_emax_minus_prec : forall x, (Rabs (B2R x) <= bpow radix2 emax - bpow radix2 (emax - prec))%R. Proof. -intros [sx|sx|sx plx Hx|sx mx ex Hx] ; simpl ; - [rewrite Rabs_R0 ; apply Rle_0_minus, bpow_le ; - revert prec_gt_0_; unfold Prec_gt_0; lia..|]. -rewrite <- F2R_Zabs, abs_cond_Zopp. -now apply bounded_le_emax_minus_prec. +intros x. +rewrite <- B2R_B2BSN. +now apply abs_B2R_le_emax_minus_prec. Qed. Theorem abs_B2R_lt_emax : forall x, (Rabs (B2R x) < bpow radix2 emax)%R. Proof. -intros [sx|sx|sx plx Hx|sx mx ex Hx] ; simpl ; try ( rewrite Rabs_R0 ; apply bpow_gt_0 ). -rewrite <- F2R_Zabs, abs_cond_Zopp. -now apply bounded_lt_emax. +intros x. +rewrite <- B2R_B2BSN. +now apply abs_B2R_lt_emax. Qed. Theorem abs_B2R_ge_emin : @@ -753,14 +856,10 @@ Theorem abs_B2R_ge_emin : is_finite_strict x = true -> (bpow radix2 emin <= Rabs (B2R x))%R. Proof. -intros [sx|sx|sx plx Hx|sx mx ex Hx] ; simpl ; try discriminate. -intros; case sx; simpl. -- unfold F2R; simpl; rewrite Rabs_mult, <-abs_IZR; simpl. - rewrite Rabs_pos_eq; [|apply bpow_ge_0]. - now apply bounded_ge_emin. -- unfold F2R; simpl; rewrite Rabs_mult, <-abs_IZR; simpl. - rewrite Rabs_pos_eq; [|apply bpow_ge_0]. - now apply bounded_ge_emin. +intros x. +rewrite <- is_finite_strict_B2BSN. +rewrite <- B2R_B2BSN. +now apply abs_B2R_ge_emin. Qed. Theorem bounded_canonical_lt_emax : @@ -769,160 +868,13 @@ Theorem bounded_canonical_lt_emax : (F2R (Float radix2 (Zpos mx) ex) < bpow radix2 emax)%R -> bounded mx ex = true. Proof. -intros mx ex Cx Bx. -apply andb_true_intro. -split. -unfold canonical_mantissa. -unfold canonical, Fexp in Cx. -rewrite Cx at 2. -rewrite Zpos_digits2_pos. -unfold cexp. -rewrite mag_F2R_Zdigits. 2: discriminate. -now apply -> Zeq_is_eq_bool. -apply Zle_bool_true. -unfold canonical, Fexp in Cx. -rewrite Cx. -unfold cexp, fexp, FLT_exp. -destruct (mag radix2 (F2R (Float radix2 (Zpos mx) ex))) as (e',Ex). simpl. -apply Z.max_lub. -cut (e' - 1 < emax)%Z. clear ; lia. -apply lt_bpow with radix2. -apply Rle_lt_trans with (2 := Bx). -change (Zpos mx) with (Z.abs (Zpos mx)). -rewrite F2R_Zabs. -apply Ex. -apply Rgt_not_eq. -now apply F2R_gt_0. -unfold emin. -generalize (prec_gt_0 prec). -clear -Hmax ; lia. +intros mx ex. +now apply bounded_canonical_lt_emax. Qed. (** Truncation *) -Record shr_record := { shr_m : Z ; shr_r : bool ; shr_s : bool }. - -Definition shr_1 mrs := - let '(Build_shr_record m r s) := mrs in - let s := orb r s in - match m with - | Z0 => Build_shr_record Z0 false s - | Zpos xH => Build_shr_record Z0 true s - | Zpos (xO p) => Build_shr_record (Zpos p) false s - | Zpos (xI p) => Build_shr_record (Zpos p) true s - | Zneg xH => Build_shr_record Z0 true s - | Zneg (xO p) => Build_shr_record (Zneg p) false s - | Zneg (xI p) => Build_shr_record (Zneg p) true s - end. - -Definition loc_of_shr_record mrs := - match mrs with - | Build_shr_record _ false false => loc_Exact - | Build_shr_record _ false true => loc_Inexact Lt - | Build_shr_record _ true false => loc_Inexact Eq - | Build_shr_record _ true true => loc_Inexact Gt - end. - -Definition shr_record_of_loc m l := - match l with - | loc_Exact => Build_shr_record m false false - | loc_Inexact Lt => Build_shr_record m false true - | loc_Inexact Eq => Build_shr_record m true false - | loc_Inexact Gt => Build_shr_record m true true - end. - -Theorem shr_m_shr_record_of_loc : - forall m l, - shr_m (shr_record_of_loc m l) = m. -Proof. -now intros m [|[| |]]. -Qed. - -Theorem loc_of_shr_record_of_loc : - forall m l, - loc_of_shr_record (shr_record_of_loc m l) = l. -Proof. -now intros m [|[| |]]. -Qed. - -Definition shr mrs e n := - match n with - | Zpos p => (iter_pos shr_1 p mrs, (e + n)%Z) - | _ => (mrs, e) - end. - -Lemma inbetween_shr_1 : - forall x mrs e, - (0 <= shr_m mrs)%Z -> - inbetween_float radix2 (shr_m mrs) e x (loc_of_shr_record mrs) -> - inbetween_float radix2 (shr_m (shr_1 mrs)) (e + 1) x (loc_of_shr_record (shr_1 mrs)). -Proof. -intros x mrs e Hm Hl. -refine (_ (new_location_even_correct (F2R (Float radix2 (shr_m (shr_1 mrs)) (e + 1))) (bpow radix2 e) 2 _ _ _ x (if shr_r (shr_1 mrs) then 1 else 0) (loc_of_shr_record mrs) _ _)) ; try easy. -2: apply bpow_gt_0. -2: now case (shr_r (shr_1 mrs)) ; split. -change 2%R with (bpow radix2 1). -rewrite <- bpow_plus. -rewrite (Zplus_comm 1), <- (F2R_bpow radix2 (e + 1)). -unfold inbetween_float, F2R. simpl. -rewrite plus_IZR, Rmult_plus_distr_r. -replace (new_location_even 2 (if shr_r (shr_1 mrs) then 1%Z else 0%Z) (loc_of_shr_record mrs)) with (loc_of_shr_record (shr_1 mrs)). -easy. -clear -Hm. -destruct mrs as (m, r, s). -now destruct m as [|[m|m|]|m] ; try (now elim Hm) ; destruct r as [|] ; destruct s as [|]. -rewrite (F2R_change_exp radix2 e). -2: apply Zle_succ. -unfold F2R. simpl. -rewrite <- 2!Rmult_plus_distr_r, <- 2!plus_IZR. -rewrite Zplus_assoc. -replace (shr_m (shr_1 mrs) * 2 ^ (e + 1 - e) + (if shr_r (shr_1 mrs) then 1%Z else 0%Z))%Z with (shr_m mrs). -exact Hl. -ring_simplify (e + 1 - e)%Z. -change (2^1)%Z with 2%Z. -rewrite Zmult_comm. -clear -Hm. -destruct mrs as (m, r, s). -now destruct m as [|[m|m|]|m] ; try (now elim Hm) ; destruct r as [|] ; destruct s as [|]. -Qed. - -Theorem inbetween_shr : - forall x m e l n, - (0 <= m)%Z -> - inbetween_float radix2 m e x l -> - let '(mrs, e') := shr (shr_record_of_loc m l) e n in - inbetween_float radix2 (shr_m mrs) e' x (loc_of_shr_record mrs). -Proof. -intros x m e l n Hm Hl. -destruct n as [|n|n]. -now destruct l as [|[| |]]. -2: now destruct l as [|[| |]]. -unfold shr. -rewrite iter_pos_nat. -rewrite Zpos_eq_Z_of_nat_o_nat_of_P. -induction (nat_of_P n). -simpl. -rewrite Zplus_0_r. -now destruct l as [|[| |]]. -rewrite iter_nat_S. -rewrite inj_S. -unfold Z.succ. -rewrite Zplus_assoc. -revert IHn0. -apply inbetween_shr_1. -clear -Hm. -induction n0. -now destruct l as [|[| |]]. -rewrite iter_nat_S. -revert IHn0. -generalize (iter_nat shr_1 n0 (shr_record_of_loc m l)). -clear. -intros (m, r, s) Hm. -now destruct m as [|[m|m|]|m] ; try (now elim Hm) ; destruct r as [|] ; destruct s as [|]. -Qed. - -Definition shr_fexp m e l := - shr (shr_record_of_loc m l) e (fexp (Zdigits2 m + e) - e). +Notation shr_fexp := (shr_fexp prec emax) (only parsing). Theorem shr_truncate : forall m e l, @@ -930,103 +882,30 @@ Theorem shr_truncate : shr_fexp m e l = let '(m', e', l') := truncate radix2 fexp (m, e, l) in (shr_record_of_loc m' l', e'). Proof. -intros m e l Hm. -case_eq (truncate radix2 fexp (m, e, l)). -intros (m', e') l'. -unfold shr_fexp. -rewrite Zdigits2_Zdigits. -case_eq (fexp (Zdigits radix2 m + e) - e)%Z. -(* *) -intros He. -unfold truncate. -rewrite He. -simpl. -intros H. -now inversion H. -(* *) -intros p Hp. -assert (He: (e <= fexp (Zdigits radix2 m + e))%Z). -clear -Hp ; zify ; lia. -destruct (inbetween_float_ex radix2 m e l) as (x, Hx). -generalize (inbetween_shr x m e l (fexp (Zdigits radix2 m + e) - e) Hm Hx). -assert (Hx0 : (0 <= x)%R). -apply Rle_trans with (F2R (Float radix2 m e)). -now apply F2R_ge_0. -exact (proj1 (inbetween_float_bounds _ _ _ _ _ Hx)). -case_eq (shr (shr_record_of_loc m l) e (fexp (Zdigits radix2 m + e) - e)). -intros mrs e'' H3 H4 H1. -generalize (truncate_correct radix2 _ x m e l Hx0 Hx (or_introl _ He)). -rewrite H1. -intros (H2,_). -rewrite <- Hp, H3. -assert (e'' = e'). -change (snd (mrs, e'') = snd (fst (m',e',l'))). -rewrite <- H1, <- H3. -unfold truncate. -now rewrite Hp. -rewrite H in H4 |- *. -apply (f_equal (fun v => (v, _))). -destruct (inbetween_float_unique _ _ _ _ _ _ _ H2 H4) as (H5, H6). -rewrite H5, H6. -case mrs. -now intros m0 [|] [|]. -(* *) -intros p Hp. -unfold truncate. -rewrite Hp. -simpl. -intros H. -now inversion H. +intros m e l. +now apply shr_truncate. Qed. (** Rounding modes *) -Inductive mode := mode_NE | mode_ZR | mode_DN | mode_UP | mode_NA. - -Definition round_mode m := - match m with - | mode_NE => ZnearestE - | mode_ZR => Ztrunc - | mode_DN => Zfloor - | mode_UP => Zceil - | mode_NA => ZnearestA - end. - -Definition choice_mode m sx mx lx := - match m with - | mode_NE => cond_incr (round_N (negb (Z.even mx)) lx) mx - | mode_ZR => mx - | mode_DN => cond_incr (round_sign_DN sx lx) mx - | mode_UP => cond_incr (round_sign_UP sx lx) mx - | mode_NA => cond_incr (round_N true lx) mx - end. +Definition binary_overflow m s := + SF2FF (binary_overflow prec emax m s). -Global Instance valid_rnd_round_mode : forall m, Valid_rnd (round_mode m). +Lemma eq_binary_overflow_FF2SF : + forall x m s, + FF2SF x = BSN.binary_overflow prec emax m s -> + x = binary_overflow m s. Proof. -destruct m ; unfold round_mode ; auto with typeclass_instances. +intros x m s H. +unfold binary_overflow. +rewrite <- H. +apply eq_sym, SF2FF_FF2SF. +rewrite <- is_nan_FF2SF, H. +apply is_nan_binary_overflow. Qed. -Definition overflow_to_inf m s := - match m with - | mode_NE => true - | mode_NA => true - | mode_ZR => false - | mode_UP => negb s - | mode_DN => s - end. - -Definition binary_overflow m s := - if overflow_to_inf m s then F754_infinity s - else F754_finite s (match (Zpower 2 prec - 1)%Z with Zpos p => p | _ => xH end) (emax - prec). - Definition binary_round_aux mode sx mx ex lx := - let '(mrs', e') := shr_fexp mx ex lx in - let '(mrs'', e'') := shr_fexp (choice_mode mode sx (shr_m mrs') (loc_of_shr_record mrs')) e' loc_Exact in - match shr_m mrs'' with - | Z0 => F754_zero sx - | Zpos m => if Zle_bool e'' (emax - prec) then F754_finite sx m e'' else binary_overflow mode sx - | _ => F754_nan false xH (* dummy *) - end. + SF2FF (binary_round_aux prec emax mode sx mx ex lx). Theorem binary_round_aux_correct' : forall mode x mx ex lx, @@ -1040,174 +919,17 @@ Theorem binary_round_aux_correct' : is_finite_FF z = true /\ sign_FF z = Rlt_bool x 0 else z = binary_overflow mode (Rlt_bool x 0). -Proof with auto with typeclass_instances. -intros m x mx ex lx Px Bx Ex z. -unfold binary_round_aux in z. -revert z. -rewrite shr_truncate. -refine (_ (round_trunc_sign_any_correct' _ _ (round_mode m) (choice_mode m) _ x mx ex lx Bx (or_introl _ Ex))). -rewrite <- cexp_abs in Ex. -refine (_ (truncate_correct_partial' _ fexp _ _ _ _ _ Bx Ex)). -destruct (truncate radix2 fexp (mx, ex, lx)) as ((m1, e1), l1). -rewrite loc_of_shr_record_of_loc, shr_m_shr_record_of_loc. -set (m1' := choice_mode m (Rlt_bool x 0) m1 l1). -intros (H1a,H1b) H1c. -rewrite H1c. -assert (Hm: (m1 <= m1')%Z). -(* . *) -unfold m1', choice_mode, cond_incr. -case m ; - try apply Z.le_refl ; - match goal with |- (m1 <= if ?b then _ else _)%Z => - case b ; [ apply Zle_succ | apply Z.le_refl ] end. -assert (Hr: Rabs (round radix2 fexp (round_mode m) x) = F2R (Float radix2 m1' e1)). -(* . *) -rewrite <- (Z.abs_eq m1'). -replace (Z.abs m1') with (Z.abs (cond_Zopp (Rlt_bool x 0) m1')). -rewrite F2R_Zabs. -now apply f_equal. -apply abs_cond_Zopp. -apply Z.le_trans with (2 := Hm). -apply Zlt_succ_le. -apply gt_0_F2R with radix2 e1. -apply Rle_lt_trans with (1 := Rabs_pos x). -exact (proj2 (inbetween_float_bounds _ _ _ _ _ H1a)). -(* . *) -assert (Br: inbetween_float radix2 m1' e1 (Rabs (round radix2 fexp (round_mode m) x)) loc_Exact). -now apply inbetween_Exact. -destruct m1' as [|m1'|m1']. -(* . m1' = 0 *) -rewrite shr_truncate. 2: apply Z.le_refl. -generalize (truncate_0 radix2 fexp e1 loc_Exact). -destruct (truncate radix2 fexp (Z0, e1, loc_Exact)) as ((m2, e2), l2). -rewrite shr_m_shr_record_of_loc. -intros Hm2. -rewrite Hm2. -repeat split. -rewrite Rlt_bool_true. -repeat split. -apply sym_eq. -case Rlt_bool ; apply F2R_0. -rewrite <- F2R_Zabs, abs_cond_Zopp, F2R_0. -apply bpow_gt_0. -(* . 0 < m1' *) -assert (He: (e1 <= fexp (Zdigits radix2 (Zpos m1') + e1))%Z). -rewrite <- mag_F2R_Zdigits, <- Hr, mag_abs. -2: discriminate. -rewrite H1b. -rewrite cexp_abs. -fold (cexp radix2 fexp (round radix2 fexp (round_mode m) x)). -apply cexp_round_ge... -rewrite H1c. -case (Rlt_bool x 0). -apply Rlt_not_eq. -now apply F2R_lt_0. -apply Rgt_not_eq. -now apply F2R_gt_0. -refine (_ (truncate_correct_partial _ _ _ _ _ _ _ Br He)). -2: now rewrite Hr ; apply F2R_gt_0. -refine (_ (truncate_correct_format radix2 fexp (Zpos m1') e1 _ _ He)). -2: discriminate. -rewrite shr_truncate. 2: easy. -destruct (truncate radix2 fexp (Zpos m1', e1, loc_Exact)) as ((m2, e2), l2). -rewrite shr_m_shr_record_of_loc. -intros (H3,H4) (H2,_). -destruct m2 as [|m2|m2]. -elim Rgt_not_eq with (2 := H3). -rewrite F2R_0. -now apply F2R_gt_0. -rewrite F2R_cond_Zopp, H3, abs_cond_Ropp, <- F2R_abs. -simpl Z.abs. -case_eq (Zle_bool e2 (emax - prec)) ; intros He2. -assert (bounded m2 e2 = true). -apply andb_true_intro. -split. -unfold canonical_mantissa. -apply Zeq_bool_true. -rewrite Zpos_digits2_pos. -rewrite <- mag_F2R_Zdigits. -apply sym_eq. -now rewrite H3 in H4. -discriminate. -exact He2. -apply (conj H). -rewrite Rlt_bool_true. -repeat split. -apply F2R_cond_Zopp. -now apply bounded_lt_emax. -rewrite (Rlt_bool_false _ (bpow radix2 emax)). -refine (conj _ (refl_equal _)). -unfold binary_overflow. -case overflow_to_inf. -apply refl_equal. -unfold valid_binary, bounded. -rewrite Zle_bool_refl. -rewrite Bool.andb_true_r. -apply Zeq_bool_true. -rewrite Zpos_digits2_pos. -replace (Zdigits radix2 (Zpos (match (Zpower 2 prec - 1)%Z with Zpos p => p | _ => xH end))) with prec. -unfold fexp, FLT_exp, emin. -generalize (prec_gt_0 prec). -clear -Hmax ; zify ; lia. -change 2%Z with (radix_val radix2). -case_eq (Zpower radix2 prec - 1)%Z. -simpl Zdigits. -generalize (Zpower_gt_1 radix2 prec (prec_gt_0 prec)). -clear ; lia. -intros p Hp. -apply Zle_antisym. -cut (prec - 1 < Zdigits radix2 (Zpos p))%Z. clear ; lia. -apply Zdigits_gt_Zpower. -simpl Z.abs. rewrite <- Hp. -cut (Zpower radix2 (prec - 1) < Zpower radix2 prec)%Z. clear ; lia. -apply lt_IZR. -rewrite 2!IZR_Zpower. 2: now apply Zlt_le_weak. -apply bpow_lt. -apply Zlt_pred. -now apply Zlt_0_le_0_pred. -apply Zdigits_le_Zpower. -simpl Z.abs. rewrite <- Hp. -apply Zlt_pred. -intros p Hp. -generalize (Zpower_gt_1 radix2 _ (prec_gt_0 prec)). -clear -Hp ; zify ; lia. -apply Rnot_lt_le. -intros Hx. -generalize (refl_equal (bounded m2 e2)). -unfold bounded at 2. -rewrite He2. -rewrite Bool.andb_false_r. -rewrite bounded_canonical_lt_emax with (2 := Hx). -discriminate. -unfold canonical. -now rewrite <- H3. -elim Rgt_not_eq with (2 := H3). -apply Rlt_trans with R0. -now apply F2R_lt_0. -now apply F2R_gt_0. -rewrite <- Hr. -apply generic_format_abs... -apply generic_format_round... -(* . not m1' < 0 *) -elim Rgt_not_eq with (2 := Hr). -apply Rlt_le_trans with R0. -now apply F2R_lt_0. -apply Rabs_pos. -(* *) -now apply Rabs_pos_lt. -(* all the modes are valid *) -clear. case m. -exact inbetween_int_NE_sign. -exact inbetween_int_ZR_sign. -exact inbetween_int_DN_sign. -exact inbetween_int_UP_sign. -exact inbetween_int_NA_sign. -(* *) -apply inbetween_float_bounds in Bx. -apply Zlt_succ_le. -eapply gt_0_F2R. -apply Rle_lt_trans with (2 := proj2 Bx). -apply Rabs_pos. +Proof. +intros mode x mx ex lx Px Bx Ex. +generalize (binary_round_aux_correct' prec emax _ _ mode x mx ex lx Px Bx Ex). +unfold binary_round_aux. +destruct (Rlt_bool (Rabs _) _). +- now destruct BSN.binary_round_aux as [sz|sz| |sz mz ez]. +- intros [_ ->]. + split. + rewrite valid_binary_SF2FF by apply is_nan_binary_overflow. + now apply binary_overflow_correct. + easy. Qed. Theorem binary_round_aux_correct : @@ -1221,239 +943,23 @@ Theorem binary_round_aux_correct : is_finite_FF z = true /\ sign_FF z = Rlt_bool x 0 else z = binary_overflow mode (Rlt_bool x 0). -Proof with auto with typeclass_instances. -intros m x mx ex lx Bx Ex z. -unfold binary_round_aux in z. -revert z. -rewrite shr_truncate. 2: easy. -refine (_ (round_trunc_sign_any_correct _ _ (round_mode m) (choice_mode m) _ x (Zpos mx) ex lx Bx (or_introl _ Ex))). -refine (_ (truncate_correct_partial _ _ _ _ _ _ _ Bx Ex)). -destruct (truncate radix2 fexp (Zpos mx, ex, lx)) as ((m1, e1), l1). -rewrite loc_of_shr_record_of_loc, shr_m_shr_record_of_loc. -set (m1' := choice_mode m (Rlt_bool x 0) m1 l1). -intros (H1a,H1b) H1c. -rewrite H1c. -assert (Hm: (m1 <= m1')%Z). -(* . *) -unfold m1', choice_mode, cond_incr. -case m ; - try apply Z.le_refl ; - match goal with |- (m1 <= if ?b then _ else _)%Z => - case b ; [ apply Zle_succ | apply Z.le_refl ] end. -assert (Hr: Rabs (round radix2 fexp (round_mode m) x) = F2R (Float radix2 m1' e1)). -(* . *) -rewrite <- (Z.abs_eq m1'). -replace (Z.abs m1') with (Z.abs (cond_Zopp (Rlt_bool x 0) m1')). -rewrite F2R_Zabs. -now apply f_equal. -apply abs_cond_Zopp. -apply Z.le_trans with (2 := Hm). -apply Zlt_succ_le. -apply gt_0_F2R with radix2 e1. -apply Rle_lt_trans with (1 := Rabs_pos x). -exact (proj2 (inbetween_float_bounds _ _ _ _ _ H1a)). -(* . *) -assert (Br: inbetween_float radix2 m1' e1 (Rabs (round radix2 fexp (round_mode m) x)) loc_Exact). -now apply inbetween_Exact. -destruct m1' as [|m1'|m1']. -(* . m1' = 0 *) -rewrite shr_truncate. 2: apply Z.le_refl. -generalize (truncate_0 radix2 fexp e1 loc_Exact). -destruct (truncate radix2 fexp (Z0, e1, loc_Exact)) as ((m2, e2), l2). -rewrite shr_m_shr_record_of_loc. -intros Hm2. -rewrite Hm2. -repeat split. -rewrite Rlt_bool_true. -repeat split. -apply sym_eq. -case Rlt_bool ; apply F2R_0. -rewrite <- F2R_Zabs, abs_cond_Zopp, F2R_0. -apply bpow_gt_0. -(* . 0 < m1' *) -assert (He: (e1 <= fexp (Zdigits radix2 (Zpos m1') + e1))%Z). -rewrite <- mag_F2R_Zdigits, <- Hr, mag_abs. -2: discriminate. -rewrite H1b. -rewrite cexp_abs. -fold (cexp radix2 fexp (round radix2 fexp (round_mode m) x)). -apply cexp_round_ge... -rewrite H1c. -case (Rlt_bool x 0). -apply Rlt_not_eq. -now apply F2R_lt_0. -apply Rgt_not_eq. -now apply F2R_gt_0. -refine (_ (truncate_correct_partial _ _ _ _ _ _ _ Br He)). -2: now rewrite Hr ; apply F2R_gt_0. -refine (_ (truncate_correct_format radix2 fexp (Zpos m1') e1 _ _ He)). -2: discriminate. -rewrite shr_truncate. 2: easy. -destruct (truncate radix2 fexp (Zpos m1', e1, loc_Exact)) as ((m2, e2), l2). -rewrite shr_m_shr_record_of_loc. -intros (H3,H4) (H2,_). -destruct m2 as [|m2|m2]. -elim Rgt_not_eq with (2 := H3). -rewrite F2R_0. -now apply F2R_gt_0. -rewrite F2R_cond_Zopp, H3, abs_cond_Ropp, <- F2R_abs. -simpl Z.abs. -case_eq (Zle_bool e2 (emax - prec)) ; intros He2. -assert (bounded m2 e2 = true). -apply andb_true_intro. -split. -unfold canonical_mantissa. -apply Zeq_bool_true. -rewrite Zpos_digits2_pos. -rewrite <- mag_F2R_Zdigits. -apply sym_eq. -now rewrite H3 in H4. -discriminate. -exact He2. -apply (conj H). -rewrite Rlt_bool_true. -repeat split. -apply F2R_cond_Zopp. -now apply bounded_lt_emax. -rewrite (Rlt_bool_false _ (bpow radix2 emax)). -refine (conj _ (refl_equal _)). -unfold binary_overflow. -case overflow_to_inf. -apply refl_equal. -unfold valid_binary, bounded. -rewrite Zle_bool_refl. -rewrite Bool.andb_true_r. -apply Zeq_bool_true. -rewrite Zpos_digits2_pos. -replace (Zdigits radix2 (Zpos (match (Zpower 2 prec - 1)%Z with Zpos p => p | _ => xH end))) with prec. -unfold fexp, FLT_exp, emin. -generalize (prec_gt_0 prec). -clear -Hmax ; zify ; lia. -change 2%Z with (radix_val radix2). -case_eq (Zpower radix2 prec - 1)%Z. -simpl Zdigits. -generalize (Zpower_gt_1 radix2 prec (prec_gt_0 prec)). -clear ; lia. -intros p Hp. -apply Zle_antisym. -cut (prec - 1 < Zdigits radix2 (Zpos p))%Z. clear ; lia. -apply Zdigits_gt_Zpower. -simpl Z.abs. rewrite <- Hp. -cut (Zpower radix2 (prec - 1) < Zpower radix2 prec)%Z. clear ; lia. -apply lt_IZR. -rewrite 2!IZR_Zpower. 2: now apply Zlt_le_weak. -apply bpow_lt. -apply Zlt_pred. -now apply Zlt_0_le_0_pred. -apply Zdigits_le_Zpower. -simpl Z.abs. rewrite <- Hp. -apply Zlt_pred. -intros p Hp. -generalize (Zpower_gt_1 radix2 _ (prec_gt_0 prec)). -clear -Hp ; zify ; lia. -apply Rnot_lt_le. -intros Hx. -generalize (refl_equal (bounded m2 e2)). -unfold bounded at 2. -rewrite He2. -rewrite Bool.andb_false_r. -rewrite bounded_canonical_lt_emax with (2 := Hx). -discriminate. -unfold canonical. -now rewrite <- H3. -elim Rgt_not_eq with (2 := H3). -apply Rlt_trans with R0. -now apply F2R_lt_0. -now apply F2R_gt_0. -rewrite <- Hr. -apply generic_format_abs... -apply generic_format_round... -(* . not m1' < 0 *) -elim Rgt_not_eq with (2 := Hr). -apply Rlt_le_trans with R0. -now apply F2R_lt_0. -apply Rabs_pos. -(* *) -apply Rlt_le_trans with (2 := proj1 (inbetween_float_bounds _ _ _ _ _ Bx)). -now apply F2R_gt_0. -(* all the modes are valid *) -clear. case m. -exact inbetween_int_NE_sign. -exact inbetween_int_ZR_sign. -exact inbetween_int_DN_sign. -exact inbetween_int_UP_sign. -exact inbetween_int_NA_sign. +Proof. +intros mode x mx ex lx Bx Ex. +generalize (binary_round_aux_correct prec emax _ _ mode x mx ex lx Bx Ex). +unfold binary_round_aux. +destruct (Rlt_bool (Rabs _) _). +- now destruct BSN.binary_round_aux as [sz|sz| |sz mz ez]. +- intros [_ ->]. + split. + rewrite valid_binary_SF2FF by apply is_nan_binary_overflow. + now apply binary_overflow_correct. + easy. Qed. (** Multiplication *) -Lemma Bmult_correct_aux : - forall m sx mx ex (Hx : bounded mx ex = true) sy my ey (Hy : bounded my ey = true), - let x := F2R (Float radix2 (cond_Zopp sx (Zpos mx)) ex) in - let y := F2R (Float radix2 (cond_Zopp sy (Zpos my)) ey) in - let z := binary_round_aux m (xorb sx sy) (Zpos (mx * my)) (ex + ey) loc_Exact in - valid_binary z = true /\ - if Rlt_bool (Rabs (round radix2 fexp (round_mode m) (x * y))) (bpow radix2 emax) then - FF2R radix2 z = round radix2 fexp (round_mode m) (x * y) /\ - is_finite_FF z = true /\ sign_FF z = xorb sx sy - else - z = binary_overflow m (xorb sx sy). -Proof. -intros m sx mx ex Hx sy my ey Hy x y. -unfold x, y. -rewrite <- F2R_mult. -simpl. -replace (xorb sx sy) with (Rlt_bool (F2R (Float radix2 (cond_Zopp sx (Zpos mx) * cond_Zopp sy (Zpos my)) (ex + ey))) 0). -apply binary_round_aux_correct. -constructor. -rewrite <- F2R_abs. -apply F2R_eq. -rewrite Zabs_Zmult. -now rewrite 2!abs_cond_Zopp. -(* *) -change (Zpos (mx * my)) with (Zpos mx * Zpos my)%Z. -assert (forall m e, bounded m e = true -> fexp (Zdigits radix2 (Zpos m) + e) = e)%Z. -clear. intros m e Hb. -destruct (andb_prop _ _ Hb) as (H,_). -apply Zeq_bool_eq. -now rewrite <- Zpos_digits2_pos. -generalize (H _ _ Hx) (H _ _ Hy). -clear x y sx sy Hx Hy H. -unfold fexp, FLT_exp. -refine (_ (Zdigits_mult_ge radix2 (Zpos mx) (Zpos my) _ _)) ; try discriminate. -refine (_ (Zdigits_gt_0 radix2 (Zpos mx) _) (Zdigits_gt_0 radix2 (Zpos my) _)) ; try discriminate. -generalize (Zdigits radix2 (Zpos mx)) (Zdigits radix2 (Zpos my)) (Zdigits radix2 (Zpos mx * Zpos my)). -clear -Hmax. -unfold emin. -intros dx dy dxy Hx Hy Hxy. -zify ; intros ; subst. -lia. -(* *) -case sx ; case sy. -apply Rlt_bool_false. -now apply F2R_ge_0. -apply Rlt_bool_true. -now apply F2R_lt_0. -apply Rlt_bool_true. -now apply F2R_lt_0. -apply Rlt_bool_false. -now apply F2R_ge_0. -Qed. - Definition Bmult mult_nan m x y := - match x, y with - | B754_nan _ _ _, _ | _, B754_nan _ _ _ => build_nan (mult_nan x y) - | B754_infinity sx, B754_infinity sy => B754_infinity (xorb sx sy) - | B754_infinity sx, B754_finite sy _ _ _ => B754_infinity (xorb sx sy) - | B754_finite sx _ _ _, B754_infinity sy => B754_infinity (xorb sx sy) - | B754_infinity _, B754_zero _ => build_nan (mult_nan x y) - | B754_zero _, B754_infinity _ => build_nan (mult_nan x y) - | B754_finite sx _ _ _, B754_zero sy => B754_zero (xorb sx sy) - | B754_zero sx, B754_finite sy _ _ _ => B754_zero (xorb sx sy) - | B754_zero sx, B754_zero sy => B754_zero (xorb sx sy) - | B754_finite sx mx ex Hx, B754_finite sy my ey Hy => - FF2B _ (proj1 (Bmult_correct_aux m sx mx ex Hx sy my ey Hy)) - end. + BSN2B (mult_nan x y) (Bmult m (B2BSN x) (B2BSN y)). Theorem Bmult_correct : forall mult_nan m x y, @@ -1465,106 +971,39 @@ Theorem Bmult_correct : else B2FF (Bmult mult_nan m x y) = binary_overflow m (xorb (Bsign x) (Bsign y)). Proof. -intros mult_nan m [sx|sx|sx plx Hplx|sx mx ex Hx] [sy|sy|sy ply Hply|sy my ey Hy] ; - try ( rewrite ?Rmult_0_r, ?Rmult_0_l, round_0, Rabs_R0, Rlt_bool_true ; [ simpl ; try easy ; now rewrite B2R_build_nan, is_finite_build_nan, is_nan_build_nan | apply bpow_gt_0 | now auto with typeclass_instances ] ). -simpl. -case Bmult_correct_aux. -intros H1. -case Rlt_bool. -intros (H2, (H3, H4)). -split. -now rewrite B2R_FF2B. -split. -now rewrite is_finite_FF2B. -rewrite Bsign_FF2B. auto. -intros H2. -now rewrite B2FF_FF2B. +intros mult_nan mode x y. +generalize (Bmult_correct prec emax _ _ mode (B2BSN x) (B2BSN y)). +replace (BSN.Bmult _ _ _) with (B2BSN (Bmult mult_nan mode x y)) by apply B2BSN_BSN2B. +intros H. +destruct x as [sx|sx|sx plx Hplx|sx mx ex Hx] ; + destruct y as [sy|sy|sy ply Hply|sy my ey Hy] ; + try ( rewrite ?Rmult_0_r, ?Rmult_0_l, round_0, Rabs_R0, Rlt_bool_true ; [ try easy | apply bpow_gt_0 | now auto with typeclass_instances ]). +revert H. +rewrite 2!B2R_B2BSN. +destruct Rlt_bool. +- now destruct Bmult. +- intros H. + apply eq_binary_overflow_FF2SF. + now rewrite FF2SF_B2FF, <- B2SF_B2BSN. Qed. (** Normalization and rounding *) -Definition shl_align mx ex ex' := - match (ex' - ex)%Z with - | Zneg d => (shift_pos d mx, ex') - | _ => (mx, ex) - end. - -Theorem shl_align_correct : - forall mx ex ex', - let (mx', ex'') := shl_align mx ex ex' in - F2R (Float radix2 (Zpos mx) ex) = F2R (Float radix2 (Zpos mx') ex'') /\ - (ex'' <= ex')%Z. -Proof. -intros mx ex ex'. -unfold shl_align. -case_eq (ex' - ex)%Z. -(* d = 0 *) -intros H. -repeat split. -rewrite Zminus_eq with (1 := H). -apply Z.le_refl. -(* d > 0 *) -intros d Hd. -repeat split. -replace ex' with (ex' - ex + ex)%Z by ring. -rewrite Hd. -pattern ex at 1 ; rewrite <- Zplus_0_l. -now apply Zplus_le_compat_r. -(* d < 0 *) -intros d Hd. -rewrite shift_pos_correct, Zmult_comm. -change (Zpower_pos 2 d) with (Zpower radix2 (Zpos d)). -change (Zpos d) with (Z.opp (Zneg d)). -rewrite <- Hd. -split. -replace (- (ex' - ex))%Z with (ex - ex')%Z by ring. -apply F2R_change_exp. -apply Zle_0_minus_le. -replace (ex - ex')%Z with (- (ex' - ex))%Z by ring. -now rewrite Hd. -apply Z.le_refl. -Qed. - -Theorem snd_shl_align : - forall mx ex ex', - (ex' <= ex)%Z -> - snd (shl_align mx ex ex') = ex'. -Proof. -intros mx ex ex' He. -unfold shl_align. -case_eq (ex' - ex)%Z ; simpl. -intros H. -now rewrite Zminus_eq with (1 := H). -intros p. -clear -He ; zify ; lia. -intros. -apply refl_equal. -Qed. - Definition shl_align_fexp mx ex := shl_align mx ex (fexp (Zpos (digits2_pos mx) + ex)). -Theorem shl_align_fexp_correct : +Lemma shl_align_fexp_correct : forall mx ex, let (mx', ex') := shl_align_fexp mx ex in F2R (Float radix2 (Zpos mx) ex) = F2R (Float radix2 (Zpos mx') ex') /\ (ex' <= fexp (Zdigits radix2 (Zpos mx') + ex'))%Z. Proof. intros mx ex. -unfold shl_align_fexp. -generalize (shl_align_correct mx ex (fexp (Zpos (digits2_pos mx) + ex))). -rewrite Zpos_digits2_pos. -case shl_align. -intros mx' ex' (H1, H2). -split. -exact H1. -rewrite <- mag_F2R_Zdigits. 2: easy. -rewrite <- H1. -now rewrite mag_F2R_Zdigits. +apply shl_align_fexp_correct. Qed. Definition binary_round m sx mx ex := - let '(mz, ez) := shl_align_fexp mx ex in binary_round_aux m sx (Zpos mz) ez loc_Exact. + SF2FF (binary_round prec emax m sx mx ex). Theorem binary_round_correct : forall m sx mx ex, @@ -1578,32 +1017,21 @@ Theorem binary_round_correct : else z = binary_overflow m sx. Proof. -intros m sx mx ex. +intros mode sx mx ex. +generalize (binary_round_correct prec emax _ _ mode sx mx ex). +simpl. unfold binary_round. -generalize (shl_align_fexp_correct mx ex). -destruct (shl_align_fexp mx ex) as (mz, ez). -intros (H1, H2). -set (x := F2R (Float radix2 (cond_Zopp sx (Zpos mx)) ex)). -replace sx with (Rlt_bool x 0). -apply binary_round_aux_correct. -constructor. -unfold x. -now rewrite <- F2R_Zabs, abs_cond_Zopp. -exact H2. -unfold x. -case sx. -apply Rlt_bool_true. -now apply F2R_lt_0. -apply Rlt_bool_false. -now apply F2R_ge_0. +destruct Rlt_bool. +- now destruct BSN.binary_round. +- intros [H1 ->]. + split. + rewrite valid_binary_SF2FF by apply is_nan_binary_overflow. + now apply binary_overflow_correct. + easy. Qed. Definition binary_normalize mode m e szero := - match m with - | Z0 => B754_zero szero - | Zpos m => FF2B _ (proj1 (binary_round_correct mode false m e)) - | Zneg m => FF2B _ (proj1 (binary_round_correct mode true m e)) - end. + BSN2B' _ (is_nan_binary_normalize prec emax _ _ mode m e szero). Theorem binary_normalize_correct : forall m mx ex szero, @@ -1618,72 +1046,22 @@ Theorem binary_normalize_correct : end else B2FF (binary_normalize m mx ex szero) = binary_overflow m (Rlt_bool (F2R (Float radix2 mx ex)) 0). -Proof with auto with typeclass_instances. -intros m mx ez szero. -destruct mx as [|mz|mz] ; simpl. -rewrite F2R_0, round_0, Rabs_R0, Rlt_bool_true... -split... split... -rewrite Rcompare_Eq... -apply bpow_gt_0. -(* . mz > 0 *) -generalize (binary_round_correct m false mz ez). -simpl. -case Rlt_bool_spec. -intros _ (Vz, (Rz, (Rz', Rz''))). -split. -now rewrite B2R_FF2B. -split. -now rewrite is_finite_FF2B. -rewrite Bsign_FF2B, Rz''. -rewrite Rcompare_Gt... -apply F2R_gt_0. -simpl. zify; lia. -intros Hz' (Vz, Rz). -rewrite B2FF_FF2B, Rz. -apply f_equal. -apply sym_eq. -apply Rlt_bool_false. -now apply F2R_ge_0. -(* . mz < 0 *) -generalize (binary_round_correct m true mz ez). +Proof. +intros mode mx ex szero. +generalize (binary_normalize_correct prec emax _ _ mode mx ex szero). +replace (BSN.binary_normalize _ _ _ _ _ _ _ _) with (B2BSN (binary_normalize mode mx ex szero)) by apply B2BSN_BSN2B'. simpl. -case Rlt_bool_spec. -intros _ (Vz, (Rz, (Rz', Rz''))). -split. -now rewrite B2R_FF2B. -split. -now rewrite is_finite_FF2B. -rewrite Bsign_FF2B, Rz''. -rewrite Rcompare_Lt... -apply F2R_lt_0. -simpl. zify; lia. -intros Hz' (Vz, Rz). -rewrite B2FF_FF2B, Rz. -apply f_equal. -apply sym_eq. -apply Rlt_bool_true. -now apply F2R_lt_0. +destruct Rlt_bool. +- now destruct binary_normalize. +- intros H. + apply eq_binary_overflow_FF2SF. + now rewrite FF2SF_B2FF, <- B2SF_B2BSN. Qed. (** Addition *) Definition Bplus plus_nan m x y := - match x, y with - | B754_nan _ _ _, _ | _, B754_nan _ _ _ => build_nan (plus_nan x y) - | B754_infinity sx, B754_infinity sy => - if Bool.eqb sx sy then x else build_nan (plus_nan x y) - | B754_infinity _, _ => x - | _, B754_infinity _ => y - | B754_zero sx, B754_zero sy => - if Bool.eqb sx sy then x else - match m with mode_DN => B754_zero true | _ => B754_zero false end - | B754_zero _, _ => y - | _, B754_zero _ => x - | B754_finite sx mx ex Hx, B754_finite sy my ey Hy => - let ez := Z.min ex ey in - binary_normalize m (Zplus (cond_Zopp sx (Zpos (fst (shl_align mx ex ez)))) (cond_Zopp sy (Zpos (fst (shl_align my ey ez))))) - ez (match m with mode_DN => true | _ => false end) - end. + BSN2B (plus_nan x y) (Bplus m (B2BSN x) (B2BSN y)). Theorem Bplus_correct : forall plus_nan m x y, @@ -1702,170 +1080,25 @@ Theorem Bplus_correct : else (B2FF (Bplus plus_nan m x y) = binary_overflow m (Bsign x) /\ Bsign x = Bsign y). Proof with auto with typeclass_instances. -intros plus_nan m [sx|sx| |sx mx ex Hx] [sy|sy| |sy my ey Hy] Fx Fy ; try easy. -(* *) -rewrite Rplus_0_r, round_0, Rabs_R0, Rlt_bool_true... -simpl. -rewrite Rcompare_Eq by auto. -destruct sx, sy; try easy; now case m. -apply bpow_gt_0. -(* *) -rewrite Rplus_0_l, round_generic, Rlt_bool_true... -split... split... -simpl. unfold F2R. -erewrite <- Rmult_0_l, Rcompare_mult_r. -rewrite Rcompare_IZR with (y:=0%Z). -destruct sy... -apply bpow_gt_0. -apply abs_B2R_lt_emax. -apply generic_format_B2R. -(* *) -rewrite Rplus_0_r, round_generic, Rlt_bool_true... -split... split... -simpl. unfold F2R. -erewrite <- Rmult_0_l, Rcompare_mult_r. -rewrite Rcompare_IZR with (y:=0%Z). -destruct sx... -apply bpow_gt_0. -apply abs_B2R_lt_emax. -apply generic_format_B2R. -(* *) -clear Fx Fy. -simpl. -set (szero := match m with mode_DN => true | _ => false end). -set (ez := Z.min ex ey). -set (mz := (cond_Zopp sx (Zpos (fst (shl_align mx ex ez))) + cond_Zopp sy (Zpos (fst (shl_align my ey ez))))%Z). -assert (Hp: (F2R (Float radix2 (cond_Zopp sx (Zpos mx)) ex) + - F2R (Float radix2 (cond_Zopp sy (Zpos my)) ey))%R = F2R (Float radix2 mz ez)). -rewrite 2!F2R_cond_Zopp. -generalize (shl_align_correct mx ex ez). -generalize (shl_align_correct my ey ez). -generalize (snd_shl_align mx ex ez (Z.le_min_l ex ey)). -generalize (snd_shl_align my ey ez (Z.le_min_r ex ey)). -destruct (shl_align mx ex ez) as (mx', ex'). -destruct (shl_align my ey ez) as (my', ey'). -simpl. -intros H1 H2. -rewrite H1, H2. -clear H1 H2. -intros (H1, _) (H2, _). -rewrite H1, H2. -clear H1 H2. -rewrite <- 2!F2R_cond_Zopp. -unfold F2R. simpl. -now rewrite <- Rmult_plus_distr_r, <- plus_IZR. -rewrite Hp. -assert (Sz: (bpow radix2 emax <= Rabs (round radix2 fexp (round_mode m) (F2R (Float radix2 mz ez))))%R -> sx = Rlt_bool (F2R (Float radix2 mz ez)) 0 /\ sx = sy). -(* . *) -rewrite <- Hp. -intros Bz. -destruct (Bool.bool_dec sx sy) as [Hs|Hs]. -(* .. *) -refine (conj _ Hs). -rewrite Hs. -apply sym_eq. -case sy. -apply Rlt_bool_true. -rewrite <- (Rplus_0_r 0). -apply Rplus_lt_compat. -now apply F2R_lt_0. -now apply F2R_lt_0. -apply Rlt_bool_false. -rewrite <- (Rplus_0_r 0). -apply Rplus_le_compat. -now apply F2R_ge_0. -now apply F2R_ge_0. -(* .. *) -elim Rle_not_lt with (1 := Bz). -generalize (bounded_lt_emax _ _ Hx) (bounded_lt_emax _ _ Hy) (andb_prop _ _ Hx) (andb_prop _ _ Hy). -intros Bx By (Hx',_) (Hy',_). -generalize (canonical_canonical_mantissa sx _ _ Hx') (canonical_canonical_mantissa sy _ _ Hy'). -clear -Bx By Hs prec_gt_0_. -intros Cx Cy. -destruct sx. -(* ... *) -destruct sy. -now elim Hs. -clear Hs. -apply Rabs_lt. -split. -apply Rlt_le_trans with (F2R (Float radix2 (cond_Zopp true (Zpos mx)) ex)). -rewrite F2R_Zopp. -now apply Ropp_lt_contravar. -apply round_ge_generic... -now apply generic_format_canonical. -pattern (F2R (Float radix2 (cond_Zopp true (Zpos mx)) ex)) at 1 ; rewrite <- Rplus_0_r. -apply Rplus_le_compat_l. -now apply F2R_ge_0. -apply Rle_lt_trans with (2 := By). -apply round_le_generic... -now apply generic_format_canonical. -rewrite <- (Rplus_0_l (F2R (Float radix2 (Zpos my) ey))). -apply Rplus_le_compat_r. -now apply F2R_le_0. -(* ... *) -destruct sy. -2: now elim Hs. -clear Hs. -apply Rabs_lt. -split. -apply Rlt_le_trans with (F2R (Float radix2 (cond_Zopp true (Zpos my)) ey)). -rewrite F2R_Zopp. -now apply Ropp_lt_contravar. -apply round_ge_generic... -now apply generic_format_canonical. -pattern (F2R (Float radix2 (cond_Zopp true (Zpos my)) ey)) at 1 ; rewrite <- Rplus_0_l. -apply Rplus_le_compat_r. -now apply F2R_ge_0. -apply Rle_lt_trans with (2 := Bx). -apply round_le_generic... -now apply generic_format_canonical. -rewrite <- (Rplus_0_r (F2R (Float radix2 (Zpos mx) ex))). -apply Rplus_le_compat_l. -now apply F2R_le_0. -(* . *) -generalize (binary_normalize_correct m mz ez szero). -case Rlt_bool_spec. -split; try easy. split; try easy. -destruct (Rcompare_spec (F2R (beta:=radix2) {| Fnum := mz; Fexp := ez |}) 0); try easy. -rewrite H1 in Hp. -apply Rplus_opp_r_uniq in Hp. -rewrite <- F2R_Zopp in Hp. -eapply canonical_unique in Hp. -inversion Hp. destruct sy, sx, m; try discriminate H3; easy. -apply canonical_canonical_mantissa. -apply Bool.andb_true_iff in Hy. easy. -replace (-cond_Zopp sx (Z.pos mx))%Z with (cond_Zopp (negb sx) (Z.pos mx)) - by (destruct sx; auto). -apply canonical_canonical_mantissa. -apply Bool.andb_true_iff in Hx. easy. -intros Hz' Vz. -specialize (Sz Hz'). -split. -rewrite Vz. -now apply f_equal. -apply Sz. +intros plus_nan mode x y Fx Fy. +rewrite <- is_finite_B2BSN in Fx, Fy. +generalize (Bplus_correct prec emax _ _ mode _ _ Fx Fy). +replace (BSN.Bplus _ _ _) with (B2BSN (Bplus plus_nan mode x y)) by apply B2BSN_BSN2B. +rewrite 2!B2R_B2BSN. +rewrite (Bsign_B2BSN x) by (clear -Fx ; now destruct x). +rewrite (Bsign_B2BSN y) by (clear -Fy ; now destruct y). +destruct Rlt_bool. +- now destruct Bplus. +- intros [H1 H2]. + refine (conj _ H2). + apply eq_binary_overflow_FF2SF. + now rewrite FF2SF_B2FF, <- B2SF_B2BSN. Qed. (** Subtraction *) Definition Bminus minus_nan m x y := - match x, y with - | B754_nan _ _ _, _ | _, B754_nan _ _ _ => build_nan (minus_nan x y) - | B754_infinity sx, B754_infinity sy => - if Bool.eqb sx (negb sy) then x else build_nan (minus_nan x y) - | B754_infinity _, _ => x - | _, B754_infinity sy => B754_infinity (negb sy) - | B754_zero sx, B754_zero sy => - if Bool.eqb sx (negb sy) then x else - match m with mode_DN => B754_zero true | _ => B754_zero false end - | B754_zero _, B754_finite sy my ey Hy => B754_finite (negb sy) my ey Hy - | _, B754_zero _ => x - | B754_finite sx mx ex Hx, B754_finite sy my ey Hy => - let ez := Z.min ex ey in - binary_normalize m (Zminus (cond_Zopp sx (Zpos (fst (shl_align mx ex ez)))) (cond_Zopp sy (Zpos (fst (shl_align my ey ez))))) - ez (match m with mode_DN => true | _ => false end) - end. + BSN2B (minus_nan x y) (Bminus m (B2BSN x) (B2BSN y)). Theorem Bminus_correct : forall minus_nan m x y, @@ -1884,77 +1117,35 @@ Theorem Bminus_correct : else (B2FF (Bminus minus_nan m x y) = binary_overflow m (Bsign x) /\ Bsign x = negb (Bsign y)). Proof with auto with typeclass_instances. -intros minus_nan m x y Fx Fy. -generalize (Bplus_correct minus_nan m x (Bopp (fun n => minus_nan n (B754_zero false)) y) Fx). -rewrite is_finite_Bopp, B2R_Bopp. -intros H. -specialize (H Fy). -replace (negb (Bsign y)) with (Bsign (Bopp (fun n => minus_nan n (B754_zero false)) y)). -destruct x as [| | |sx mx ex Hx], y as [| | |sy my ey Hy] ; try easy. -unfold Bminus, Zminus. -now rewrite <- cond_Zopp_negb. -now destruct y as [ | | | ]. +intros minus_nan mode x y Fx Fy. +rewrite <- is_finite_B2BSN in Fx, Fy. +generalize (Bminus_correct prec emax _ _ mode _ _ Fx Fy). +replace (BSN.Bminus _ _ _) with (B2BSN (Bminus minus_nan mode x y)) by apply B2BSN_BSN2B. +rewrite 2!B2R_B2BSN. +rewrite (Bsign_B2BSN x) by (clear -Fx ; now destruct x). +rewrite (Bsign_B2BSN y) by (clear -Fy ; now destruct y). +destruct Rlt_bool. +- now destruct Bminus. +- intros [H1 H2]. + refine (conj _ H2). + apply eq_binary_overflow_FF2SF. + now rewrite FF2SF_B2FF, <- B2SF_B2BSN. Qed. (** Fused Multiply-Add *) -Definition Bfma_szero m (x y z: binary_float) : bool := - let s_xy := xorb (Bsign x) (Bsign y) in (* sign of product x*y *) - if Bool.eqb s_xy (Bsign z) then s_xy - else match m with mode_DN => true | _ => false end. +Definition Bfma_szero m (x y z : binary_float) := + Bfma_szero prec emax m (B2BSN x) (B2BSN y) (B2BSN z). Definition Bfma fma_nan m (x y z: binary_float) := - match x, y with - | B754_nan _ _ _, _ | _, B754_nan _ _ _ - | B754_infinity _, B754_zero _ - | B754_zero _, B754_infinity _ => - (* Multiplication produces NaN *) - build_nan (fma_nan x y z) - | B754_infinity sx, B754_infinity sy - | B754_infinity sx, B754_finite sy _ _ _ - | B754_finite sx _ _ _, B754_infinity sy => - let s := xorb sx sy in - (* Multiplication produces infinity with sign [s] *) - match z with - | B754_nan _ _ _ => build_nan (fma_nan x y z) - | B754_infinity sz => - if Bool.eqb s sz then z else build_nan (fma_nan x y z) - | _ => B754_infinity s - end - | B754_finite sx _ _ _, B754_zero sy - | B754_zero sx, B754_finite sy _ _ _ - | B754_zero sx, B754_zero sy => - (* Multiplication produces zero *) - match z with - | B754_nan _ _ _ => build_nan (fma_nan x y z) - | B754_zero _ => B754_zero (Bfma_szero m x y z) - | _ => z - end - | B754_finite sx mx ex _, B754_finite sy my ey _ => - (* Multiplication produces a finite, non-zero result *) - match z with - | B754_nan _ _ _ => build_nan (fma_nan x y z) - | B754_infinity sz => z - | B754_zero _ => - let X := Float radix2 (cond_Zopp sx (Zpos mx)) ex in - let Y := Float radix2 (cond_Zopp sy (Zpos my)) ey in - let '(Float _ mr er) := Fmult X Y in - binary_normalize m mr er (Bfma_szero m x y z) - | B754_finite sz mz ez _ => - let X := Float radix2 (cond_Zopp sx (Zpos mx)) ex in - let Y := Float radix2 (cond_Zopp sy (Zpos my)) ey in - let Z := Float radix2 (cond_Zopp sz (Zpos mz)) ez in - let '(Float _ mr er) := Fplus (Fmult X Y) Z in - binary_normalize m mr er (Bfma_szero m x y z) - end - end. + BSN2B (fma_nan x y z) (Bfma m (B2BSN x) (B2BSN y) (B2BSN z)). Theorem Bfma_correct: forall fma_nan m x y z, - let res := (B2R x * B2R y + B2R z)%R in is_finite x = true -> is_finite y = true -> is_finite z = true -> + let res := (B2R x * B2R y + B2R z)%R in if Rlt_bool (Rabs (round radix2 fexp (round_mode m) res)) (bpow radix2 emax) then B2R (Bfma fma_nan m x y z) = round radix2 fexp (round_mode m) res /\ is_finite (Bfma fma_nan m x y z) = true /\ @@ -1967,179 +1158,23 @@ Theorem Bfma_correct: else B2FF (Bfma fma_nan m x y z) = binary_overflow m (Rlt_bool res 0). Proof. - intros. pattern (Bfma fma_nan m x y z). - match goal with |- ?p ?x => set (PROP := p) end. - set (szero := Bfma_szero m x y z). - assert (BINORM: forall mr er, F2R (Float radix2 mr er) = res -> - PROP (binary_normalize m mr er szero)). - { intros mr er E. - specialize (binary_normalize_correct m mr er szero). - change (FLT_exp (3 - emax - prec) prec) with fexp. rewrite E. tauto. - } - set (add_zero := - match z with - | B754_nan _ _ _ => build_nan (fma_nan x y z) - | B754_zero sz => B754_zero szero - | _ => z - end). - assert (ADDZERO: B2R x = 0%R \/ B2R y = 0%R -> PROP add_zero). - { - intros Z. - assert (RES: res = B2R z). - { unfold res. destruct Z as [E|E]; rewrite E, ?Rmult_0_l, ?Rmult_0_r, Rplus_0_l; auto. } - unfold PROP, add_zero; destruct z as [ sz | sz | sz plz | sz mz ez Bz]; try discriminate. - - simpl in RES; rewrite RES; rewrite round_0 by apply valid_rnd_round_mode. - rewrite Rlt_bool_true. split. reflexivity. split. reflexivity. - rewrite Rcompare_Eq by auto. reflexivity. - rewrite Rabs_R0; apply bpow_gt_0. - - rewrite RES, round_generic, Rlt_bool_true. - split. reflexivity. split. reflexivity. - unfold B2R. destruct sz. - rewrite Rcompare_Lt. auto. apply F2R_lt_0. reflexivity. - rewrite Rcompare_Gt. auto. apply F2R_gt_0. reflexivity. - apply abs_B2R_lt_emax. apply valid_rnd_round_mode. apply generic_format_B2R. - } - destruct x as [ sx | sx | sx plx | sx mx ex Bx]; - destruct y as [ sy | sy | sy ply | sy my ey By]; - try discriminate. -- apply ADDZERO; auto. -- apply ADDZERO; auto. -- apply ADDZERO; auto. -- destruct z as [ sz | sz | sz plz | sz mz ez Bz]; try discriminate; unfold Bfma. -+ set (X := Float radix2 (cond_Zopp sx (Zpos mx)) ex). - set (Y := Float radix2 (cond_Zopp sy (Zpos my)) ey). - destruct (Fmult X Y) as [mr er] eqn:FRES. - apply BINORM. unfold res. rewrite <- FRES, F2R_mult, Rplus_0_r. auto. -+ set (X := Float radix2 (cond_Zopp sx (Zpos mx)) ex). - set (Y := Float radix2 (cond_Zopp sy (Zpos my)) ey). - set (Z := Float radix2 (cond_Zopp sz (Zpos mz)) ez). - destruct (Fplus (Fmult X Y) Z) as [mr er] eqn:FRES. - apply BINORM. unfold res. rewrite <- FRES, F2R_plus, F2R_mult. auto. +intros fma_nan mode x y z Fx Fy Fz. +rewrite <- is_finite_B2BSN in Fx, Fy, Fz. +generalize (Bfma_correct prec emax _ _ mode _ _ _ Fx Fy Fz). +replace (BSN.Bfma _ _ _ _) with (B2BSN (Bfma fma_nan mode x y z)) by apply B2BSN_BSN2B. +rewrite 3!B2R_B2BSN. +cbv zeta. +destruct Rlt_bool. +- now destruct Bfma. +- intros H. + apply eq_binary_overflow_FF2SF. + now rewrite FF2SF_B2FF, <- B2SF_B2BSN. Qed. (** Division *) -Definition Fdiv_core_binary m1 e1 m2 e2 := - let d1 := Zdigits2 m1 in - let d2 := Zdigits2 m2 in - let e' := Z.min (fexp (d1 + e1 - (d2 + e2))) (e1 - e2) in - let s := (e1 - e2 - e')%Z in - let m' := - match s with - | Zpos _ => Z.shiftl m1 s - | Z0 => m1 - | Zneg _ => Z0 - end in - let '(q, r) := Zfast_div_eucl m' m2 in - (q, e', new_location m2 r loc_Exact). - -Lemma Bdiv_correct_aux : - forall m sx mx ex sy my ey, - let x := F2R (Float radix2 (cond_Zopp sx (Zpos mx)) ex) in - let y := F2R (Float radix2 (cond_Zopp sy (Zpos my)) ey) in - let z := - let '(mz, ez, lz) := Fdiv_core_binary (Zpos mx) ex (Zpos my) ey in - binary_round_aux m (xorb sx sy) mz ez lz in - valid_binary z = true /\ - if Rlt_bool (Rabs (round radix2 fexp (round_mode m) (x / y))) (bpow radix2 emax) then - FF2R radix2 z = round radix2 fexp (round_mode m) (x / y) /\ - is_finite_FF z = true /\ sign_FF z = xorb sx sy - else - z = binary_overflow m (xorb sx sy). -Proof. -intros m sx mx ex sy my ey. -unfold Fdiv_core_binary. -rewrite 2!Zdigits2_Zdigits. -set (e' := Z.min _ _). -generalize (Fdiv_core_correct radix2 (Zpos mx) ex (Zpos my) ey e' eq_refl eq_refl). -unfold Fdiv_core. -rewrite Zle_bool_true by apply Z.le_min_r. -match goal with |- context [Zfast_div_eucl ?m _] => set (mx' := m) end. -assert (mx' = Zpos mx * Zpower radix2 (ex - ey - e'))%Z as <-. -{ unfold mx'. - destruct (ex - ey - e')%Z as [|p|p]. - now rewrite Zmult_1_r. - now rewrite Z.shiftl_mul_pow2. - easy. } -clearbody mx'. -rewrite Zfast_div_eucl_correct. -destruct Z.div_eucl as [q r]. -intros Bz. -assert (xorb sx sy = Rlt_bool (F2R (Float radix2 (cond_Zopp sx (Zpos mx)) ex) * - / F2R (Float radix2 (cond_Zopp sy (Zpos my)) ey)) 0) as ->. -{ apply eq_sym. -case sy ; simpl. -change (Zneg my) with (Z.opp (Zpos my)). -rewrite F2R_Zopp. -rewrite <- Ropp_inv_permute. -rewrite Ropp_mult_distr_r_reverse. -case sx ; simpl. -apply Rlt_bool_false. -rewrite <- Ropp_mult_distr_l_reverse. -apply Rmult_le_pos. -rewrite <- F2R_opp. -now apply F2R_ge_0. -apply Rlt_le. -apply Rinv_0_lt_compat. -now apply F2R_gt_0. -apply Rlt_bool_true. -rewrite <- Ropp_0. -apply Ropp_lt_contravar. -apply Rmult_lt_0_compat. -now apply F2R_gt_0. -apply Rinv_0_lt_compat. -now apply F2R_gt_0. -apply Rgt_not_eq. -now apply F2R_gt_0. -case sx. -apply Rlt_bool_true. -rewrite F2R_Zopp. -rewrite Ropp_mult_distr_l_reverse. -rewrite <- Ropp_0. -apply Ropp_lt_contravar. -apply Rmult_lt_0_compat. -now apply F2R_gt_0. -apply Rinv_0_lt_compat. -now apply F2R_gt_0. -apply Rlt_bool_false. -apply Rmult_le_pos. -now apply F2R_ge_0. -apply Rlt_le. -apply Rinv_0_lt_compat. -now apply F2R_gt_0. } -unfold Rdiv. -apply binary_round_aux_correct'. -- apply Rmult_integral_contrapositive_currified. - now apply F2R_neq_0 ; case sx. - apply Rinv_neq_0_compat. - now apply F2R_neq_0 ; case sy. -- rewrite Rabs_mult, Rabs_Rinv. - now rewrite <- 2!F2R_Zabs, 2!abs_cond_Zopp. - now apply F2R_neq_0 ; case sy. -- rewrite <- cexp_abs, Rabs_mult, Rabs_Rinv. - rewrite 2!F2R_cond_Zopp, 2!abs_cond_Ropp, <- Rabs_Rinv. - rewrite <- Rabs_mult, cexp_abs. - apply Z.le_trans with (1 := Z.le_min_l _ _). - apply FLT_exp_monotone. - now apply mag_div_F2R. - now apply F2R_neq_0. - now apply F2R_neq_0 ; case sy. -Qed. - Definition Bdiv div_nan m x y := - match x, y with - | B754_nan _ _ _, _ | _, B754_nan _ _ _ => build_nan (div_nan x y) - | B754_infinity sx, B754_infinity sy => build_nan (div_nan x y) - | B754_infinity sx, B754_finite sy _ _ _ => B754_infinity (xorb sx sy) - | B754_finite sx _ _ _, B754_infinity sy => B754_zero (xorb sx sy) - | B754_infinity sx, B754_zero sy => B754_infinity (xorb sx sy) - | B754_zero sx, B754_infinity sy => B754_zero (xorb sx sy) - | B754_finite sx _ _ _, B754_zero sy => B754_infinity (xorb sx sy) - | B754_zero sx, B754_finite sy _ _ _ => B754_zero (xorb sx sy) - | B754_zero sx, B754_zero sy => build_nan (div_nan x y) - | B754_finite sx mx ex _, B754_finite sy my ey _ => - FF2B _ (proj1 (Bdiv_correct_aux m sx mx ex sy my ey)) - end. + BSN2B (div_nan x y) (Bdiv m (B2BSN x) (B2BSN y)). Theorem Bdiv_correct : forall div_nan m x y, @@ -2152,164 +1187,25 @@ Theorem Bdiv_correct : else B2FF (Bdiv div_nan m x y) = binary_overflow m (xorb (Bsign x) (Bsign y)). Proof. -intros div_nan m x [sy|sy|sy ply|sy my ey Hy] Zy ; try now elim Zy. -revert x. +intros div_nan mode x y Zy. +rewrite <- B2R_B2BSN in Zy. +generalize (Bdiv_correct prec emax _ _ mode (B2BSN x) _ Zy). +replace (BSN.Bdiv _ _ _) with (B2BSN (Bdiv div_nan mode x y)) by apply B2BSN_BSN2B. unfold Rdiv. -intros [sx|sx|sx plx Hx|sx mx ex Hx] ; - try ( rewrite Rmult_0_l, round_0, Rabs_R0, Rlt_bool_true ; [ simpl ; try easy ; now rewrite B2R_build_nan, is_finite_build_nan, is_nan_build_nan | apply bpow_gt_0 | auto with typeclass_instances ] ). -simpl. -case Bdiv_correct_aux. -intros H1. -unfold Rdiv. -case Rlt_bool. -intros (H2, (H3, H4)). -split. -now rewrite B2R_FF2B. -split. -now rewrite is_finite_FF2B. -rewrite Bsign_FF2B. congruence. -intros H2. -now rewrite B2FF_FF2B. +destruct y as [sy|sy|sy ply|sy my ey Hy] ; try now elim Zy. +destruct x as [sx|sx|sx plx Hx|sx mx ex Hx] ; + try ( simpl ; rewrite Rmult_0_l, round_0, Rabs_R0, Rlt_bool_true ; [ simpl ; try easy ; now rewrite B2R_build_nan, is_finite_build_nan, is_nan_build_nan | apply bpow_gt_0 | auto with typeclass_instances ] ). +destruct Rlt_bool. +- now destruct Bdiv. +- intros H. + apply eq_binary_overflow_FF2SF. + now rewrite FF2SF_B2FF, <- B2SF_B2BSN. Qed. (** Square root *) -Definition Fsqrt_core_binary m e := - let d := Zdigits2 m in - let e' := Z.min (fexp (Z.div2 (d + e + 1))) (Z.div2 e) in - let s := (e - 2 * e')%Z in - let m' := - match s with - | Zpos p => Z.shiftl m s - | Z0 => m - | Zneg _ => Z0 - end in - let (q, r) := Z.sqrtrem m' in - let l := - if Zeq_bool r 0 then loc_Exact - else loc_Inexact (if Zle_bool r q then Lt else Gt) in - (q, e', l). - -Lemma Bsqrt_correct_aux : - forall m mx ex (Hx : bounded mx ex = true), - let x := F2R (Float radix2 (Zpos mx) ex) in - let z := - let '(mz, ez, lz) := Fsqrt_core_binary (Zpos mx) ex in - binary_round_aux m false mz ez lz in - valid_binary z = true /\ - FF2R radix2 z = round radix2 fexp (round_mode m) (sqrt x) /\ - is_finite_FF z = true /\ sign_FF z = false. -Proof with auto with typeclass_instances. -intros m mx ex Hx. -unfold Fsqrt_core_binary. -rewrite Zdigits2_Zdigits. -set (e' := Z.min _ _). -assert (2 * e' <= ex)%Z as He. -{ assert (e' <= Z.div2 ex)%Z by apply Z.le_min_r. - rewrite (Zdiv2_odd_eqn ex). - destruct Z.odd ; lia. } -generalize (Fsqrt_core_correct radix2 (Zpos mx) ex e' eq_refl He). -unfold Fsqrt_core. -set (mx' := match (ex - 2 * e')%Z with Z0 => _ | _ => _ end). -assert (mx' = Zpos mx * Zpower radix2 (ex - 2 * e'))%Z as <-. -{ unfold mx'. - destruct (ex - 2 * e')%Z as [|p|p]. - now rewrite Zmult_1_r. - now rewrite Z.shiftl_mul_pow2. - easy. } -clearbody mx'. -destruct Z.sqrtrem as [mz r]. -set (lz := if Zeq_bool r 0 then _ else _). -clearbody lz. -intros Bz. -refine (_ (binary_round_aux_correct' m (sqrt (F2R (Float radix2 (Zpos mx) ex))) mz e' lz _ _ _)) ; cycle 1. - now apply Rgt_not_eq, sqrt_lt_R0, F2R_gt_0. - rewrite Rabs_pos_eq. - exact Bz. - apply sqrt_ge_0. - apply Z.le_trans with (1 := Z.le_min_l _ _). - apply FLT_exp_monotone. - rewrite mag_sqrt_F2R by easy. - apply Z.le_refl. -rewrite Rlt_bool_false by apply sqrt_ge_0. -rewrite Rlt_bool_true. -easy. -rewrite Rabs_pos_eq. -refine (_ (relative_error_FLT_ex radix2 emin prec (prec_gt_0 prec) (round_mode m) (sqrt (F2R (Float radix2 (Zpos mx) ex))) _)). -fold fexp. -intros (eps, (Heps, Hr)). -rewrite Hr. -assert (Heps': (Rabs eps < 1)%R). -apply Rlt_le_trans with (1 := Heps). -fold (bpow radix2 0). -apply bpow_le. -generalize (prec_gt_0 prec). -clear ; lia. -apply Rsqr_incrst_0. -3: apply bpow_ge_0. -rewrite Rsqr_mult. -rewrite Rsqr_sqrt. -2: now apply F2R_ge_0. -unfold Rsqr. -apply Rmult_ge_0_gt_0_lt_compat. -apply Rle_ge. -apply Rle_0_sqr. -apply bpow_gt_0. -now apply bounded_lt_emax. -apply Rlt_le_trans with 4%R. -apply (Rsqr_incrst_1 _ 2). -apply Rplus_lt_compat_l. -apply (Rabs_lt_inv _ _ Heps'). -rewrite <- (Rplus_opp_r 1). -apply Rplus_le_compat_l. -apply Rlt_le. -apply (Rabs_lt_inv _ _ Heps'). -now apply IZR_le. -change 4%R with (bpow radix2 2). -apply bpow_le. -generalize (prec_gt_0 prec). -clear -Hmax ; lia. -apply Rmult_le_pos. -apply sqrt_ge_0. -rewrite <- (Rplus_opp_r 1). -apply Rplus_le_compat_l. -apply Rlt_le. -apply (Rabs_lt_inv _ _ Heps'). -rewrite Rabs_pos_eq. -2: apply sqrt_ge_0. -apply Rsqr_incr_0. -2: apply bpow_ge_0. -2: apply sqrt_ge_0. -rewrite Rsqr_sqrt. -2: now apply F2R_ge_0. -apply Rle_trans with (bpow radix2 emin). -unfold Rsqr. -rewrite <- bpow_plus. -apply bpow_le. -unfold emin. -clear -Hmax ; lia. -apply generic_format_ge_bpow with fexp. -intros. -apply Z.le_max_r. -now apply F2R_gt_0. -apply generic_format_canonical. -apply (canonical_canonical_mantissa false). -apply (andb_prop _ _ Hx). -apply round_ge_generic... -apply generic_format_0. -apply sqrt_ge_0. -Qed. - Definition Bsqrt sqrt_nan m x := - match x with - | B754_nan sx plx _ => build_nan (sqrt_nan x) - | B754_infinity false => x - | B754_infinity true => build_nan (sqrt_nan x) - | B754_finite true _ _ _ => build_nan (sqrt_nan x) - | B754_zero _ => x - | B754_finite sx mx ex Hx => - FF2B _ (proj1 (Bsqrt_correct_aux m mx ex Hx)) - end. + BSN2B (sqrt_nan x) (Bsqrt m (B2BSN x)). Theorem Bsqrt_correct : forall sqrt_nan m x, @@ -2317,126 +1213,71 @@ Theorem Bsqrt_correct : is_finite (Bsqrt sqrt_nan m x) = match x with B754_zero _ => true | B754_finite false _ _ _ => true | _ => false end /\ (is_nan (Bsqrt sqrt_nan m x) = false -> Bsign (Bsqrt sqrt_nan m x) = Bsign x). Proof. -intros sqrt_nan m [sx|[|]|sx plx Hplx|sx mx ex Hx] ; - try ( simpl ; rewrite sqrt_0, round_0, ?B2R_build_nan, ?is_finite_build_nan, ?is_nan_build_nan ; intuition auto with typeclass_instances ; easy). -simpl. -case Bsqrt_correct_aux. -intros H1 (H2, (H3, H4)). -case sx. -rewrite B2R_build_nan, is_finite_build_nan, is_nan_build_nan. -refine (conj _ (conj (refl_equal false) _)). -apply sym_eq. -unfold sqrt. -case Rcase_abs. -intros _. -apply round_0. -auto with typeclass_instances. +intros sqrt_nan mode x. +generalize (Bsqrt_correct prec emax _ _ mode (B2BSN x)). +replace (BSN.Bsqrt _ _) with (B2BSN (Bsqrt sqrt_nan mode x)) by apply B2BSN_BSN2B. intros H. -elim Rge_not_lt with (1 := H). -now apply F2R_lt_0. -easy. -split. -now rewrite B2R_FF2B. -split. -now rewrite is_finite_FF2B. -intros _. -now rewrite Bsign_FF2B. +destruct x as [sx|[|]|sx plx Hplx|sx mx ex Hx] ; try easy. +now destruct Bsqrt. Qed. (** A few values *) -Definition Bone := FF2B _ (proj1 (binary_round_correct mode_NE false 1 0)). +Definition Bone := + BSN2B' _ (@is_nan_Bone prec emax _ _). Theorem Bone_correct : B2R Bone = 1%R. Proof. -unfold Bone; simpl. -set (Hr := binary_round_correct _ _ _ _). -unfold Hr; rewrite B2R_FF2B. -destruct Hr as (Vz, Hr). -revert Hr. -fold emin; simpl. -rewrite round_generic; [|now apply valid_rnd_N|]. -- unfold F2R; simpl; rewrite Rmult_1_r. - rewrite Rlt_bool_true. - + now intros (Hr, Hr'); rewrite Hr. - + rewrite Rabs_pos_eq; [|lra]. - change 1%R with (bpow radix2 0); apply bpow_lt. - unfold Prec_gt_0 in prec_gt_0_; lia. -- apply generic_format_F2R; intros _. - unfold cexp, fexp, FLT_exp, F2R; simpl; rewrite Rmult_1_r, mag_1. - unfold emin; unfold Prec_gt_0 in prec_gt_0_; lia. +unfold Bone. +rewrite B2R_BSN2B'. +apply Bone_correct. Qed. Lemma is_finite_Bone : is_finite Bone = true. Proof. -generalize Bone_correct; case Bone; simpl; - try (intros; reflexivity); intros; exfalso; lra. +unfold Bone. +rewrite is_finite_BSN2B'. +apply is_finite_Bone. Qed. Lemma Bsign_Bone : Bsign Bone = false. Proof. -generalize Bone_correct; case Bone; simpl; - try (intros; exfalso; lra); intros s' m e _. -case s'; [|now intro]; unfold F2R; simpl. -intro H; exfalso; revert H; apply Rlt_not_eq, (Rle_lt_trans _ 0); [|lra]. -rewrite <-Ropp_0, <-(Ropp_involutive (_ * _)); apply Ropp_le_contravar. -rewrite Ropp_mult_distr_l; apply Rmult_le_pos; [|now apply bpow_ge_0]. -unfold IZR; rewrite <-INR_IPR; generalize (INR_pos m); lra. -Qed. - -Lemma Bmax_float_proof : - valid_binary - (F754_finite false (shift_pos (Z.to_pos prec) 1 - 1) (emax - prec)) - = true. -Proof. -unfold valid_binary, bounded; apply andb_true_intro; split. -- unfold canonical_mantissa; apply Zeq_bool_true. - set (p := Z.pos (digits2_pos _)). - assert (H : p = prec). - { unfold p; 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 prec_gt_0_; lia. } - apply Zdigits_unique; - rewrite Z.pow_pos_fold, Z2Pos.id; [|exact prec_gt_0_]; 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 prec_gt_0_; 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 prec_gt_0_; 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 prec_gt_0_]. - change 1%Z with (2 ^ 0)%Z; change 2%Z with (radix2 : Z). - apply Zpower_lt; unfold Prec_gt_0 in prec_gt_0_; lia. } - unfold fexp, FLT_exp; rewrite H, Z.max_l; [ring|]. - unfold Prec_gt_0 in prec_gt_0_; unfold emin; lia. -- apply Zle_bool_true; unfold emin; unfold Prec_gt_0 in prec_gt_0_; lia. -Qed. - -Definition Bmax_float := FF2B _ Bmax_float_proof. +unfold Bone. +rewrite Bsign_BSN2B'. +apply Bsign_Bone. +Qed. + +Definition Bmax_float := + BSN2B' Bmax_float eq_refl. (** Extraction/modification of mantissa/exponent *) Definition Bnormfr_mantissa x := - match x with - | B754_finite _ mx ex _ => - if Z.eqb ex (-prec)%Z then Npos mx else 0%N - | _ => 0%N - end. + Bnormfr_mantissa (B2BSN x). -Definition Bldexp mode f e := - match f with - | B754_finite sx mx ex _ => - FF2B _ (proj1 (binary_round_correct mode sx mx (ex+e))) - | _ => f - end. +Definition lift x y (Ny : @BSN.is_nan prec emax y = is_nan x) : binary_float. +Proof. +destruct (is_nan x). +exact x. +now apply (BSN2B' y). +Defined. + +Lemma B2BSN_lift : + forall x y Ny, + B2BSN (lift x y Ny) = y. +Proof. +intros x y Ny. +unfold lift. +destruct x as [sx|sx|sx px Px|sx mx ex Bx] ; simpl ; try apply B2BSN_BSN2B'. +now destruct y. +Qed. + +Definition Bldexp (mode : mode) (x : binary_float) (e : Z) : binary_float. +Proof. +apply (lift x (Bldexp mode (B2BSN x) e)). +rewrite <- is_nan_B2BSN. +apply is_nan_Bldexp. +Defined. Theorem Bldexp_correct : forall m (f : binary_float) e, @@ -2450,144 +1291,38 @@ Theorem Bldexp_correct : else B2FF (Bldexp m f e) = binary_overflow m (Bsign f). Proof. -intros m f e. -case f. -- intro s; simpl; rewrite Rmult_0_l, round_0; [|apply valid_rnd_round_mode]. - now rewrite Rabs_R0, Rlt_bool_true; [|now apply bpow_gt_0]. -- intro s; simpl; rewrite Rmult_0_l, round_0; [|apply valid_rnd_round_mode]. - now rewrite Rabs_R0, Rlt_bool_true; [|now apply bpow_gt_0]. -- intro s; simpl; rewrite Rmult_0_l, round_0; [|apply valid_rnd_round_mode]. - now rewrite Rabs_R0, Rlt_bool_true; [|now apply bpow_gt_0]. -- intros s mf ef Hmef. - case (Rlt_bool_spec _ _); intro Hover. - + unfold Bldexp; rewrite B2R_FF2B, is_finite_FF2B, Bsign_FF2B. - simpl; unfold F2R; simpl; rewrite Rmult_assoc, <-bpow_plus. - destruct (binary_round_correct m s mf (ef + e)) as (Hf, Hr). - fold emin in Hr; simpl in Hr; rewrite Rlt_bool_true in Hr. - * now destruct Hr as (Hr, (Hfr, Hsr)); rewrite Hr, Hfr, Hsr. - * now revert Hover; unfold B2R, F2R; simpl; rewrite Rmult_assoc, bpow_plus. - + unfold Bldexp; rewrite B2FF_FF2B; simpl. - destruct (binary_round_correct m s mf (ef + e)) as (Hf, Hr). - fold emin in Hr; simpl in Hr; rewrite Rlt_bool_false in Hr; [exact Hr|]. - now revert Hover; unfold B2R, F2R; simpl; rewrite Rmult_assoc, bpow_plus. -Qed. +intros mode x e. +generalize (Bldexp_correct prec emax _ _ mode (B2BSN x) e). +replace (BSN.Bldexp _ _ _) with (B2BSN (Bldexp mode x e)) by apply B2BSN_lift. +rewrite B2R_B2BSN. +destruct Rlt_bool. +- destruct x as [sx|sx|sx px Px|sx mx ex Bx] ; try easy. + now destruct Bldexp. +- intros H. + apply eq_binary_overflow_FF2SF. + rewrite B2SF_B2BSN in H. + rewrite FF2SF_B2FF, H. + destruct x as [sx|sx|sx px Px|sx mx ex Bx] ; simpl in H ; try easy. + contradict H. + unfold BSN.binary_overflow. + now destruct overflow_to_inf. +Qed. + +Section Bfrexp. (** This hypothesis is needed to implement [Bfrexp] (otherwise, we have emin > - prec and [Bfrexp] cannot fit the mantissa in interval #[0.5, 1)#) *) -Hypothesis Hemax : (3 <= emax)%Z. +Hypothesis Hemax : (2 < emax)%Z. -Definition Ffrexp_core_binary s m e := - if (Z.to_pos prec <=? digits2_pos m)%positive then - (F754_finite s m (-prec), (e + prec)%Z) - else - let d := (prec - Z.pos (digits2_pos m))%Z in - (F754_finite s (shift_pos (Z.to_pos d) m) (-prec), (e + prec - d)%Z). - -Lemma Bfrexp_correct_aux : - forall sx mx ex (Hx : bounded mx ex = true), - let x := F2R (Float radix2 (cond_Zopp sx (Z.pos mx)) ex) in - let z := fst (Ffrexp_core_binary sx mx ex) in - let e := snd (Ffrexp_core_binary sx mx ex) in - valid_binary z = true /\ - (/2 <= Rabs (FF2R radix2 z) < 1)%R /\ - (x = FF2R radix2 z * bpow radix2 e)%R. -Proof. -intros sx mx ex Bx. -set (x := F2R _). -set (z := fst _). -set (e := snd _); simpl. -assert (Dmx_le_prec : (Z.pos (digits2_pos mx) <= prec)%Z). -{ revert Bx; unfold bounded; rewrite Bool.andb_true_iff. - unfold canonical_mantissa; rewrite <-Zeq_is_eq_bool; unfold fexp, FLT_exp. - case (Z.max_spec (Z.pos (digits2_pos mx) + ex - prec) emin); lia. } -assert (Dmx_le_prec' : (digits2_pos mx <= Z.to_pos prec)%positive). -{ change (_ <= _)%positive - with (Z.pos (digits2_pos mx) <= Z.pos (Z.to_pos prec))%Z. - now rewrite Z2Pos.id; [|now apply prec_gt_0_]. } -unfold z, e, Ffrexp_core_binary. -case (Pos.leb_spec _ _); simpl; intro Dmx. -- unfold bounded, F2R; simpl. - assert (Dmx' : digits2_pos mx = Z.to_pos prec). - { now apply Pos.le_antisym. } - assert (Dmx'' : Z.pos (digits2_pos mx) = prec). - { now rewrite Dmx', Z2Pos.id; [|apply prec_gt_0_]. } - split; [|split]. - + apply andb_true_intro. - split; [|apply Zle_bool_true; lia]. - apply Zeq_bool_true; unfold fexp, FLT_exp. - rewrite Dmx', Z2Pos.id; [|now apply prec_gt_0_]. - rewrite Z.max_l; [ring|unfold emin; lia]. - + rewrite Rabs_mult, (Rabs_pos_eq (bpow _ _)); [|now apply bpow_ge_0]. - rewrite <-abs_IZR, abs_cond_Zopp; simpl; split. - * apply (Rmult_le_reg_r (bpow radix2 prec)); [now apply bpow_gt_0|]. - rewrite Rmult_assoc, <-bpow_plus, Z.add_opp_diag_l; simpl. - rewrite Rmult_1_r. - change (/ 2)%R with (bpow radix2 (- 1)); rewrite <-bpow_plus. - rewrite <-Dmx'', Z.add_comm, Zpos_digits2_pos, Zdigits_mag; [|lia]. - set (b := bpow _ _). - rewrite <-(Rabs_pos_eq (IZR _)); [|apply IZR_le; lia]. - apply bpow_mag_le; apply IZR_neq; lia. - * apply (Rmult_lt_reg_r (bpow radix2 prec)); [now apply bpow_gt_0|]. - rewrite Rmult_assoc, <-bpow_plus, Z.add_opp_diag_l; simpl. - rewrite Rmult_1_l, Rmult_1_r. - rewrite <-Dmx'', Zpos_digits2_pos, Zdigits_mag; [|lia]. - set (b := bpow _ _). - rewrite <-(Rabs_pos_eq (IZR _)); [|apply IZR_le; lia]. - apply bpow_mag_gt; apply IZR_neq; lia. - + unfold x, F2R; simpl; rewrite Rmult_assoc, <-bpow_plus. - now replace (_ + _)%Z with ex by ring. -- unfold bounded, F2R; simpl. - assert (Dmx' : (Z.pos (digits2_pos mx) < prec)%Z). - { now rewrite <-(Z2Pos.id prec); [|now apply prec_gt_0_]. } - split; [|split]. - + unfold bounded; apply andb_true_intro. - split; [|apply Zle_bool_true; lia]. - apply Zeq_bool_true; unfold fexp, FLT_exp. - rewrite Zpos_digits2_pos, shift_pos_correct, Z.pow_pos_fold. - rewrite Z2Pos.id; [|lia]. - rewrite Z.mul_comm; change 2%Z with (radix2 : Z). - rewrite Zdigits_mult_Zpower; [|lia|lia]. - rewrite Zpos_digits2_pos; replace (_ - _)%Z with (- prec)%Z by ring. - now rewrite Z.max_l; [|unfold emin; lia]. - + rewrite Rabs_mult, (Rabs_pos_eq (bpow _ _)); [|now apply bpow_ge_0]. - rewrite <-abs_IZR, abs_cond_Zopp; simpl. - rewrite shift_pos_correct, mult_IZR. - change (IZR (Z.pow_pos _ _)) - with (bpow radix2 (Z.pos (Z.to_pos ((prec - Z.pos (digits2_pos mx)))))). - rewrite Z2Pos.id; [|lia]. - rewrite Rmult_comm, <-Rmult_assoc, <-bpow_plus. - set (d := Z.pos (digits2_pos mx)). - replace (_ + _)%Z with (- d)%Z by ring; split. - * apply (Rmult_le_reg_l (bpow radix2 d)); [now apply bpow_gt_0|]. - rewrite <-Rmult_assoc, <-bpow_plus, Z.add_opp_diag_r. - rewrite Rmult_1_l. - change (/ 2)%R with (bpow radix2 (- 1)); rewrite <-bpow_plus. - rewrite <-(Rabs_pos_eq (IZR _)); [|apply IZR_le; lia]. - unfold d; rewrite Zpos_digits2_pos, Zdigits_mag; [|lia]. - apply bpow_mag_le; apply IZR_neq; lia. - * apply (Rmult_lt_reg_l (bpow radix2 d)); [now apply bpow_gt_0|]. - rewrite <-Rmult_assoc, <-bpow_plus, Z.add_opp_diag_r. - rewrite Rmult_1_l, Rmult_1_r. - rewrite <-(Rabs_pos_eq (IZR _)); [|apply IZR_le; lia]. - unfold d; rewrite Zpos_digits2_pos, Zdigits_mag; [|lia]. - apply bpow_mag_gt; apply IZR_neq; lia. - + rewrite Rmult_assoc, <-bpow_plus, shift_pos_correct. - rewrite IZR_cond_Zopp, mult_IZR, cond_Ropp_mult_r, <-IZR_cond_Zopp. - change (IZR (Z.pow_pos _ _)) - with (bpow radix2 (Z.pos (Z.to_pos (prec - Z.pos (digits2_pos mx))))). - rewrite Z2Pos.id; [|lia]. - rewrite Rmult_comm, <-Rmult_assoc, <-bpow_plus. - now replace (_ + _)%Z with ex by ring; rewrite Rmult_comm. -Qed. - -Definition Bfrexp f := - match f with - | B754_finite s m e H => - let e' := snd (Ffrexp_core_binary s m e) in - (FF2B _ (proj1 (Bfrexp_correct_aux s m e H)), e') - | _ => (f, (-2*emax-prec)%Z) - end. +Definition Bfrexp (x : binary_float) : binary_float * Z. +Proof. +set (y := Bfrexp (B2BSN x)). +refine (pair _ (snd y)). +apply (lift x (fst y)). +rewrite <- is_nan_B2BSN. +apply is_nan_Bfrexp. +Defined. Theorem Bfrexp_correct : forall f, @@ -2599,19 +1334,27 @@ Theorem Bfrexp_correct : (x = B2R z * bpow radix2 e)%R /\ e = mag radix2 x. Proof. -intro f; case f; intro s; try discriminate; intros m e Hf _. -generalize (Bfrexp_correct_aux s m e Hf). -intros (_, (Hb, Heq)); simpl; rewrite B2R_FF2B. -split; [now simpl|]; split; [now simpl|]. -rewrite Heq, mag_mult_bpow. -- apply (Z.add_reg_l (- (snd (Ffrexp_core_binary s m e)))). - now ring_simplify; symmetry; apply mag_unique. -- intro H; destruct Hb as (Hb, _); revert Hb; rewrite H, Rabs_R0; lra. +intros x Fx. +rewrite <- is_finite_strict_B2BSN in Fx. +generalize (Bfrexp_correct prec emax _ (B2BSN x) Fx). +simpl. +rewrite <- B2R_B2BSN. +rewrite B2BSN_lift. +destruct BSN.Bfrexp as [z e]. +rewrite B2R_B2BSN. +now intros [H1 [H2 H3]]. Qed. +End Bfrexp. + (** Ulp *) -Definition Bulp x := Bldexp mode_NE Bone (fexp (snd (Bfrexp x))). +Definition Bulp (x : binary_float) : binary_float. +Proof. +apply (lift x (Bulp (B2BSN x))). +rewrite <- is_nan_B2BSN. +apply is_nan_Bulp. +Defined. Theorem Bulp_correct : forall x, @@ -2620,373 +1363,72 @@ Theorem Bulp_correct : is_finite (Bulp x) = true /\ Bsign (Bulp x) = false. Proof. -intro x; case x. -- intros s _; unfold Bulp. - replace (fexp _) with emin. - + generalize (Bldexp_correct mode_NE Bone emin). - rewrite Bone_correct, Rmult_1_l, round_generic; - [|now apply valid_rnd_N|apply generic_format_bpow; unfold fexp, FLT_exp; - rewrite Z.max_r; unfold Prec_gt_0 in prec_gt_0_; lia]. - rewrite Rlt_bool_true. - * intros (Hr, (Hf, Hs)); rewrite Hr, Hf, Hs. - split; [|now split; [apply is_finite_Bone|apply Bsign_Bone]]. - simpl; unfold ulp; rewrite Req_bool_true; [|reflexivity]. - destruct (negligible_exp_FLT emin prec) as (n, (Hn, Hn')). - change fexp with (FLT_exp emin prec); rewrite Hn. - now unfold FLT_exp; rewrite Z.max_r; - [|unfold Prec_gt_0 in prec_gt_0_; lia]. - * rewrite Rabs_pos_eq; [|now apply bpow_ge_0]; apply bpow_lt. - unfold emin; unfold Prec_gt_0 in prec_gt_0_; lia. - + simpl; change (fexp _) with (fexp (-2 * emax - prec)). - unfold fexp, FLT_exp; rewrite Z.max_r; [reflexivity|]. - unfold emin; unfold Prec_gt_0 in prec_gt_0_; lia. -- intro; discriminate. -- intros s pl Hpl; discriminate. -- intros s m e Hme _; unfold Bulp, ulp, cexp. - set (f := B754_finite _ _ _ _). - rewrite Req_bool_false. - + destruct (Bfrexp_correct f (eq_refl _)) as (Hfr1, (Hfr2, Hfr3)). - rewrite Hfr3. - set (e' := fexp _). - generalize (Bldexp_correct mode_NE Bone e'). - rewrite Bone_correct, Rmult_1_l, round_generic; [|now apply valid_rnd_N|]. - { rewrite Rlt_bool_true. - - intros (Hr, (Hf, Hs)); rewrite Hr, Hf, Hs. - now split; [|split; [apply is_finite_Bone|apply Bsign_Bone]]. - - rewrite Rabs_pos_eq; [|now apply bpow_ge_0]. - unfold e', fexp, FLT_exp. - case (Z.max_spec (mag radix2 (B2R f) - prec) emin) - as [(_, Hm)|(_, Hm)]; rewrite Hm; apply bpow_lt; - [now unfold emin; unfold Prec_gt_0 in prec_gt_0_; lia|]. - apply (Zplus_lt_reg_r _ _ prec); ring_simplify. - assert (mag radix2 (B2R f) <= emax)%Z; - [|now unfold Prec_gt_0 in prec_gt_0_; lia]. - apply mag_le_bpow; [|now apply abs_B2R_lt_emax]. - now unfold f, B2R; apply F2R_neq_0; case s. } - apply generic_format_bpow, Z.max_lub. - * unfold Prec_gt_0 in prec_gt_0_; lia. - * apply Z.le_max_r. - + now unfold f, B2R; apply F2R_neq_0; case s. +intros x Fx. +rewrite <- is_finite_B2BSN in Fx. +generalize (Bulp_correct prec emax _ _ _ Fx). +replace (BSN.Bulp (B2BSN x)) with (B2BSN (Bulp x)) by apply B2BSN_lift. +rewrite 2!B2R_B2BSN. +now destruct Bulp. Qed. (** Successor (and predecessor) *) -Definition Bpred_pos pred_pos_nan x := - match x with - | B754_finite _ mx _ _ => - let d := - if (mx~0 =? shift_pos (Z.to_pos prec) 1)%positive then - Bldexp mode_NE Bone (fexp (snd (Bfrexp x) - 1)) - else - Bulp x in - Bminus (fun _ => pred_pos_nan) mode_NE x d - | _ => x - end. - -Theorem Bpred_pos_correct : - forall pred_pos_nan x, - (0 < B2R x)%R -> - B2R (Bpred_pos pred_pos_nan x) = pred_pos radix2 fexp (B2R x) /\ - is_finite (Bpred_pos pred_pos_nan x) = true /\ - Bsign (Bpred_pos pred_pos_nan x) = false. -Proof. -intros pred_pos_nan x. -generalize (Bfrexp_correct x). -case x. -- simpl; intros s _ Bx; exfalso; apply (Rlt_irrefl _ Bx). -- simpl; intros s _ Bx; exfalso; apply (Rlt_irrefl _ Bx). -- simpl; intros s pl Hpl _ Bx; exfalso; apply (Rlt_irrefl _ Bx). -- intros sx mx ex Hmex Hfrexpx Px. - assert (Hsx : sx = false). - { revert Px; case sx; unfold B2R, F2R; simpl; [|now intro]. - intro Px; exfalso; revert Px; apply Rle_not_lt. - rewrite <-(Rmult_0_l (bpow radix2 ex)). - apply Rmult_le_compat_r; [apply bpow_ge_0|apply IZR_le; lia]. } - clear Px; rewrite Hsx in Hfrexpx |- *; clear Hsx sx. - specialize (Hfrexpx (eq_refl _)). - simpl in Hfrexpx; rewrite B2R_FF2B in Hfrexpx. - destruct Hfrexpx as (Hfrexpx_bounds, (Hfrexpx_eq, Hfrexpx_exp)). - unfold Bpred_pos, Bfrexp. - simpl (snd (_, snd _)). - rewrite Hfrexpx_exp. - set (x' := B754_finite _ _ _ _). - set (xr := F2R _). - assert (Nzxr : xr <> 0%R). - { unfold xr, F2R; simpl. - rewrite <-(Rmult_0_l (bpow radix2 ex)); intro H. - apply Rmult_eq_reg_r in H; [|apply Rgt_not_eq, bpow_gt_0]. - apply eq_IZR in H; lia. } - assert (Hulp := Bulp_correct x'). - specialize (Hulp (eq_refl _)). - assert (Hldexp := Bldexp_correct mode_NE Bone (fexp (mag radix2 xr - 1))). - rewrite Bone_correct, Rmult_1_l in Hldexp. - assert (Fbpowxr : generic_format radix2 fexp - (bpow radix2 (fexp (mag radix2 xr - 1)))). - { apply generic_format_bpow, Z.max_lub. - - unfold Prec_gt_0 in prec_gt_0_; lia. - - apply Z.le_max_r. } - assert (H : Rlt_bool (Rabs - (round radix2 fexp (round_mode mode_NE) - (bpow radix2 (fexp (mag radix2 xr - 1))))) - (bpow radix2 emax) = true); [|rewrite H in Hldexp; clear H]. - { apply Rlt_bool_true; rewrite round_generic; - [|apply valid_rnd_round_mode|apply Fbpowxr]. - rewrite Rabs_pos_eq; [|apply bpow_ge_0]; apply bpow_lt. - apply Z.max_lub_lt; [|unfold emin; unfold Prec_gt_0 in prec_gt_0_; lia]. - apply (Zplus_lt_reg_r _ _ (prec + 1)); ring_simplify. - rewrite Z.add_1_r; apply Zle_lt_succ, mag_le_bpow. - - exact Nzxr. - - apply (Rlt_le_trans _ (bpow radix2 emax)). - + change xr with (B2R x'); apply abs_B2R_lt_emax. - + apply bpow_le; unfold Prec_gt_0 in prec_gt_0_; lia. } - set (d := if (mx~0 =? _)%positive then _ else _). - set (minus_nan := fun _ => _). - assert (Hminus := Bminus_correct minus_nan mode_NE x' d (eq_refl _)). - assert (Fd : is_finite d = true). - { unfold d; case (_ =? _)%positive. - - now rewrite (proj1 (proj2 Hldexp)), is_finite_Bone. - - now rewrite (proj1 (proj2 Hulp)). } - specialize (Hminus Fd). - assert (Px : (0 <= B2R x')%R). - { unfold B2R, x', F2R; simpl. - now apply Rmult_le_pos; [apply IZR_le|apply bpow_ge_0]. } - assert (Pd : (0 <= B2R d)%R). - { unfold d; case (_ =? _)%positive. - - rewrite (proj1 Hldexp). - now rewrite round_generic; [apply bpow_ge_0|apply valid_rnd_N|]. - - rewrite (proj1 Hulp); apply ulp_ge_0. } - assert (Hdlex : (B2R d <= B2R x')%R). - { unfold d; case (_ =? _)%positive. - - rewrite (proj1 Hldexp). - rewrite round_generic; [|now apply valid_rnd_N|now simpl]. - apply (Rle_trans _ (bpow radix2 (mag radix2 xr - 1))). - + apply bpow_le, Z.max_lub. - * unfold Prec_gt_0 in prec_gt_0_; lia. - * apply (Zplus_le_reg_r _ _ 1); ring_simplify. - apply mag_ge_bpow. - replace (_ - 1)%Z with emin by ring. - now change xr with (B2R x'); apply abs_B2R_ge_emin. - + rewrite <-(Rabs_pos_eq _ Px). - now change xr with (B2R x'); apply bpow_mag_le. - - rewrite (proj1 Hulp); apply ulp_le_id. - + assert (B2R x' <> 0%R); [exact Nzxr|lra]. - + apply generic_format_B2R. } - assert (H : Rlt_bool - (Rabs - (round radix2 fexp - (round_mode mode_NE) (B2R x' - B2R d))) - (bpow radix2 emax) = true); [|rewrite H in Hminus; clear H]. - { apply Rlt_bool_true. - rewrite <-round_NE_abs; [|now apply FLT_exp_valid]. - rewrite Rabs_pos_eq; [|lra]. - apply (Rle_lt_trans _ (B2R x')). - - apply round_le_generic; - [now apply FLT_exp_valid|now apply valid_rnd_N| |lra]. - apply generic_format_B2R. - - apply (Rle_lt_trans _ _ _ (Rle_abs _)), abs_B2R_lt_emax. } - rewrite (proj1 Hminus). - rewrite (proj1 (proj2 Hminus)). - rewrite (proj2 (proj2 Hminus)). - split; [|split; [reflexivity|now case (Rcompare_spec _ _); [lra| |]]]. - unfold pred_pos, d. - case (Pos.eqb_spec _ _); intro Hd; case (Req_bool_spec _ _); intro Hpred. - + rewrite (proj1 Hldexp). - rewrite (round_generic _ _ _ _ Fbpowxr). - change xr with (B2R x'). - replace (_ - _)%R with (pred_pos radix2 fexp (B2R x')). - * rewrite round_generic; [reflexivity|now apply valid_rnd_N|]. - apply generic_format_pred_pos; - [now apply FLT_exp_valid|apply generic_format_B2R|]. - change xr with (B2R x') in Nzxr; lra. - * now unfold pred_pos; rewrite Req_bool_true. - + exfalso; apply Hpred. - assert (Hmx : IZR (Z.pos mx) = bpow radix2 (prec - 1)). - { apply (Rmult_eq_reg_l 2); [|lra]; rewrite <-mult_IZR. - change (2 * Z.pos mx)%Z with (Z.pos mx~0); rewrite Hd. - rewrite shift_pos_correct, Z.mul_1_r. - change (IZR (Z.pow_pos _ _)) with (bpow radix2 (Z.pos (Z.to_pos prec))). - rewrite Z2Pos.id; [|exact prec_gt_0_]. - change 2%R with (bpow radix2 1); rewrite <-bpow_plus. - f_equal; ring. } - unfold x' at 1; unfold B2R at 1; unfold F2R; simpl. - rewrite Hmx, <-bpow_plus; f_equal. - apply (Z.add_reg_l 1); ring_simplify; symmetry; apply mag_unique_pos. - unfold F2R; simpl; rewrite Hmx, <-bpow_plus; split. - * right; f_equal; ring. - * apply bpow_lt; lia. - + rewrite (proj1 Hulp). - assert (H : ulp radix2 fexp (B2R x') - = bpow radix2 (fexp (mag radix2 (B2R x') - 1))); - [|rewrite H; clear H]. - { unfold ulp; rewrite Req_bool_false; [|now simpl]. - unfold cexp; f_equal. - assert (H : (mag radix2 (B2R x') <= emin + prec)%Z). - { assert (Hcm : canonical_mantissa mx ex = true). - { now generalize Hmex; unfold bounded; rewrite Bool.andb_true_iff. } - apply (canonical_canonical_mantissa false) in Hcm. - revert Hcm; fold emin; unfold canonical, cexp; simpl. - change (F2R _) with (B2R x'); intro Hex. - apply Z.nlt_ge; intro H'; apply Hd. - apply Pos2Z.inj_pos; rewrite shift_pos_correct, Z.mul_1_r. - apply eq_IZR; change (IZR (Z.pow_pos _ _)) - with (bpow radix2 (Z.pos (Z.to_pos prec))). - rewrite Z2Pos.id; [|exact prec_gt_0_]. - change (Z.pos mx~0) with (2 * Z.pos mx)%Z. - rewrite Z.mul_comm, mult_IZR. - apply (Rmult_eq_reg_r (bpow radix2 (ex - 1))); - [|apply Rgt_not_eq, bpow_gt_0]. - change 2%R with (bpow radix2 1); rewrite Rmult_assoc, <-!bpow_plus. - replace (1 + _)%Z with ex by ring. - unfold B2R at 1, F2R in Hpred; simpl in Hpred; rewrite Hpred. - change (F2R _) with (B2R x'); rewrite Hex. - unfold fexp, FLT_exp; rewrite Z.max_l; [f_equal; ring|lia]. } - now unfold fexp, FLT_exp; do 2 (rewrite Z.max_r; [|lia]). } - replace (_ - _)%R with (pred_pos radix2 fexp (B2R x')). - * rewrite round_generic; [reflexivity|apply valid_rnd_N|]. - apply generic_format_pred_pos; - [now apply FLT_exp_valid| |change xr with (B2R x') in Nzxr; lra]. - apply generic_format_B2R. - * now unfold pred_pos; rewrite Req_bool_true. - + rewrite (proj1 Hulp). - replace (_ - _)%R with (pred_pos radix2 fexp (B2R x')). - * rewrite round_generic; [reflexivity|now apply valid_rnd_N|]. - apply generic_format_pred_pos; - [now apply FLT_exp_valid|apply generic_format_B2R|]. - change xr with (B2R x') in Nzxr; lra. - * now unfold pred_pos; rewrite Req_bool_false. -Qed. - -Definition Bsucc succ_nan x := - match x with - | B754_zero _ => Bldexp mode_NE Bone emin - | B754_infinity false => x - | B754_infinity true => Bopp succ_nan Bmax_float - | B754_nan _ _ _ => build_nan (succ_nan x) - | B754_finite false _ _ _ => - Bplus (fun _ => succ_nan) mode_NE x (Bulp x) - | B754_finite true _ _ _ => - Bopp succ_nan (Bpred_pos succ_nan (Bopp succ_nan x)) - end. +Definition Bsucc (x : binary_float) : binary_float. +Proof. +apply (lift x (Bsucc (B2BSN x))). +rewrite <- is_nan_B2BSN. +apply is_nan_Bsucc. +Defined. Lemma Bsucc_correct : - forall succ_nan x, + forall x, is_finite x = true -> if Rlt_bool (succ radix2 fexp (B2R x)) (bpow radix2 emax) then - B2R (Bsucc succ_nan x) = succ radix2 fexp (B2R x) /\ - is_finite (Bsucc succ_nan x) = true /\ - (Bsign (Bsucc succ_nan x) = Bsign x && is_finite_strict x)%bool + B2R (Bsucc x) = succ radix2 fexp (B2R x) /\ + is_finite (Bsucc x) = true /\ + (Bsign (Bsucc x) = Bsign x && is_finite_strict x)%bool else - B2FF (Bsucc succ_nan x) = F754_infinity false. -Proof. -assert (Hsucc : succ radix2 fexp 0 = bpow radix2 emin). -{ unfold succ; rewrite Rle_bool_true; [|now right]; rewrite Rplus_0_l. - unfold ulp; rewrite Req_bool_true; [|now simpl]. - destruct (negligible_exp_FLT emin prec) as (n, (Hne, Hn)). - now unfold fexp; rewrite Hne; unfold FLT_exp; rewrite Z.max_r; - [|unfold Prec_gt_0 in prec_gt_0_; lia]. } -intros succ_nan [s|s|s pl Hpl|sx mx ex Hmex]; try discriminate; intros _. -- generalize (Bldexp_correct mode_NE Bone emin); unfold Bsucc; simpl. - assert (Hbemin : round radix2 fexp ZnearestE (bpow radix2 emin) - = bpow radix2 emin). - { rewrite round_generic; [reflexivity|apply valid_rnd_N|]. - apply generic_format_bpow. - unfold fexp, FLT_exp; rewrite Z.max_r; [now simpl|]. - unfold Prec_gt_0 in prec_gt_0_; lia. } - rewrite Hsucc, Rlt_bool_true. - + intros (Hr, (Hf, Hs)); rewrite Hr, Hf, Hs. - rewrite Bone_correct, Rmult_1_l, is_finite_Bone, Bsign_Bone. - case Rlt_bool_spec; intro Hover. - * now rewrite Bool.andb_false_r. - * exfalso; revert Hover; apply Rlt_not_le, bpow_lt. - unfold emin; unfold Prec_gt_0 in prec_gt_0_; lia. - + rewrite Bone_correct, Rmult_1_l, Hbemin, Rabs_pos_eq; [|apply bpow_ge_0]. - apply bpow_lt; unfold emin; unfold Prec_gt_0 in prec_gt_0_; lia. -- unfold Bsucc; case sx. - + case Rlt_bool_spec; intro Hover. - * rewrite B2R_Bopp; simpl (Bopp _ (B754_finite _ _ _ _)). - rewrite is_finite_Bopp. - set (ox := B754_finite false mx ex Hmex). - assert (Hpred := Bpred_pos_correct succ_nan ox). - assert (Hox : (0 < B2R ox)%R); [|specialize (Hpred Hox); clear Hox]. - { now apply Rmult_lt_0_compat; [apply IZR_lt|apply bpow_gt_0]. } - rewrite (proj1 Hpred), (proj1 (proj2 Hpred)). - unfold succ; rewrite Rle_bool_false; [split; [|split]|]. - { now unfold B2R, F2R, ox; simpl; rewrite Ropp_mult_distr_l, <-opp_IZR. } - { now simpl. } - { simpl (Bsign (B754_finite _ _ _ _)); simpl (true && _)%bool. - rewrite Bsign_Bopp, (proj2 (proj2 Hpred)); [now simpl|]. - now destruct Hpred as (_, (H, _)); revert H; case (Bpred_pos _ _). } - unfold B2R, F2R; simpl; change (Z.neg mx) with (- Z.pos mx)%Z. - rewrite opp_IZR, <-Ropp_mult_distr_l, <-Ropp_0; apply Ropp_lt_contravar. - now apply Rmult_lt_0_compat; [apply IZR_lt|apply bpow_gt_0]. - * exfalso; revert Hover; apply Rlt_not_le. - apply (Rle_lt_trans _ (succ radix2 fexp 0)). - { apply succ_le; [now apply FLT_exp_valid|apply generic_format_B2R| - apply generic_format_0|]. - unfold B2R, F2R; simpl; change (Z.neg mx) with (- Z.pos mx)%Z. - rewrite opp_IZR, <-Ropp_mult_distr_l, <-Ropp_0; apply Ropp_le_contravar. - now apply Rmult_le_pos; [apply IZR_le|apply bpow_ge_0]. } - rewrite Hsucc; apply bpow_lt. - unfold emin; unfold Prec_gt_0 in prec_gt_0_; lia. - + set (x := B754_finite _ _ _ _). - set (plus_nan := fun _ => succ_nan). - assert (Hulp := Bulp_correct x (eq_refl _)). - assert (Hplus := Bplus_correct plus_nan mode_NE x (Bulp x) (eq_refl _)). - rewrite (proj1 (proj2 Hulp)) in Hplus; specialize (Hplus (eq_refl _)). - assert (Px : (0 <= B2R x)%R). - { now apply Rmult_le_pos; [apply IZR_le|apply bpow_ge_0]. } - assert (Hsucc' : (succ radix2 fexp (B2R x) - = B2R x + ulp radix2 fexp (B2R x))%R). - { now unfold succ; rewrite (Rle_bool_true _ _ Px). } - rewrite (proj1 Hulp), <- Hsucc' in Hplus. - rewrite round_generic in Hplus; - [|apply valid_rnd_N| now apply generic_format_succ; - [apply FLT_exp_valid|apply generic_format_B2R]]. - rewrite Rabs_pos_eq in Hplus; [|apply (Rle_trans _ _ _ Px), succ_ge_id]. - revert Hplus; case Rlt_bool_spec; intros Hover Hplus. - * split; [now simpl|split; [now simpl|]]. - rewrite (proj2 (proj2 Hplus)); case Rcompare_spec. - { intro H; exfalso; revert H. - apply Rle_not_lt, (Rle_trans _ _ _ Px), succ_ge_id. } - { intro H; exfalso; revert H; apply Rgt_not_eq, Rlt_gt. - apply (Rlt_le_trans _ (B2R x)); [|apply succ_ge_id]. - now apply Rmult_lt_0_compat; [apply IZR_lt|apply bpow_gt_0]. } - now simpl. - * now rewrite (proj1 Hplus). -Qed. - -Definition Bpred pred_nan x := - Bopp pred_nan (Bsucc pred_nan (Bopp pred_nan x)). + B2FF (Bsucc x) = F754_infinity false. +Proof. +intros x Fx. +rewrite <- is_finite_B2BSN in Fx. +generalize (Bsucc_correct prec emax _ _ _ Fx). +replace (BSN.Bsucc (B2BSN x)) with (B2BSN (Bsucc x)) by apply B2BSN_lift. +rewrite 2!B2R_B2BSN. +destruct Rlt_bool. +- rewrite (Bsign_B2BSN x) by now destruct x. + rewrite is_finite_strict_B2BSN. + now destruct Bsucc. +- now destruct Bsucc as [|[|]| |]. +Qed. + +Definition Bpred (x : binary_float) : binary_float. +Proof. +apply (lift x (Bpred (B2BSN x))). +rewrite <- is_nan_B2BSN. +apply is_nan_Bpred. +Defined. Lemma Bpred_correct : - forall pred_nan x, + forall x, is_finite x = true -> if Rlt_bool (- bpow radix2 emax) (pred radix2 fexp (B2R x)) then - B2R (Bpred pred_nan x) = pred radix2 fexp (B2R x) /\ - is_finite (Bpred pred_nan x) = true /\ - (Bsign (Bpred pred_nan x) = Bsign x || negb (is_finite_strict x))%bool + B2R (Bpred x) = pred radix2 fexp (B2R x) /\ + is_finite (Bpred x) = true /\ + (Bsign (Bpred x) = Bsign x || negb (is_finite_strict x))%bool else - B2FF (Bpred pred_nan x) = F754_infinity true. -Proof. -intros pred_nan x Fx. -assert (Fox : is_finite (Bopp pred_nan x) = true). -{ now rewrite is_finite_Bopp. } -rewrite <-(Ropp_involutive (B2R x)), <-(B2R_Bopp pred_nan). -rewrite pred_opp, Rlt_bool_opp. -generalize (Bsucc_correct pred_nan _ Fox). -case (Rlt_bool _ _). -- intros (HR, (HF, HS)); unfold Bpred. - rewrite B2R_Bopp, HR, is_finite_Bopp. - rewrite <-(Bool.negb_involutive (Bsign x)), <-Bool.negb_andb. - split; [reflexivity|split; [exact HF|]]. - replace (is_finite_strict x) with (is_finite_strict (Bopp pred_nan x)); - [|now case x; try easy; intros s pl Hpl; simpl; - rewrite is_finite_strict_build_nan]. - rewrite Bsign_Bopp, <-(Bsign_Bopp pred_nan x), HS. - + now simpl. - + now revert Fx; case x. - + now revert HF; case (Bsucc _ _). -- now unfold Bpred; case (Bsucc _ _); intro s; case s. + B2FF (Bpred x) = F754_infinity true. +Proof. +intros x Fx. +rewrite <- is_finite_B2BSN in Fx. +generalize (Bpred_correct prec emax _ _ _ Fx). +replace (BSN.Bpred (B2BSN x)) with (B2BSN (Bpred x)) by apply B2BSN_lift. +rewrite 2!B2R_B2BSN. +destruct Rlt_bool. +- rewrite (Bsign_B2BSN x) by now destruct x. + rewrite is_finite_strict_B2BSN. + now destruct Bpred. +- now destruct Bpred as [|[|]| |]. Qed. End Binary. diff --git a/flocq/IEEE754/BinarySingleNaN.v b/flocq/IEEE754/BinarySingleNaN.v new file mode 100644 index 00000000..2dd5c3c6 --- /dev/null +++ b/flocq/IEEE754/BinarySingleNaN.v @@ -0,0 +1,3421 @@ +(** +This file is part of the Flocq formalization of floating-point +arithmetic in Coq: http://flocq.gforge.inria.fr/ + +Copyright (C) 2010-2018 Sylvie Boldo +#
# +Copyright (C) 2010-2018 Guillaume Melquiond + +This library is free software; 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; either +version 3 of the License, or (at your option) any later version. + +This library 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 +COPYING file for more details. +*) + +(** * IEEE-754 arithmetic *) + +From Coq Require Import ZArith Reals Psatz SpecFloat. + +Require Import Core Round Bracket Operations Div Sqrt Relative. + +Definition SF2R beta x := + match x with + | S754_finite s m e => F2R (Float beta (cond_Zopp s (Zpos m)) e) + | _ => 0%R + end. + +Class Prec_lt_emax prec emax := prec_lt_emax : (prec < emax)%Z. +Arguments prec_lt_emax prec emax {Prec_lt_emax}. + +Section Binary. + +(** [prec] is the number of bits of the mantissa including the implicit one; + [emax] is the exponent of the infinities. + For instance, binary32 is defined by [prec = 24] and [emax = 128]. *) +Variable prec emax : Z. +Context (prec_gt_0_ : Prec_gt_0 prec). +Context (prec_lt_emax_ : Prec_lt_emax prec emax). + +Notation emin := (emin prec emax). +Notation fexp := (fexp prec emax). +Instance fexp_correct : Valid_exp fexp := FLT_exp_valid emin prec. +Instance fexp_monotone : Monotone_exp fexp := FLT_exp_monotone emin prec. + +Notation canonical_mantissa := (canonical_mantissa prec emax). + +Notation bounded := (SpecFloat.bounded prec emax). + +Notation valid_binary := (valid_binary prec emax). + +(** Basic type used for representing binary FP numbers. + Note that there is exactly one such object per FP datum. *) + +Inductive binary_float := + | B754_zero (s : bool) + | B754_infinity (s : bool) + | B754_nan : binary_float + | B754_finite (s : bool) (m : positive) (e : Z) : + bounded m e = true -> binary_float. + +Definition SF2B x := + match x as x return valid_binary x = true -> binary_float with + | S754_finite s m e => B754_finite s m e + | S754_infinity s => fun _ => B754_infinity s + | S754_zero s => fun _ => B754_zero s + | S754_nan => fun _ => B754_nan + end. + +Definition B2SF x := + match x with + | B754_finite s m e _ => S754_finite s m e + | B754_infinity s => S754_infinity s + | B754_zero s => S754_zero s + | B754_nan => S754_nan + end. + +Definition B2R f := + match f with + | B754_finite s m e _ => F2R (Float radix2 (cond_Zopp s (Zpos m)) e) + | _ => 0%R + end. + +Theorem SF2R_B2SF : + forall x, + SF2R radix2 (B2SF x) = B2R x. +Proof. +now intros [sx|sx| |sx mx ex Hx]. +Qed. + +Theorem B2SF_SF2B : + forall x Hx, + B2SF (SF2B x Hx) = x. +Proof. +now intros [sx|sx| |sx mx ex] Hx. +Qed. + +Theorem valid_binary_B2SF : + forall x, + valid_binary (B2SF x) = true. +Proof. +now intros [sx|sx| |sx mx ex Hx]. +Qed. + +Theorem SF2B_B2SF : + forall x H, + SF2B (B2SF x) H = x. +Proof. +intros [sx|sx| |sx mx ex Hx] H ; try easy. +apply f_equal, eqbool_irrelevance. +Qed. + +Theorem SF2B_B2SF_valid : + forall x, + SF2B (B2SF x) (valid_binary_B2SF x) = x. +Proof. +intros x. +apply SF2B_B2SF. +Qed. + +Theorem B2R_SF2B : + forall x Hx, + B2R (SF2B x Hx) = SF2R radix2 x. +Proof. +now intros [sx|sx| |sx mx ex] Hx. +Qed. + +Theorem match_SF2B : + forall {T} fz fi fn ff x Hx, + match SF2B x Hx return T with + | B754_zero sx => fz sx + | B754_infinity sx => fi sx + | B754_nan => fn + | B754_finite sx mx ex _ => ff sx mx ex + end = + match x with + | S754_zero sx => fz sx + | S754_infinity sx => fi sx + | S754_nan => fn + | S754_finite sx mx ex => ff sx mx ex + end. +Proof. +now intros T fz fi fn ff [sx|sx| |sx mx ex] Hx. +Qed. + +Theorem canonical_canonical_mantissa : + forall (sx : bool) mx ex, + canonical_mantissa mx ex = true -> + canonical radix2 fexp (Float radix2 (cond_Zopp sx (Zpos mx)) ex). +Proof. +intros sx mx ex H. +assert (Hx := Zeq_bool_eq _ _ H). clear H. +apply sym_eq. +simpl. +pattern ex at 2 ; rewrite <- Hx. +apply (f_equal fexp). +rewrite mag_F2R_Zdigits. +rewrite <- Zdigits_abs. +rewrite Zpos_digits2_pos. +now case sx. +now case sx. +Qed. + +Theorem generic_format_B2R : + forall x, + generic_format radix2 fexp (B2R x). +Proof. +intros [sx|sx| |sx mx ex Hx] ; try apply generic_format_0. +simpl. +apply generic_format_canonical. +apply canonical_canonical_mantissa. +now destruct (andb_prop _ _ Hx) as (H, _). +Qed. + +Theorem FLT_format_B2R : + forall x, + FLT_format radix2 emin prec (B2R x). +Proof with auto with typeclass_instances. +intros x. +apply FLT_format_generic... +apply generic_format_B2R. +Qed. + +Theorem B2SF_inj : + forall x y : binary_float, + B2SF x = B2SF y -> + x = y. +Proof. +intros [sx|sx| |sx mx ex Hx] [sy|sy| |sy my ey Hy] ; try easy. +(* *) +intros H. +now inversion H. +(* *) +intros H. +now inversion H. +(* *) +intros H. +inversion H. +clear H. +revert Hx. +rewrite H2, H3. +intros Hx. +apply f_equal, eqbool_irrelevance. +Qed. + +Definition is_finite_strict f := + match f with + | B754_finite _ _ _ _ => true + | _ => false + end. + +Definition is_finite_strict_SF f := + match f with + | S754_finite _ _ _ => true + | _ => false + end. + +Theorem is_finite_strict_B2R : + forall x, + B2R x <> 0%R -> + is_finite_strict x = true. +Proof. +now intros [sx|sx| |sx mx ex Bx] Hx. +Qed. + +Theorem is_finite_strict_SF2B : + forall x Hx, + is_finite_strict (SF2B x Hx) = is_finite_strict_SF x. +Proof. +now intros [sx|sx| |sx mx ex] Hx. +Qed. + +Theorem B2R_inj: + forall x y : binary_float, + is_finite_strict x = true -> + is_finite_strict y = true -> + B2R x = B2R y -> + x = y. +Proof. +intros [sx|sx| |sx mx ex Hx] [sy|sy| |sy my ey Hy] ; try easy. +simpl. +intros _ _ Heq. +assert (Hs: sx = sy). +(* *) +revert Heq. clear. +case sx ; case sy ; try easy ; + intros Heq ; apply False_ind ; revert Heq. +apply Rlt_not_eq. +apply Rlt_trans with R0. +now apply F2R_lt_0. +now apply F2R_gt_0. +apply Rgt_not_eq. +apply Rgt_trans with R0. +now apply F2R_gt_0. +now apply F2R_lt_0. +assert (mx = my /\ ex = ey). +(* *) +refine (_ (canonical_unique _ fexp _ _ _ _ Heq)). +rewrite Hs. +now case sy ; intro H ; injection H ; split. +apply canonical_canonical_mantissa. +exact (proj1 (andb_prop _ _ Hx)). +apply canonical_canonical_mantissa. +exact (proj1 (andb_prop _ _ Hy)). +(* *) +revert Hx. +rewrite Hs, (proj1 H), (proj2 H). +intros Hx. +apply f_equal. +apply eqbool_irrelevance. +Qed. + +Definition Bsign x := + match x with + | B754_nan => false + | B754_zero s => s + | B754_infinity s => s + | B754_finite s _ _ _ => s + end. + +Definition sign_SF x := + match x with + | S754_nan => false + | S754_zero s => s + | S754_infinity s => s + | S754_finite s _ _ => s + end. + +Theorem Bsign_SF2B : + forall x H, + Bsign (SF2B x H) = sign_SF x. +Proof. +now intros [sx|sx| |sx mx ex] H. +Qed. + +Definition is_finite f := + match f with + | B754_finite _ _ _ _ => true + | B754_zero _ => true + | _ => false + end. + +Definition is_finite_SF f := + match f with + | S754_finite _ _ _ => true + | S754_zero _ => true + | _ => false + end. + +Theorem is_finite_SF2B : + forall x Hx, + is_finite (SF2B x Hx) = is_finite_SF x. +Proof. +now intros [| | |]. +Qed. + +Theorem is_finite_SF_B2SF : + forall x, + is_finite_SF (B2SF x) = is_finite x. +Proof. +now intros [| | |]. +Qed. + +Theorem B2R_Bsign_inj: + forall x y : binary_float, + is_finite x = true -> + is_finite y = true -> + B2R x = B2R y -> + Bsign x = Bsign y -> + x = y. +Proof. +intros. destruct x, y; try (apply B2R_inj; now eauto). +- simpl in H2. congruence. +- symmetry in H1. apply Rmult_integral in H1. + destruct H1. apply (eq_IZR _ 0) in H1. destruct s0; discriminate H1. + simpl in H1. pose proof (bpow_gt_0 radix2 e). + rewrite H1 in H3. apply Rlt_irrefl in H3. destruct H3. +- apply Rmult_integral in H1. + destruct H1. apply (eq_IZR _ 0) in H1. destruct s; discriminate H1. + simpl in H1. pose proof (bpow_gt_0 radix2 e). + rewrite H1 in H3. apply Rlt_irrefl in H3. destruct H3. +Qed. + +Definition is_nan f := + match f with + | B754_nan => true + | _ => false + end. + +Definition is_nan_SF f := + match f with + | S754_nan => true + | _ => false + end. + +Theorem is_nan_SF2B : + forall x Hx, + is_nan (SF2B x Hx) = is_nan_SF x. +Proof. +now intros [| | |]. +Qed. + +Theorem is_nan_SF_B2SF : + forall x, + is_nan_SF (B2SF x) = is_nan x. +Proof. +now intros [| | |]. +Qed. + +Definition erase (x : binary_float) : binary_float. +Proof. +destruct x as [s|s| |s m e H]. +- exact (B754_zero s). +- exact (B754_infinity s). +- exact B754_nan. +- apply (B754_finite s m e). + destruct bounded. + apply eq_refl. + exact H. +Defined. + +Theorem erase_correct : + forall x, erase x = x. +Proof. +destruct x as [s|s| |s m e H] ; try easy ; simpl. +- apply f_equal, eqbool_irrelevance. +Qed. + +(** Opposite *) + +Definition Bopp x := + match x with + | B754_nan => x + | B754_infinity sx => B754_infinity (negb sx) + | B754_finite sx mx ex Hx => B754_finite (negb sx) mx ex Hx + | B754_zero sx => B754_zero (negb sx) + end. + +Theorem Bopp_involutive : + forall x, + Bopp (Bopp x) = x. +Proof. +now intros [sx|sx| |sx mx ex Hx] ; simpl ; try rewrite Bool.negb_involutive. +Qed. + +Theorem B2R_Bopp : + forall x, + B2R (Bopp x) = (- B2R x)%R. +Proof. +intros [sx|sx| |sx mx ex Hx]; apply sym_eq ; try apply Ropp_0. +simpl. +rewrite <- F2R_opp. +now case sx. +Qed. + +Theorem is_nan_Bopp : + forall x, + is_nan (Bopp x) = is_nan x. +Proof. +now intros [| | |]. +Qed. + +Theorem is_finite_Bopp : + forall x, + is_finite (Bopp x) = is_finite x. +Proof. +now intros [| | |]. +Qed. + +Theorem is_finite_strict_Bopp : + forall x, + is_finite_strict (Bopp x) = is_finite_strict x. +Proof. +now intros [| | |]. +Qed. + +Lemma Bsign_Bopp : + forall x, is_nan x = false -> Bsign (Bopp x) = negb (Bsign x). +Proof. now intros [s|s| |s m e H]. Qed. + +(** Absolute value *) + +Definition Babs (x : binary_float) : binary_float := + match x with + | B754_nan => x + | B754_infinity sx => B754_infinity false + | B754_finite sx mx ex Hx => B754_finite false mx ex Hx + | B754_zero sx => B754_zero false + end. + +Theorem B2R_Babs : + forall x, + B2R (Babs x) = Rabs (B2R x). +Proof. +intros [sx|sx| |sx mx ex Hx]; apply sym_eq ; try apply Rabs_R0. +simpl. rewrite <- F2R_abs. now destruct sx. +Qed. + +Theorem is_nan_Babs : + forall x, + is_nan (Babs x) = is_nan x. +Proof. +now intros [| | |]. +Qed. + +Theorem is_finite_Babs : + forall x, + is_finite (Babs x) = is_finite x. +Proof. +now intros [| | |]. +Qed. + +Theorem is_finite_strict_Babs : + forall x, + is_finite_strict (Babs x) = is_finite_strict x. +Proof. +now intros [| | |]. +Qed. + +Theorem Bsign_Babs : + forall x, + Bsign (Babs x) = false. +Proof. +now intros [| | |]. +Qed. + +Theorem Babs_idempotent : + forall (x: binary_float), + Babs (Babs x) = Babs x. +Proof. +now intros [sx|sx| |sx mx ex Hx]. +Qed. + +Theorem Babs_Bopp : + forall x, + Babs (Bopp x) = Babs x. +Proof. +now intros [| | |]. +Qed. + +(** Comparison + +[Some c] means ordered as per [c]; [None] means unordered. *) + +Definition Bcompare (f1 f2 : binary_float) : option comparison := + SFcompare (B2SF f1) (B2SF f2). + +Theorem Bcompare_correct : + forall f1 f2, + is_finite f1 = true -> is_finite f2 = true -> + Bcompare f1 f2 = Some (Rcompare (B2R f1) (B2R f2)). +Proof. + Ltac apply_Rcompare := + match goal with + | [ |- Lt = Rcompare _ _ ] => symmetry; apply Rcompare_Lt + | [ |- Eq = Rcompare _ _ ] => symmetry; apply Rcompare_Eq + | [ |- Gt = Rcompare _ _ ] => symmetry; apply Rcompare_Gt + end. + unfold Bcompare, SFcompare; intros f1 f2 H1 H2. + destruct f1, f2; try easy; apply f_equal; clear H1 H2. + now rewrite Rcompare_Eq. + destruct s0 ; apply_Rcompare. + now apply F2R_lt_0. + now apply F2R_gt_0. + destruct s ; apply_Rcompare. + now apply F2R_lt_0. + now apply F2R_gt_0. + simpl. + apply andb_prop in e0; destruct e0; apply (canonical_canonical_mantissa false) in H. + apply andb_prop in e2; destruct e2; apply (canonical_canonical_mantissa false) in H1. + pose proof (Zcompare_spec e e1); unfold canonical, Fexp in H1, H. + assert (forall m1 m2 e1 e2, + let x := (IZR (Zpos m1) * bpow radix2 e1)%R in + let y := (IZR (Zpos m2) * bpow radix2 e2)%R in + (cexp radix2 fexp x < cexp radix2 fexp y)%Z -> (x < y)%R). + { + intros; apply Rnot_le_lt; intro; apply (mag_le radix2) in H5. + apply Zlt_not_le with (1 := H4). + now apply fexp_monotone. + now apply (F2R_gt_0 _ (Float radix2 (Zpos m2) e2)). + } + assert (forall m1 m2 e1 e2, (IZR (- Zpos m1) * bpow radix2 e1 < IZR (Zpos m2) * bpow radix2 e2)%R). + { + intros; apply (Rlt_trans _ 0%R). + now apply (F2R_lt_0 _ (Float radix2 (Zneg m1) e0)). + now apply (F2R_gt_0 _ (Float radix2 (Zpos m2) e2)). + } + unfold F2R, Fnum, Fexp. + destruct s, s0; try (now apply_Rcompare; apply H5); inversion H3; + try (apply_Rcompare; apply H4; rewrite H, H1 in H7; assumption); + try (apply_Rcompare; do 2 rewrite opp_IZR, Ropp_mult_distr_l_reverse; + apply Ropp_lt_contravar; apply H4; rewrite H, H1 in H7; assumption); + rewrite H7, Rcompare_mult_r, Rcompare_IZR by (apply bpow_gt_0); reflexivity. +Qed. + +Theorem Bcompare_swap : + forall x y, + Bcompare y x = match Bcompare x y with Some c => Some (CompOpp c) | None => None end. +Proof. + intros. + unfold Bcompare. + destruct x as [ ? | [] | | [] mx ex Bx ]; + destruct y as [ ? | [] | | [] my ey By ]; simpl; try easy. +- rewrite <- (Zcompare_antisym ex ey). destruct (ex ?= ey)%Z; try easy. + now rewrite (Pcompare_antisym mx my). +- rewrite <- (Zcompare_antisym ex ey). destruct (ex ?= ey)%Z; try easy. + now rewrite Pcompare_antisym. +Qed. + +Definition Beqb (f1 f2 : binary_float) : bool := SFeqb (B2SF f1) (B2SF f2). + +Theorem Beqb_correct : + forall f1 f2, + is_finite f1 = true -> is_finite f2 = true -> + Beqb f1 f2 = Req_bool (B2R f1) (B2R f2). +Proof. +intros f1 f2 F1 F2. +generalize (Bcompare_correct _ _ F1 F2). +unfold Beqb, SFeqb, Bcompare. +intros ->. +case Rcompare_spec; intro H; case Req_bool_spec; intro H'; try reflexivity; lra. +Qed. + +Definition Bltb (f1 f2 : binary_float) : bool := SFltb (B2SF f1) (B2SF f2). + +Theorem Bltb_correct : + forall f1 f2, + is_finite f1 = true -> is_finite f2 = true -> + Bltb f1 f2 = Rlt_bool (B2R f1) (B2R f2). +Proof. +intros f1 f2 F1 F2. +generalize (Bcompare_correct _ _ F1 F2). +unfold Bltb, SFltb, Bcompare. +intros ->. +case Rcompare_spec; intro H; case Rlt_bool_spec; intro H'; try reflexivity; lra. +Qed. + +Definition Bleb (f1 f2 : binary_float) : bool := SFleb (B2SF f1) (B2SF f2). + +Theorem Bleb_correct : + forall f1 f2, + is_finite f1 = true -> is_finite f2 = true -> + Bleb f1 f2 = Rle_bool (B2R f1) (B2R f2). +Proof. +intros f1 f2 F1 F2. +generalize (Bcompare_correct _ _ F1 F2). +unfold Bleb, SFleb, Bcompare. +intros ->. +case Rcompare_spec; intro H; case Rle_bool_spec; intro H'; try reflexivity; lra. +Qed. + +Theorem bounded_le_emax_minus_prec : + forall mx ex, + bounded mx ex = true -> + (F2R (Float radix2 (Zpos mx) ex) + <= bpow radix2 emax - bpow radix2 (emax - prec))%R. +Proof. +intros mx ex Hx. +destruct (andb_prop _ _ Hx) as (H1,H2). +generalize (Zeq_bool_eq _ _ H1). clear H1. intro H1. +generalize (Zle_bool_imp_le _ _ H2). clear H2. intro H2. +generalize (mag_F2R_Zdigits radix2 (Zpos mx) ex). +destruct (mag radix2 (F2R (Float radix2 (Zpos mx) ex))) as (e',Ex). +unfold mag_val. +intros H. +elim Ex; [|now apply Rgt_not_eq, F2R_gt_0]; intros _. +rewrite <-F2R_Zabs; simpl; clear Ex; intros Ex. +generalize (Rmult_lt_compat_r (bpow radix2 (-ex)) _ _ (bpow_gt_0 _ _) Ex). +unfold F2R; simpl; rewrite Rmult_assoc, <-!bpow_plus. +rewrite H; [|intro H'; discriminate H']. +rewrite <-Z.add_assoc, Z.add_opp_diag_r, Z.add_0_r, Rmult_1_r. +rewrite <-(IZR_Zpower _ _ (Zdigits_ge_0 _ _)); clear Ex; intro Ex. +generalize (Zlt_le_succ _ _ (lt_IZR _ _ Ex)); clear Ex; intro Ex. +generalize (IZR_le _ _ Ex). +rewrite succ_IZR; clear Ex; intro Ex. +generalize (Rplus_le_compat_r (-1) _ _ Ex); clear Ex; intro Ex. +ring_simplify in Ex; revert Ex. +rewrite (IZR_Zpower _ _ (Zdigits_ge_0 _ _)); intro Ex. +generalize (Rmult_le_compat_r (bpow radix2 ex) _ _ (bpow_ge_0 _ _) Ex). +intro H'; apply (Rle_trans _ _ _ H'). +rewrite Rmult_minus_distr_r, Rmult_1_l, <-bpow_plus. +revert H1; unfold fexp, FLT_exp; intro H1. +generalize (Z.le_max_l (Z.pos (digits2_pos mx) + ex - prec) emin). + +rewrite H1; intro H1'. +generalize (proj1 (Z.le_sub_le_add_r _ _ _) H1'). +rewrite Zpos_digits2_pos; clear H1'; intro H1'. +apply (Rle_trans _ _ _ (Rplus_le_compat_r _ _ _ (bpow_le _ _ _ H1'))). +replace emax with (emax - prec - ex + (ex + prec))%Z at 1 by ring. +replace (emax - prec)%Z with (emax - prec - ex + ex)%Z at 2 by ring. +do 2 rewrite (bpow_plus _ (emax - prec - ex)). +rewrite <-Rmult_minus_distr_l. +rewrite <-(Rmult_1_l (_ + _)). +apply Rmult_le_compat_r. +{ apply Rle_0_minus, bpow_le; unfold Prec_gt_0 in prec_gt_0_; lia. } +change 1%R with (bpow radix2 0); apply bpow_le; lia. +Qed. + +Theorem bounded_lt_emax : + forall mx ex, + bounded mx ex = true -> + (F2R (Float radix2 (Zpos mx) ex) < bpow radix2 emax)%R. +Proof. +intros mx ex Hx. +destruct (andb_prop _ _ Hx) as (H1,H2). +generalize (Zeq_bool_eq _ _ H1). clear H1. intro H1. +generalize (Zle_bool_imp_le _ _ H2). clear H2. intro H2. +generalize (mag_F2R_Zdigits radix2 (Zpos mx) ex). +destruct (mag radix2 (F2R (Float radix2 (Zpos mx) ex))) as (e',Ex). +unfold mag_val. +intros H. +apply Rlt_le_trans with (bpow radix2 e'). +change (Zpos mx) with (Z.abs (Zpos mx)). +rewrite F2R_Zabs. +apply Ex. +apply Rgt_not_eq. +now apply F2R_gt_0. +apply bpow_le. +rewrite H. 2: discriminate. +revert H1. clear -H2. +rewrite Zpos_digits2_pos. +unfold fexp, FLT_exp. +intros ; lia. +Qed. + +Theorem bounded_ge_emin : + forall mx ex, + bounded mx ex = true -> + (bpow radix2 emin <= F2R (Float radix2 (Zpos mx) ex))%R. +Proof. +intros mx ex Hx. +destruct (andb_prop _ _ Hx) as [H1 _]. +apply Zeq_bool_eq in H1. +generalize (mag_F2R_Zdigits radix2 (Zpos mx) ex). +destruct (mag radix2 (F2R (Float radix2 (Zpos mx) ex))) as [e' Ex]. +unfold mag_val. +intros H. +assert (H0 : Zpos mx <> 0%Z) by easy. +rewrite Rabs_pos_eq in Ex by now apply F2R_ge_0. +refine (Rle_trans _ _ _ _ (proj1 (Ex _))). +2: now apply F2R_neq_0. +apply bpow_le. +rewrite H by easy. +revert H1. +rewrite Zpos_digits2_pos. +generalize (Zdigits radix2 (Zpos mx)) (Zdigits_gt_0 radix2 (Zpos mx) H0). +unfold fexp, FLT_exp. +clear -prec_gt_0_. +unfold Prec_gt_0 in prec_gt_0_. +intros ; lia. +Qed. + +Theorem abs_B2R_le_emax_minus_prec : + forall x, + (Rabs (B2R x) <= bpow radix2 emax - bpow radix2 (emax - prec))%R. +Proof. +intros [sx|sx| |sx mx ex Hx] ; simpl ; + [rewrite Rabs_R0 ; apply Rle_0_minus, bpow_le ; + revert prec_gt_0_; unfold Prec_gt_0; lia..|]. +rewrite <- F2R_Zabs, abs_cond_Zopp. +now apply bounded_le_emax_minus_prec. +Qed. + +Theorem abs_B2R_lt_emax : + forall x, + (Rabs (B2R x) < bpow radix2 emax)%R. +Proof. +intros [sx|sx| |sx mx ex Hx] ; simpl ; try ( rewrite Rabs_R0 ; apply bpow_gt_0 ). +rewrite <- F2R_Zabs, abs_cond_Zopp. +now apply bounded_lt_emax. +Qed. + +Theorem abs_B2R_ge_emin : + forall x, + is_finite_strict x = true -> + (bpow radix2 emin <= Rabs (B2R x))%R. +Proof. +intros [sx|sx| |sx mx ex Hx] ; simpl ; try discriminate. +intros; case sx; simpl. +- unfold F2R; simpl; rewrite Rabs_mult, <-abs_IZR; simpl. + rewrite Rabs_pos_eq; [|apply bpow_ge_0]. + now apply bounded_ge_emin. +- unfold F2R; simpl; rewrite Rabs_mult, <-abs_IZR; simpl. + rewrite Rabs_pos_eq; [|apply bpow_ge_0]. + now apply bounded_ge_emin. +Qed. + +Theorem bounded_canonical_lt_emax : + forall mx ex, + canonical radix2 fexp (Float radix2 (Zpos mx) ex) -> + (F2R (Float radix2 (Zpos mx) ex) < bpow radix2 emax)%R -> + bounded mx ex = true. +Proof. +intros mx ex Cx Bx. +apply andb_true_intro. +split. +unfold canonical_mantissa. +unfold canonical, Fexp in Cx. +rewrite Cx at 2. +rewrite Zpos_digits2_pos. +unfold cexp. +rewrite mag_F2R_Zdigits. 2: discriminate. +now apply -> Zeq_is_eq_bool. +apply Zle_bool_true. +unfold canonical, Fexp in Cx. +rewrite Cx. +unfold cexp, fexp, FLT_exp. +destruct (mag radix2 (F2R (Float radix2 (Zpos mx) ex))) as (e',Ex). simpl. +apply Z.max_lub. +cut (e' - 1 < emax)%Z. clear ; lia. +apply lt_bpow with radix2. +apply Rle_lt_trans with (2 := Bx). +change (Zpos mx) with (Z.abs (Zpos mx)). +rewrite F2R_Zabs. +apply Ex. +apply Rgt_not_eq. +now apply F2R_gt_0. +unfold emin. +generalize (prec_gt_0 prec) (prec_lt_emax prec emax). +clear ; lia. +Qed. + +(** Truncation *) + +Theorem shr_m_shr_record_of_loc : + forall m l, + shr_m (shr_record_of_loc m l) = m. +Proof. +now intros m [|[| |]]. +Qed. + +Theorem loc_of_shr_record_of_loc : + forall m l, + loc_of_shr_record (shr_record_of_loc m l) = l. +Proof. +now intros m [|[| |]]. +Qed. + +Lemma inbetween_shr_1 : + forall x mrs e, + (0 <= shr_m mrs)%Z -> + inbetween_float radix2 (shr_m mrs) e x (loc_of_shr_record mrs) -> + inbetween_float radix2 (shr_m (shr_1 mrs)) (e + 1) x (loc_of_shr_record (shr_1 mrs)). +Proof. +intros x mrs e Hm Hl. +refine (_ (new_location_even_correct (F2R (Float radix2 (shr_m (shr_1 mrs)) (e + 1))) (bpow radix2 e) 2 _ _ _ x (if shr_r (shr_1 mrs) then 1 else 0) (loc_of_shr_record mrs) _ _)) ; try easy. +2: apply bpow_gt_0. +2: now case (shr_r (shr_1 mrs)) ; split. +change 2%R with (bpow radix2 1). +rewrite <- bpow_plus. +rewrite (Zplus_comm 1), <- (F2R_bpow radix2 (e + 1)). +unfold inbetween_float, F2R. simpl. +rewrite plus_IZR, Rmult_plus_distr_r. +replace (Bracket.new_location_even 2 (if shr_r (shr_1 mrs) then 1%Z else 0%Z) (loc_of_shr_record mrs)) with (loc_of_shr_record (shr_1 mrs)). +easy. +clear -Hm. +destruct mrs as (m, r, s). +now destruct m as [|[m|m|]|m] ; try (now elim Hm) ; destruct r as [|] ; destruct s as [|]. +rewrite (F2R_change_exp radix2 e). +2: apply Zle_succ. +unfold F2R. simpl. +rewrite <- 2!Rmult_plus_distr_r, <- 2!plus_IZR. +rewrite Zplus_assoc. +replace (shr_m (shr_1 mrs) * 2 ^ (e + 1 - e) + (if shr_r (shr_1 mrs) then 1%Z else 0%Z))%Z with (shr_m mrs). +exact Hl. +ring_simplify (e + 1 - e)%Z. +change (2^1)%Z with 2%Z. +rewrite Zmult_comm. +clear -Hm. +destruct mrs as (m, r, s). +now destruct m as [|[m|m|]|m] ; try (now elim Hm) ; destruct r as [|] ; destruct s as [|]. +Qed. + +Theorem inbetween_shr : + forall x m e l n, + (0 <= m)%Z -> + inbetween_float radix2 m e x l -> + let '(mrs, e') := shr (shr_record_of_loc m l) e n in + inbetween_float radix2 (shr_m mrs) e' x (loc_of_shr_record mrs). +Proof. +intros x m e l n Hm Hl. +destruct n as [|n|n]. +now destruct l as [|[| |]]. +2: now destruct l as [|[| |]]. +unfold shr. +rewrite iter_pos_nat. +rewrite Zpos_eq_Z_of_nat_o_nat_of_P. +induction (nat_of_P n). +simpl. +rewrite Zplus_0_r. +now destruct l as [|[| |]]. +rewrite iter_nat_S. +rewrite inj_S. +unfold Z.succ. +rewrite Zplus_assoc. +revert IHn0. +apply inbetween_shr_1. +clear -Hm. +induction n0. +now destruct l as [|[| |]]. +rewrite iter_nat_S. +revert IHn0. +generalize (iter_nat shr_1 n0 (shr_record_of_loc m l)). +clear. +intros (m, r, s) Hm. +now destruct m as [|[m|m|]|m] ; try (now elim Hm) ; destruct r as [|] ; destruct s as [|]. +Qed. + +Notation shr_fexp := (shr_fexp prec emax). + +Theorem shr_truncate : + forall m e l, + (0 <= m)%Z -> + shr_fexp m e l = + let '(m', e', l') := truncate radix2 fexp (m, e, l) in (shr_record_of_loc m' l', e'). +Proof. +intros m e l Hm. +case_eq (truncate radix2 fexp (m, e, l)). +intros (m', e') l'. +unfold shr_fexp. +rewrite Zdigits2_Zdigits. +case_eq (fexp (Zdigits radix2 m + e) - e)%Z. +(* *) +intros He. +unfold truncate. +rewrite He. +simpl. +intros H. +now inversion H. +(* *) +intros p Hp. +assert (He: (e <= fexp (Zdigits radix2 m + e))%Z). +clear -Hp ; lia. +destruct (inbetween_float_ex radix2 m e l) as (x, Hx). +generalize (inbetween_shr x m e l (fexp (Zdigits radix2 m + e) - e) Hm Hx). +assert (Hx0 : (0 <= x)%R). +apply Rle_trans with (F2R (Float radix2 m e)). +now apply F2R_ge_0. +exact (proj1 (inbetween_float_bounds _ _ _ _ _ Hx)). +case_eq (shr (shr_record_of_loc m l) e (fexp (Zdigits radix2 m + e) - e)). +intros mrs e'' H3 H4 H1. +generalize (truncate_correct radix2 _ x m e l Hx0 Hx (or_introl _ He)). +rewrite H1. +intros (H2,_). +rewrite <- Hp, H3. +assert (e'' = e'). +change (snd (mrs, e'') = snd (fst (m',e',l'))). +rewrite <- H1, <- H3. +unfold truncate. +now rewrite Hp. +rewrite H in H4 |- *. +apply (f_equal (fun v => (v, _))). +destruct (inbetween_float_unique _ _ _ _ _ _ _ H2 H4) as (H5, H6). +rewrite H5, H6. +case mrs. +now intros m0 [|] [|]. +(* *) +intros p Hp. +unfold truncate. +rewrite Hp. +simpl. +intros H. +now inversion H. +Qed. + +(** Rounding modes *) + +Inductive mode := mode_NE | mode_ZR | mode_DN | mode_UP | mode_NA. + +Definition round_mode m := + match m with + | mode_NE => ZnearestE + | mode_ZR => Ztrunc + | mode_DN => Zfloor + | mode_UP => Zceil + | mode_NA => ZnearestA + end. + +Definition choice_mode m sx mx lx := + match m with + | mode_NE => cond_incr (round_N (negb (Z.even mx)) lx) mx + | mode_ZR => mx + | mode_DN => cond_incr (round_sign_DN sx lx) mx + | mode_UP => cond_incr (round_sign_UP sx lx) mx + | mode_NA => cond_incr (round_N true lx) mx + end. + +Global Instance valid_rnd_round_mode : forall m, Valid_rnd (round_mode m). +Proof. +destruct m ; unfold round_mode ; auto with typeclass_instances. +Qed. + +Definition overflow_to_inf m s := + match m with + | mode_NE => true + | mode_NA => true + | mode_ZR => false + | mode_UP => negb s + | mode_DN => s + end. + +Definition binary_overflow m s := + if overflow_to_inf m s then S754_infinity s + else S754_finite s (Z.to_pos (Zpower 2 prec - 1)%Z) (emax - prec). + +Theorem is_nan_binary_overflow : + forall mode s, + is_nan_SF (binary_overflow mode s) = false. +Proof. +intros mode s. +unfold binary_overflow. +now destruct overflow_to_inf. +Qed. + +Theorem binary_overflow_correct : + forall m s, + valid_binary (binary_overflow m s) = true. +Proof. +intros m s. +unfold binary_overflow. +case overflow_to_inf. +easy. +unfold valid_binary, bounded. +rewrite Zle_bool_refl. +rewrite Bool.andb_true_r. +apply Zeq_bool_true. +rewrite Zpos_digits2_pos. +replace (Zdigits radix2 _) with prec. +unfold fexp, FLT_exp, emin. +generalize (prec_gt_0 prec) (prec_lt_emax prec emax). +clear ; zify ; lia. +change 2%Z with (radix_val radix2). +assert (H: (0 < radix2 ^ prec - 1)%Z). + apply Zlt_succ_pred. + now apply Zpower_gt_1. +rewrite Z2Pos.id by exact H. +apply Zle_antisym. +- apply Z.lt_pred_le. + apply Zdigits_gt_Zpower. + rewrite Z.abs_eq by now apply Zlt_le_weak. + apply Z.lt_le_pred. + apply Zpower_lt. + now apply Zlt_le_weak. + apply Z.lt_pred_l. +- apply Zdigits_le_Zpower. + rewrite Z.abs_eq by now apply Zlt_le_weak. + apply Z.lt_pred_l. +Qed. + +Definition binary_fit_aux mode sx mx ex := + if Zle_bool ex (emax - prec) then S754_finite sx mx ex + else binary_overflow mode sx. + +Theorem binary_fit_aux_correct : + forall mode sx mx ex, + canonical_mantissa mx ex = true -> + let x := SF2R radix2 (S754_finite sx mx ex) in + let z := binary_fit_aux mode sx mx ex in + valid_binary z = true /\ + if Rlt_bool (Rabs x) (bpow radix2 emax) then + SF2R radix2 z = x /\ is_finite_SF z = true /\ sign_SF z = sx + else + z = binary_overflow mode sx. +Proof. +intros m sx mx ex Cx. +unfold binary_fit_aux. +simpl. +rewrite F2R_cond_Zopp. +rewrite abs_cond_Ropp. +rewrite Rabs_pos_eq by now apply F2R_ge_0. +destruct Zle_bool eqn:He. +- assert (Hb: bounded mx ex = true). + { unfold bounded. now rewrite Cx. } + apply (conj Hb). + rewrite Rlt_bool_true. + repeat split. + apply F2R_cond_Zopp. + now apply bounded_lt_emax. +- rewrite Rlt_bool_false. + { repeat split. + apply binary_overflow_correct. } + apply Rnot_lt_le. + intros Hx. + apply bounded_canonical_lt_emax in Hx. + revert Hx. + unfold bounded. + now rewrite Cx, He. + now apply (canonical_canonical_mantissa false). +Qed. + +Definition binary_round_aux mode sx mx ex lx := + let '(mrs', e') := shr_fexp mx ex lx in + let '(mrs'', e'') := shr_fexp (choice_mode mode sx (shr_m mrs') (loc_of_shr_record mrs')) e' loc_Exact in + match shr_m mrs'' with + | Z0 => S754_zero sx + | Zpos m => binary_fit_aux mode sx m e'' + | _ => S754_nan + end. + +Theorem binary_round_aux_correct' : + forall mode x mx ex lx, + (x <> 0)%R -> + inbetween_float radix2 mx ex (Rabs x) lx -> + (ex <= cexp radix2 fexp x)%Z -> + let z := binary_round_aux mode (Rlt_bool x 0) mx ex lx in + valid_binary z = true /\ + if Rlt_bool (Rabs (round radix2 fexp (round_mode mode) x)) (bpow radix2 emax) then + SF2R radix2 z = round radix2 fexp (round_mode mode) x /\ + is_finite_SF z = true /\ sign_SF z = Rlt_bool x 0 + else + z = binary_overflow mode (Rlt_bool x 0). +Proof with auto with typeclass_instances. +intros m x mx ex lx Px Bx Ex z. +unfold binary_round_aux in z. +revert z. +rewrite shr_truncate. +refine (_ (round_trunc_sign_any_correct' _ _ (round_mode m) (choice_mode m) _ x mx ex lx Bx (or_introl _ Ex))). +rewrite <- cexp_abs in Ex. +refine (_ (truncate_correct_partial' _ fexp _ _ _ _ _ Bx Ex)). +destruct (truncate radix2 fexp (mx, ex, lx)) as ((m1, e1), l1). +rewrite loc_of_shr_record_of_loc, shr_m_shr_record_of_loc. +set (m1' := choice_mode m (Rlt_bool x 0) m1 l1). +intros (H1a,H1b) H1c. +rewrite H1c. +assert (Hm: (m1 <= m1')%Z). +(* . *) +unfold m1', choice_mode, cond_incr. +case m ; + try apply Z.le_refl ; + match goal with |- (m1 <= if ?b then _ else _)%Z => + case b ; [ apply Zle_succ | apply Z.le_refl ] end. +assert (Hr: Rabs (round radix2 fexp (round_mode m) x) = F2R (Float radix2 m1' e1)). +(* . *) +rewrite <- (Z.abs_eq m1'). +rewrite <- (abs_cond_Zopp (Rlt_bool x 0) m1'). +rewrite F2R_Zabs. +now apply f_equal. +apply Z.le_trans with (2 := Hm). +apply Zlt_succ_le. +apply gt_0_F2R with radix2 e1. +apply Rle_lt_trans with (1 := Rabs_pos x). +exact (proj2 (inbetween_float_bounds _ _ _ _ _ H1a)). +(* . *) +assert (Br: inbetween_float radix2 m1' e1 (Rabs (round radix2 fexp (round_mode m) x)) loc_Exact). +now apply inbetween_Exact. +destruct m1' as [|m1'|m1']. +(* . m1' = 0 *) +rewrite shr_truncate. 2: apply Z.le_refl. +generalize (truncate_0 radix2 fexp e1 loc_Exact). +destruct (truncate radix2 fexp (Z0, e1, loc_Exact)) as ((m2, e2), l2). +rewrite shr_m_shr_record_of_loc. +intros Hm2. +rewrite Hm2. +repeat split. +rewrite Rlt_bool_true. +repeat split. +apply sym_eq. +case Rlt_bool ; apply F2R_0. +rewrite <- F2R_Zabs, abs_cond_Zopp, F2R_0. +apply bpow_gt_0. +(* . 0 < m1' *) +assert (He: (e1 <= fexp (Zdigits radix2 (Zpos m1') + e1))%Z). +rewrite <- mag_F2R_Zdigits, <- Hr, mag_abs. +2: discriminate. +rewrite H1b. +rewrite cexp_abs. +fold (cexp radix2 fexp (round radix2 fexp (round_mode m) x)). +apply cexp_round_ge... +rewrite H1c. +case (Rlt_bool x 0). +apply Rlt_not_eq. +now apply F2R_lt_0. +apply Rgt_not_eq. +now apply F2R_gt_0. +refine (_ (truncate_correct_partial _ _ _ _ _ _ _ Br He)). +2: now rewrite Hr ; apply F2R_gt_0. +refine (_ (truncate_correct_format radix2 fexp (Zpos m1') e1 _ _ He)). +2: discriminate. +rewrite shr_truncate. 2: easy. +destruct (truncate radix2 fexp (Zpos m1', e1, loc_Exact)) as ((m2, e2), l2). +rewrite shr_m_shr_record_of_loc. +intros (H3,H4) (H2,_). +destruct m2 as [|m2|m2]. +elim Rgt_not_eq with (2 := H3). +rewrite F2R_0. +now apply F2R_gt_0. +destruct (binary_fit_aux_correct m (Rlt_bool x 0) m2 e2) as [H5 H6]. + apply Zeq_bool_true. + rewrite Zpos_digits2_pos. + rewrite <- mag_F2R_Zdigits by easy. + now rewrite <- H3. +apply (conj H5). +revert H6. +simpl. +rewrite 2!F2R_cond_Zopp. +now rewrite <- H3. +elim Rgt_not_eq with (2 := H3). +apply Rlt_trans with R0. +now apply F2R_lt_0. +now apply F2R_gt_0. +rewrite <- Hr. +apply generic_format_abs... +apply generic_format_round... +(* . not m1' < 0 *) +elim Rgt_not_eq with (2 := Hr). +apply Rlt_le_trans with R0. +now apply F2R_lt_0. +apply Rabs_pos. +(* *) +now apply Rabs_pos_lt. +(* all the modes are valid *) +clear. case m. +exact inbetween_int_NE_sign. +exact inbetween_int_ZR_sign. +exact inbetween_int_DN_sign. +exact inbetween_int_UP_sign. +exact inbetween_int_NA_sign. +(* *) +apply inbetween_float_bounds in Bx. +apply Zlt_succ_le. +eapply gt_0_F2R. +apply Rle_lt_trans with (2 := proj2 Bx). +apply Rabs_pos. +Qed. + +Theorem binary_round_aux_correct : + forall mode x mx ex lx, + inbetween_float radix2 (Zpos mx) ex (Rabs x) lx -> + (ex <= fexp (Zdigits radix2 (Zpos mx) + ex))%Z -> + let z := binary_round_aux mode (Rlt_bool x 0) (Zpos mx) ex lx in + valid_binary z = true /\ + if Rlt_bool (Rabs (round radix2 fexp (round_mode mode) x)) (bpow radix2 emax) then + SF2R radix2 z = round radix2 fexp (round_mode mode) x /\ + is_finite_SF z = true /\ sign_SF z = Rlt_bool x 0 + else + z = binary_overflow mode (Rlt_bool x 0). +Proof with auto with typeclass_instances. +intros m x mx ex lx Bx Ex z. +unfold binary_round_aux in z. +revert z. +rewrite shr_truncate. 2: easy. +refine (_ (round_trunc_sign_any_correct _ _ (round_mode m) (choice_mode m) _ x (Zpos mx) ex lx Bx (or_introl _ Ex))). +refine (_ (truncate_correct_partial _ _ _ _ _ _ _ Bx Ex)). +destruct (truncate radix2 fexp (Zpos mx, ex, lx)) as ((m1, e1), l1). +rewrite loc_of_shr_record_of_loc, shr_m_shr_record_of_loc. +set (m1' := choice_mode m (Rlt_bool x 0) m1 l1). +intros (H1a,H1b) H1c. +rewrite H1c. +assert (Hm: (m1 <= m1')%Z). +(* . *) +unfold m1', choice_mode, cond_incr. +case m ; + try apply Z.le_refl ; + match goal with |- (m1 <= if ?b then _ else _)%Z => + case b ; [ apply Zle_succ | apply Z.le_refl ] end. +assert (Hr: Rabs (round radix2 fexp (round_mode m) x) = F2R (Float radix2 m1' e1)). +(* . *) +rewrite <- (Z.abs_eq m1'). +rewrite <- (abs_cond_Zopp (Rlt_bool x 0) m1'). +rewrite F2R_Zabs. +now apply f_equal. +apply Z.le_trans with (2 := Hm). +apply Zlt_succ_le. +apply gt_0_F2R with radix2 e1. +apply Rle_lt_trans with (1 := Rabs_pos x). +exact (proj2 (inbetween_float_bounds _ _ _ _ _ H1a)). +(* . *) +assert (Br: inbetween_float radix2 m1' e1 (Rabs (round radix2 fexp (round_mode m) x)) loc_Exact). +now apply inbetween_Exact. +destruct m1' as [|m1'|m1']. +(* . m1' = 0 *) +rewrite shr_truncate. 2: apply Z.le_refl. +generalize (truncate_0 radix2 fexp e1 loc_Exact). +destruct (truncate radix2 fexp (Z0, e1, loc_Exact)) as ((m2, e2), l2). +rewrite shr_m_shr_record_of_loc. +intros Hm2. +rewrite Hm2. +repeat split. +rewrite Rlt_bool_true. +repeat split. +apply sym_eq. +case Rlt_bool ; apply F2R_0. +rewrite <- F2R_Zabs, abs_cond_Zopp, F2R_0. +apply bpow_gt_0. +(* . 0 < m1' *) +assert (He: (e1 <= fexp (Zdigits radix2 (Zpos m1') + e1))%Z). +rewrite <- mag_F2R_Zdigits, <- Hr, mag_abs. +2: discriminate. +rewrite H1b. +rewrite cexp_abs. +fold (cexp radix2 fexp (round radix2 fexp (round_mode m) x)). +apply cexp_round_ge... +rewrite H1c. +case (Rlt_bool x 0). +apply Rlt_not_eq. +now apply F2R_lt_0. +apply Rgt_not_eq. +now apply F2R_gt_0. +refine (_ (truncate_correct_partial _ _ _ _ _ _ _ Br He)). +2: now rewrite Hr ; apply F2R_gt_0. +refine (_ (truncate_correct_format radix2 fexp (Zpos m1') e1 _ _ He)). +2: discriminate. +rewrite shr_truncate. 2: easy. +destruct (truncate radix2 fexp (Zpos m1', e1, loc_Exact)) as ((m2, e2), l2). +rewrite shr_m_shr_record_of_loc. +intros (H3,H4) (H2,_). +destruct m2 as [|m2|m2]. +elim Rgt_not_eq with (2 := H3). +rewrite F2R_0. +now apply F2R_gt_0. +destruct (binary_fit_aux_correct m (Rlt_bool x 0) m2 e2) as [H5 H6]. + apply Zeq_bool_true. + rewrite Zpos_digits2_pos. + rewrite <- mag_F2R_Zdigits by easy. + now rewrite <- H3. +apply (conj H5). +revert H6. +simpl. +rewrite 2!F2R_cond_Zopp. +now rewrite <- H3. +elim Rgt_not_eq with (2 := H3). +apply Rlt_trans with R0. +now apply F2R_lt_0. +now apply F2R_gt_0. +rewrite <- Hr. +apply generic_format_abs... +apply generic_format_round... +(* . not m1' < 0 *) +elim Rgt_not_eq with (2 := Hr). +apply Rlt_le_trans with R0. +now apply F2R_lt_0. +apply Rabs_pos. +(* *) +apply Rlt_le_trans with (2 := proj1 (inbetween_float_bounds _ _ _ _ _ Bx)). +now apply F2R_gt_0. +(* all the modes are valid *) +clear. case m. +exact inbetween_int_NE_sign. +exact inbetween_int_ZR_sign. +exact inbetween_int_DN_sign. +exact inbetween_int_UP_sign. +exact inbetween_int_NA_sign. +Qed. + +(** Multiplication *) + +Lemma Bmult_correct_aux : + forall m sx mx ex (Hx : bounded mx ex = true) sy my ey (Hy : bounded my ey = true), + let x := F2R (Float radix2 (cond_Zopp sx (Zpos mx)) ex) in + let y := F2R (Float radix2 (cond_Zopp sy (Zpos my)) ey) in + let z := binary_round_aux m (xorb sx sy) (Zpos (mx * my)) (ex + ey) loc_Exact in + valid_binary z = true /\ + if Rlt_bool (Rabs (round radix2 fexp (round_mode m) (x * y))) (bpow radix2 emax) then + SF2R radix2 z = round radix2 fexp (round_mode m) (x * y) /\ + is_finite_SF z = true /\ sign_SF z = xorb sx sy + else + z = binary_overflow m (xorb sx sy). +Proof. +intros m sx mx ex Hx sy my ey Hy x y. +unfold x, y. +rewrite <- F2R_mult. +simpl. +replace (xorb sx sy) with (Rlt_bool (F2R (Float radix2 (cond_Zopp sx (Zpos mx) * cond_Zopp sy (Zpos my)) (ex + ey))) 0). +apply binary_round_aux_correct. +constructor. +rewrite <- F2R_abs. +apply F2R_eq. +rewrite Zabs_Zmult. +now rewrite 2!abs_cond_Zopp. +(* *) +change (Zpos (mx * my)) with (Zpos mx * Zpos my)%Z. +assert (forall m e, bounded m e = true -> fexp (Zdigits radix2 (Zpos m) + e) = e)%Z. +clear. intros m e Hb. +destruct (andb_prop _ _ Hb) as (H,_). +apply Zeq_bool_eq. +now rewrite <- Zpos_digits2_pos. +generalize (H _ _ Hx) (H _ _ Hy). +clear x y sx sy Hx Hy H. +unfold fexp, FLT_exp. +refine (_ (Zdigits_mult_ge radix2 (Zpos mx) (Zpos my) _ _)) ; try discriminate. +refine (_ (Zdigits_gt_0 radix2 (Zpos mx) _) (Zdigits_gt_0 radix2 (Zpos my) _)) ; try discriminate. +generalize (Zdigits radix2 (Zpos mx)) (Zdigits radix2 (Zpos my)) (Zdigits radix2 (Zpos mx * Zpos my)). +intros dx dy dxy Hx Hy Hxy. +unfold emin. +generalize (prec_lt_emax prec emax). +lia. +(* *) +case sx ; case sy. +apply Rlt_bool_false. +now apply F2R_ge_0. +apply Rlt_bool_true. +now apply F2R_lt_0. +apply Rlt_bool_true. +now apply F2R_lt_0. +apply Rlt_bool_false. +now apply F2R_ge_0. +Qed. + +Definition Bmult m x y := + match x, y with + | B754_nan, _ | _, B754_nan => B754_nan + | B754_infinity sx, B754_infinity sy => B754_infinity (xorb sx sy) + | B754_infinity sx, B754_finite sy _ _ _ => B754_infinity (xorb sx sy) + | B754_finite sx _ _ _, B754_infinity sy => B754_infinity (xorb sx sy) + | B754_infinity _, B754_zero _ => B754_nan + | B754_zero _, B754_infinity _ => B754_nan + | B754_finite sx _ _ _, B754_zero sy => B754_zero (xorb sx sy) + | B754_zero sx, B754_finite sy _ _ _ => B754_zero (xorb sx sy) + | B754_zero sx, B754_zero sy => B754_zero (xorb sx sy) + | B754_finite sx mx ex Hx, B754_finite sy my ey Hy => + SF2B _ (proj1 (Bmult_correct_aux m sx mx ex Hx sy my ey Hy)) + end. + +(* TODO: lemme d'equivalence *) + +Theorem Bmult_correct : + forall m x y, + if Rlt_bool (Rabs (round radix2 fexp (round_mode m) (B2R x * B2R y))) (bpow radix2 emax) then + B2R (Bmult m x y) = round radix2 fexp (round_mode m) (B2R x * B2R y) /\ + is_finite (Bmult m x y) = andb (is_finite x) (is_finite y) /\ + (is_nan (Bmult m x y) = false -> + Bsign (Bmult m x y) = xorb (Bsign x) (Bsign y)) + else + B2SF (Bmult m x y) = binary_overflow m (xorb (Bsign x) (Bsign y)). +Proof. +intros m [sx|sx| |sx mx ex Hx] [sy|sy| |sy my ey Hy] ; + try ( rewrite ?Rmult_0_r, ?Rmult_0_l, round_0, Rabs_R0, Rlt_bool_true ; [ simpl ; try easy ; now rewrite B2R_build_nan, is_finite_build_nan, is_nan_build_nan | apply bpow_gt_0 | now auto with typeclass_instances ] ). +simpl. +case Bmult_correct_aux. +intros H1. +case Rlt_bool. +intros (H2, (H3, H4)). +split. +now rewrite B2R_SF2B. +split. +now rewrite is_finite_SF2B. +rewrite Bsign_SF2B. auto. +intros H2. +now rewrite B2SF_SF2B. +Qed. + +(** Normalization and rounding *) + +Theorem shl_align_correct': + forall mx ex e, + (e <= ex)%Z -> + let (mx', ex') := shl_align mx ex e in + F2R (Float radix2 (Zpos mx') e) = F2R (Float radix2 (Zpos mx) ex) /\ + ex' = e. +Proof. +intros mx ex ex' He. +unfold shl_align. +destruct (ex' - ex)%Z as [|d|d] eqn:Hd ; simpl. +- now replace ex with ex' by lia. +- exfalso ; lia. +- refine (conj _ eq_refl). + rewrite shift_pos_correct, Zmult_comm. + change (Zpower_pos 2 d) with (Zpower radix2 (Z.opp (Z.neg d))). + rewrite <- Hd. + replace (- (ex' - ex))%Z with (ex - ex')%Z by ring. + now apply eq_sym, F2R_change_exp. +Qed. + +Theorem shl_align_correct : + forall mx ex ex', + let (mx', ex'') := shl_align mx ex ex' in + F2R (Float radix2 (Zpos mx) ex) = F2R (Float radix2 (Zpos mx') ex'') /\ + (ex'' <= ex')%Z. +Proof. +intros mx ex ex'. +generalize (shl_align_correct' mx ex ex'). +unfold shl_align. +destruct (ex' - ex)%Z as [|d|d] eqn:Hd ; simpl. +- refine (fun H => _ (H _)). + 2: clear -Hd; lia. + clear. + intros [H1 ->]. + now split. +- intros _. + refine (conj eq_refl _). + lia. +- refine (fun H => _ (H _)). + 2: clear -Hd; lia. + clear. + now split. +Qed. + +Theorem snd_shl_align : + forall mx ex ex', + (ex' <= ex)%Z -> + snd (shl_align mx ex ex') = ex'. +Proof. +intros mx ex ex' He. +generalize (shl_align_correct' mx ex ex' He). +now destruct shl_align as [m e]. +Qed. + +Definition shl_align_fexp mx ex := + shl_align mx ex (fexp (Zpos (digits2_pos mx) + ex)). + +Theorem shl_align_fexp_correct : + forall mx ex, + let (mx', ex') := shl_align_fexp mx ex in + F2R (Float radix2 (Zpos mx) ex) = F2R (Float radix2 (Zpos mx') ex') /\ + (ex' <= fexp (Zdigits radix2 (Zpos mx') + ex'))%Z. +Proof. +intros mx ex. +unfold shl_align_fexp. +generalize (shl_align_correct mx ex (fexp (Zpos (digits2_pos mx) + ex))). +rewrite Zpos_digits2_pos. +case shl_align. +intros mx' ex' (H1, H2). +split. +exact H1. +rewrite <- mag_F2R_Zdigits. 2: easy. +rewrite <- H1. +now rewrite mag_F2R_Zdigits. +Qed. + +(* TODO: lemme equivalence pour le cas mode_NE *) +Definition binary_round m sx mx ex := + let '(mz, ez) := shl_align_fexp mx ex in binary_round_aux m sx (Zpos mz) ez loc_Exact. + +Theorem binary_round_correct : + forall m sx mx ex, + let z := binary_round m sx mx ex in + valid_binary z = true /\ + let x := F2R (Float radix2 (cond_Zopp sx (Zpos mx)) ex) in + if Rlt_bool (Rabs (round radix2 fexp (round_mode m) x)) (bpow radix2 emax) then + SF2R radix2 z = round radix2 fexp (round_mode m) x /\ + is_finite_SF z = true /\ + sign_SF z = sx + else + z = binary_overflow m sx. +Proof. +intros m sx mx ex. +unfold binary_round. +generalize (shl_align_fexp_correct mx ex). +destruct (shl_align_fexp mx ex) as (mz, ez). +intros (H1, H2). +set (x := F2R (Float radix2 (cond_Zopp sx (Zpos mx)) ex)). +replace sx with (Rlt_bool x 0). +apply binary_round_aux_correct. +constructor. +unfold x. +now rewrite <- F2R_Zabs, abs_cond_Zopp. +exact H2. +unfold x. +case sx. +apply Rlt_bool_true. +now apply F2R_lt_0. +apply Rlt_bool_false. +now apply F2R_ge_0. +Qed. + +Theorem is_nan_binary_round : + forall mode sx mx ex, + is_nan_SF (binary_round mode sx mx ex) = false. +Proof. +intros mode sx mx ex. +generalize (binary_round_correct mode sx mx ex). +simpl. +destruct binary_round ; try easy. +intros [_ H]. +destruct Rlt_bool ; try easy. +unfold binary_overflow in H. +now destruct overflow_to_inf. +Qed. + +(* TODO: lemme equivalence pour le cas mode_NE *) +Definition binary_normalize mode m e szero := + match m with + | Z0 => B754_zero szero + | Zpos m => SF2B _ (proj1 (binary_round_correct mode false m e)) + | Zneg m => SF2B _ (proj1 (binary_round_correct mode true m e)) + end. + +Theorem binary_normalize_correct : + forall m mx ex szero, + let x := F2R (Float radix2 mx ex) in + let z := binary_normalize m mx ex szero in + if Rlt_bool (Rabs (round radix2 fexp (round_mode m) x)) (bpow radix2 emax) then + B2R z = round radix2 fexp (round_mode m) x /\ + is_finite z = true /\ + Bsign z = + match Rcompare x 0 with + | Eq => szero + | Lt => true + | Gt => false + end + else + B2SF z = binary_overflow m (Rlt_bool x 0). +Proof with auto with typeclass_instances. +intros m mx ez szero. +destruct mx as [|mz|mz] ; simpl. +rewrite F2R_0, round_0, Rabs_R0, Rlt_bool_true... +split... split... +rewrite Rcompare_Eq... +apply bpow_gt_0. +(* . mz > 0 *) +generalize (binary_round_correct m false mz ez). +simpl. +case Rlt_bool_spec. +intros _ (Vz, (Rz, (Rz', Rz''))). +split. +now rewrite B2R_SF2B. +split. +now rewrite is_finite_SF2B. +rewrite Bsign_SF2B, Rz''. +rewrite Rcompare_Gt... +apply F2R_gt_0. +simpl. lia. +intros Hz' (Vz, Rz). +rewrite B2SF_SF2B, Rz. +apply f_equal. +apply sym_eq. +apply Rlt_bool_false. +now apply F2R_ge_0. +(* . mz < 0 *) +generalize (binary_round_correct m true mz ez). +simpl. +case Rlt_bool_spec. +intros _ (Vz, (Rz, (Rz', Rz''))). +split. +now rewrite B2R_SF2B. +split. +now rewrite is_finite_SF2B. +rewrite Bsign_SF2B, Rz''. +rewrite Rcompare_Lt... +apply F2R_lt_0. +simpl. lia. +intros Hz' (Vz, Rz). +rewrite B2SF_SF2B, Rz. +apply f_equal. +apply sym_eq. +apply Rlt_bool_true. +now apply F2R_lt_0. +Qed. + +Theorem is_nan_binary_normalize : + forall mode m e szero, + is_nan (binary_normalize mode m e szero) = false. +Proof. +intros mode m e szero. +generalize (binary_normalize_correct mode m e szero). +simpl. +destruct Rlt_bool. +- intros [_ [H _]]. + now destruct binary_normalize. +- intros H. + rewrite <- is_nan_SF_B2SF. + rewrite H. + unfold binary_overflow. + now destruct overflow_to_inf. +Qed. + +(** Addition *) + +Definition Fplus_naive sx mx ex sy my ey ez := + (Zplus (cond_Zopp sx (Zpos (fst (shl_align mx ex ez)))) (cond_Zopp sy (Zpos (fst (shl_align my ey ez))))). + +Lemma Fplus_naive_correct : + forall sx mx ex sy my ey ez, + (ez <= ex)%Z -> (ez <= ey)%Z -> + let x := F2R (Float radix2 (cond_Zopp sx (Zpos mx)) ex) in + let y := F2R (Float radix2 (cond_Zopp sy (Zpos my)) ey) in + F2R (Float radix2 (Fplus_naive sx mx ex sy my ey ez) ez) = (x + y)%R. +Proof. +intros sx mx ex sy my ey ez Ex Ey. +unfold Fplus_naive, F2R. simpl. +generalize (shl_align_correct' mx ex ez Ex). +generalize (shl_align_correct' my ey ez Ey). +destruct shl_align as [my' ey']. +destruct shl_align as [mx' ex']. +intros [Hy _]. +intros [Hx _]. +simpl. +rewrite plus_IZR, Rmult_plus_distr_r. +generalize (f_equal (cond_Ropp sx) Hx). +generalize (f_equal (cond_Ropp sy) Hy). +rewrite <- 4!F2R_cond_Zopp. +unfold F2R. simpl. +now intros -> ->. +Qed. + +Lemma sign_plus_overflow : + forall m sx mx ex sy my ey, + bounded mx ex = true -> + bounded my ey = true -> + let z := (F2R (Float radix2 (cond_Zopp sx (Zpos mx)) ex) + F2R (Float radix2 (cond_Zopp sy (Zpos my)) ey))%R in + (bpow radix2 emax <= Rabs (round radix2 fexp (round_mode m) z))%R -> + sx = Rlt_bool z 0 /\ sx = sy. +Proof with auto with typeclass_instances. +intros m sx mx ex sy my ey Hx Hy z Bz. +destruct (Bool.bool_dec sx sy) as [Hs|Hs]. +(* .. *) +refine (conj _ Hs). +unfold z. +rewrite Hs. +apply sym_eq. +case sy. +apply Rlt_bool_true. +rewrite <- (Rplus_0_r 0). +apply Rplus_lt_compat. +now apply F2R_lt_0. +now apply F2R_lt_0. +apply Rlt_bool_false. +rewrite <- (Rplus_0_r 0). +apply Rplus_le_compat. +now apply F2R_ge_0. +now apply F2R_ge_0. +(* .. *) +elim Rle_not_lt with (1 := Bz). +generalize (bounded_lt_emax _ _ Hx) (bounded_lt_emax _ _ Hy) (andb_prop _ _ Hx) (andb_prop _ _ Hy). +intros Bx By (Hx',_) (Hy',_). +generalize (canonical_canonical_mantissa sx _ _ Hx') (canonical_canonical_mantissa sy _ _ Hy'). +clear -Bx By Hs prec_gt_0_. +intros Cx Cy. +destruct sx. +(* ... *) +destruct sy. +now elim Hs. +clear Hs. +apply Rabs_lt. +split. +apply Rlt_le_trans with (F2R (Float radix2 (cond_Zopp true (Zpos mx)) ex)). +rewrite F2R_Zopp. +now apply Ropp_lt_contravar. +apply round_ge_generic... +now apply generic_format_canonical. +pattern (F2R (Float radix2 (cond_Zopp true (Zpos mx)) ex)) at 1 ; rewrite <- Rplus_0_r. +apply Rplus_le_compat_l. +now apply F2R_ge_0. +apply Rle_lt_trans with (2 := By). +apply round_le_generic... +now apply generic_format_canonical. +rewrite <- (Rplus_0_l (F2R (Float radix2 (Zpos my) ey))). +apply Rplus_le_compat_r. +now apply F2R_le_0. +(* ... *) +destruct sy. +2: now elim Hs. +clear Hs. +apply Rabs_lt. +split. +apply Rlt_le_trans with (F2R (Float radix2 (cond_Zopp true (Zpos my)) ey)). +rewrite F2R_Zopp. +now apply Ropp_lt_contravar. +apply round_ge_generic... +now apply generic_format_canonical. +pattern (F2R (Float radix2 (cond_Zopp true (Zpos my)) ey)) at 1 ; rewrite <- Rplus_0_l. +apply Rplus_le_compat_r. +now apply F2R_ge_0. +apply Rle_lt_trans with (2 := Bx). +apply round_le_generic... +now apply generic_format_canonical. +rewrite <- (Rplus_0_r (F2R (Float radix2 (Zpos mx) ex))). +apply Rplus_le_compat_l. +now apply F2R_le_0. +Qed. + +Definition Bplus m x y := + match x, y with + | B754_nan, _ | _, B754_nan => B754_nan + | B754_infinity sx, B754_infinity sy => if Bool.eqb sx sy then x else B754_nan + | B754_infinity _, _ => x + | _, B754_infinity _ => y + | B754_zero sx, B754_zero sy => + if Bool.eqb sx sy then x else + match m with mode_DN => B754_zero true | _ => B754_zero false end + | B754_zero _, _ => y + | _, B754_zero _ => x + | B754_finite sx mx ex Hx, B754_finite sy my ey Hy => + let ez := Z.min ex ey in + binary_normalize m (Fplus_naive sx mx ex sy my ey ez) + ez (match m with mode_DN => true | _ => false end) + end. + +Theorem Bplus_correct : + forall m x y, + is_finite x = true -> + is_finite y = true -> + if Rlt_bool (Rabs (round radix2 fexp (round_mode m) (B2R x + B2R y))) (bpow radix2 emax) then + B2R (Bplus m x y) = round radix2 fexp (round_mode m) (B2R x + B2R y) /\ + is_finite (Bplus m x y) = true /\ + Bsign (Bplus m x y) = + match Rcompare (B2R x + B2R y) 0 with + | Eq => match m with mode_DN => orb (Bsign x) (Bsign y) + | _ => andb (Bsign x) (Bsign y) end + | Lt => true + | Gt => false + end + else + (B2SF (Bplus m x y) = binary_overflow m (Bsign x) /\ Bsign x = Bsign y). +Proof with auto with typeclass_instances. +intros m [sx|sx| |sx mx ex Hx] [sy|sy| |sy my ey Hy] Fx Fy ; try easy. +(* *) +rewrite Rplus_0_r, round_0, Rabs_R0, Rlt_bool_true... +simpl. +rewrite Rcompare_Eq by auto. +destruct sx, sy; try easy; now case m. +apply bpow_gt_0. +(* *) +rewrite Rplus_0_l, round_generic, Rlt_bool_true... +split... split... +simpl. unfold F2R. +erewrite <- Rmult_0_l, Rcompare_mult_r. +rewrite Rcompare_IZR with (y:=0%Z). +destruct sy... +apply bpow_gt_0. +apply abs_B2R_lt_emax. +apply generic_format_B2R. +(* *) +rewrite Rplus_0_r, round_generic, Rlt_bool_true... +split... split... +simpl. unfold F2R. +erewrite <- Rmult_0_l, Rcompare_mult_r. +rewrite Rcompare_IZR with (y:=0%Z). +destruct sx... +apply bpow_gt_0. +apply abs_B2R_lt_emax. +apply generic_format_B2R. +(* *) +clear Fx Fy. +simpl. +set (szero := match m with mode_DN => true | _ => false end). +set (ez := Z.min ex ey). +assert (Hp := Fplus_naive_correct sx mx ex sy my ey ez (Z.le_min_l _ _) (Z.le_min_r _ _)). +set (mz := Fplus_naive sx mx ex sy my ey ez). +simpl in Hp. +fold mz in Hp. +rewrite <- Hp. +generalize (binary_normalize_correct m mz ez szero). +simpl. +case Rlt_bool_spec ; intros Hz. +intros [H1 [H2 H3]]. +apply (conj H1). +apply (conj H2). +rewrite H3. +case Rcompare_spec ; try easy. +intros Hz'. +rewrite Hz' in Hp. +apply eq_sym, Rplus_opp_r_uniq in Hp. +rewrite <- F2R_Zopp in Hp. +eapply canonical_unique in Hp. +inversion Hp. +clear -H0. +destruct sy, sx, m ; easy. +apply canonical_canonical_mantissa. +apply Bool.andb_true_iff in Hy. easy. +rewrite <- cond_Zopp_negb. +apply canonical_canonical_mantissa. +apply Bool.andb_true_iff in Hx. easy. +intros Vz. +rewrite Hp in Hz. +assert (Sz := sign_plus_overflow m sx mx ex sy my ey Hx Hy Hz). +split. +rewrite Vz. +apply f_equal. +now rewrite Hp. +apply Sz. +Qed. + +(** Subtraction *) + +Definition Bminus m x y := + match x, y with + | B754_nan, _ | _, B754_nan => B754_nan + | B754_infinity sx, B754_infinity sy => + if Bool.eqb sx (negb sy) then x else B754_nan + | B754_infinity _, _ => x + | _, B754_infinity sy => B754_infinity (negb sy) + | B754_zero sx, B754_zero sy => + if Bool.eqb sx (negb sy) then x else + match m with mode_DN => B754_zero true | _ => B754_zero false end + | B754_zero _, B754_finite sy my ey Hy => B754_finite (negb sy) my ey Hy + | _, B754_zero _ => x + | B754_finite sx mx ex Hx, B754_finite sy my ey Hy => + let ez := Z.min ex ey in + binary_normalize m (Fplus_naive sx mx ex (negb sy) my ey ez) + ez (match m with mode_DN => true | _ => false end) + end. + +Theorem Bminus_correct : + forall m x y, + is_finite x = true -> + is_finite y = true -> + if Rlt_bool (Rabs (round radix2 fexp (round_mode m) (B2R x - B2R y))) (bpow radix2 emax) then + B2R (Bminus m x y) = round radix2 fexp (round_mode m) (B2R x - B2R y) /\ + is_finite (Bminus m x y) = true /\ + Bsign (Bminus m x y) = + match Rcompare (B2R x - B2R y) 0 with + | Eq => match m with mode_DN => orb (Bsign x) (negb (Bsign y)) + | _ => andb (Bsign x) (negb (Bsign y)) end + | Lt => true + | Gt => false + end + else + (B2SF (Bminus m x y) = binary_overflow m (Bsign x) /\ Bsign x = negb (Bsign y)). +Proof with auto with typeclass_instances. +intros m x y Fx Fy. +generalize (Bplus_correct m x (Bopp y) Fx). +rewrite is_finite_Bopp, B2R_Bopp. +intros H. +specialize (H Fy). +rewrite <- Bsign_Bopp. +destruct x as [| | |sx mx ex Hx], y as [| | |sy my ey Hy] ; try easy. +now clear -Fy; destruct y as [ | | | ]. +Qed. + +(** Fused Multiply-Add *) + +Definition Bfma_szero m (x y z: binary_float) : bool := + let s_xy := xorb (Bsign x) (Bsign y) in (* sign of product x*y *) + if Bool.eqb s_xy (Bsign z) then s_xy + else match m with mode_DN => true | _ => false end. + +Definition Bfma m (x y z: binary_float) := + match x, y with + | B754_nan, _ | _, B754_nan + | B754_infinity _, B754_zero _ + | B754_zero _, B754_infinity _ => + (* Multiplication produces NaN *) + B754_nan + | B754_infinity sx, B754_infinity sy + | B754_infinity sx, B754_finite sy _ _ _ + | B754_finite sx _ _ _, B754_infinity sy => + let s := xorb sx sy in + (* Multiplication produces infinity with sign [s] *) + match z with + | B754_nan => B754_nan + | B754_infinity sz => if Bool.eqb s sz then z else B754_nan + | _ => B754_infinity s + end + | B754_finite sx _ _ _, B754_zero sy + | B754_zero sx, B754_finite sy _ _ _ + | B754_zero sx, B754_zero sy => + (* Multiplication produces zero *) + match z with + | B754_nan => B754_nan + | B754_zero _ => B754_zero (Bfma_szero m x y z) + | _ => z + end + | B754_finite sx mx ex _, B754_finite sy my ey _ => + (* Multiplication produces a finite, non-zero result *) + match z with + | B754_nan => B754_nan + | B754_infinity sz => z + | B754_zero _ => + let X := Float radix2 (cond_Zopp sx (Zpos mx)) ex in + let Y := Float radix2 (cond_Zopp sy (Zpos my)) ey in + let '(Float _ mr er) := Fmult X Y in + binary_normalize m mr er (Bfma_szero m x y z) + | B754_finite sz mz ez _ => + let X := Float radix2 (cond_Zopp sx (Zpos mx)) ex in + let Y := Float radix2 (cond_Zopp sy (Zpos my)) ey in + let Z := Float radix2 (cond_Zopp sz (Zpos mz)) ez in + let '(Float _ mr er) := Fplus (Fmult X Y) Z in + binary_normalize m mr er (Bfma_szero m x y z) + end + end. + +Theorem Bfma_correct: + forall m x y z, + is_finite x = true -> + is_finite y = true -> + is_finite z = true -> + let res := (B2R x * B2R y + B2R z)%R in + if Rlt_bool (Rabs (round radix2 fexp (round_mode m) res)) (bpow radix2 emax) then + B2R (Bfma m x y z) = round radix2 fexp (round_mode m) res /\ + is_finite (Bfma m x y z) = true /\ + Bsign (Bfma m x y z) = + match Rcompare res 0 with + | Eq => Bfma_szero m x y z + | Lt => true + | Gt => false + end + else + B2SF (Bfma m x y z) = binary_overflow m (Rlt_bool res 0). +Proof. + intros. pattern (Bfma m x y z). + match goal with |- ?p ?x => set (PROP := p) end. + set (szero := Bfma_szero m x y z). + assert (BINORM: forall mr er, F2R (Float radix2 mr er) = res -> + PROP (binary_normalize m mr er szero)). + { intros mr er E. + specialize (binary_normalize_correct m mr er szero). + change (FLT_exp (3 - emax - prec) prec) with fexp. rewrite E. tauto. + } + set (add_zero := + match z with + | B754_nan => B754_nan + | B754_zero sz => B754_zero szero + | _ => z + end). + assert (ADDZERO: B2R x = 0%R \/ B2R y = 0%R -> PROP add_zero). + { + intros Z. + assert (RES: res = B2R z). + { unfold res. destruct Z as [E|E]; rewrite E, ?Rmult_0_l, ?Rmult_0_r, Rplus_0_l; auto. } + unfold PROP, add_zero; destruct z as [ sz | sz | | sz mz ez Bz]; try discriminate. + - simpl in RES; rewrite RES; rewrite round_0 by apply valid_rnd_round_mode. + rewrite Rlt_bool_true. split. reflexivity. split. reflexivity. + rewrite Rcompare_Eq by auto. reflexivity. + rewrite Rabs_R0; apply bpow_gt_0. + - rewrite RES, round_generic, Rlt_bool_true. + split. reflexivity. split. reflexivity. + unfold B2R. destruct sz. + rewrite Rcompare_Lt. auto. apply F2R_lt_0. reflexivity. + rewrite Rcompare_Gt. auto. apply F2R_gt_0. reflexivity. + apply abs_B2R_lt_emax. apply valid_rnd_round_mode. apply generic_format_B2R. + } + destruct x as [ sx | sx | | sx mx ex Bx]; + destruct y as [ sy | sy | | sy my ey By]; + try discriminate. +- apply ADDZERO; auto. +- apply ADDZERO; auto. +- apply ADDZERO; auto. +- destruct z as [ sz | sz | | sz mz ez Bz]; try discriminate; unfold Bfma. ++ set (X := Float radix2 (cond_Zopp sx (Zpos mx)) ex). + set (Y := Float radix2 (cond_Zopp sy (Zpos my)) ey). + destruct (Fmult X Y) as [mr er] eqn:FRES. + apply BINORM. unfold res. rewrite <- FRES, F2R_mult, Rplus_0_r. auto. ++ set (X := Float radix2 (cond_Zopp sx (Zpos mx)) ex). + set (Y := Float radix2 (cond_Zopp sy (Zpos my)) ey). + set (Z := Float radix2 (cond_Zopp sz (Zpos mz)) ez). + destruct (Fplus (Fmult X Y) Z) as [mr er] eqn:FRES. + apply BINORM. unfold res. rewrite <- FRES, F2R_plus, F2R_mult. auto. +Qed. + +(** Division *) + +Lemma Bdiv_correct_aux : + forall m sx mx ex sy my ey, + let x := F2R (Float radix2 (cond_Zopp sx (Zpos mx)) ex) in + let y := F2R (Float radix2 (cond_Zopp sy (Zpos my)) ey) in + let z := + let '(mz, ez, lz) := SFdiv_core_binary prec emax (Zpos mx) ex (Zpos my) ey in + binary_round_aux m (xorb sx sy) mz ez lz in + valid_binary z = true /\ + if Rlt_bool (Rabs (round radix2 fexp (round_mode m) (x / y))) (bpow radix2 emax) then + SF2R radix2 z = round radix2 fexp (round_mode m) (x / y) /\ + is_finite_SF z = true /\ sign_SF z = xorb sx sy + else + z = binary_overflow m (xorb sx sy). +Proof. +intros m sx mx ex sy my ey. +unfold SFdiv_core_binary. +rewrite 2!Zdigits2_Zdigits. +set (e' := Z.min _ _). +match goal with |- context [Z.div_eucl ?m _] => set (mx' := m) end. +generalize (Fdiv_core_correct radix2 (Zpos mx) ex (Zpos my) ey e' eq_refl eq_refl). +unfold Fdiv_core. +rewrite Zle_bool_true by apply Z.le_min_r. +assert (mx' = Zpos mx * Zpower radix2 (ex - ey - e'))%Z as <-. +{ unfold mx'. + destruct (ex - ey - e')%Z as [|p|p]. + now rewrite Zmult_1_r. + now rewrite Z.shiftl_mul_pow2. + easy. } +clearbody mx'. +destruct Z.div_eucl as [q r]. +intros Bz. +assert (xorb sx sy = Rlt_bool (F2R (Float radix2 (cond_Zopp sx (Zpos mx)) ex) * + / F2R (Float radix2 (cond_Zopp sy (Zpos my)) ey)) 0) as ->. +{ apply eq_sym. +case sy ; simpl. +change (Zneg my) with (Z.opp (Zpos my)). +rewrite F2R_Zopp. +rewrite <- Ropp_inv_permute. +rewrite Ropp_mult_distr_r_reverse. +case sx ; simpl. +apply Rlt_bool_false. +rewrite <- Ropp_mult_distr_l_reverse. +apply Rmult_le_pos. +rewrite <- F2R_opp. +now apply F2R_ge_0. +apply Rlt_le. +apply Rinv_0_lt_compat. +now apply F2R_gt_0. +apply Rlt_bool_true. +rewrite <- Ropp_0. +apply Ropp_lt_contravar. +apply Rmult_lt_0_compat. +now apply F2R_gt_0. +apply Rinv_0_lt_compat. +now apply F2R_gt_0. +apply Rgt_not_eq. +now apply F2R_gt_0. +case sx. +apply Rlt_bool_true. +rewrite F2R_Zopp. +rewrite Ropp_mult_distr_l_reverse. +rewrite <- Ropp_0. +apply Ropp_lt_contravar. +apply Rmult_lt_0_compat. +now apply F2R_gt_0. +apply Rinv_0_lt_compat. +now apply F2R_gt_0. +apply Rlt_bool_false. +apply Rmult_le_pos. +now apply F2R_ge_0. +apply Rlt_le. +apply Rinv_0_lt_compat. +now apply F2R_gt_0. } +unfold Rdiv. +apply binary_round_aux_correct'. +- apply Rmult_integral_contrapositive_currified. + now apply F2R_neq_0 ; case sx. + apply Rinv_neq_0_compat. + now apply F2R_neq_0 ; case sy. +- rewrite Rabs_mult, Rabs_Rinv. + + rewrite <- 2!F2R_Zabs, 2!abs_cond_Zopp; simpl. + replace (SpecFloat.new_location _ _) with (Bracket.new_location (Z.pos my) r loc_Exact); + [exact Bz|]. + case my as [p|p|]; [reflexivity| |reflexivity]. + unfold Bracket.new_location, SpecFloat.new_location; simpl. + unfold Bracket.new_location_even, SpecFloat.new_location_even; simpl. + now case Zeq_bool; [|case r as [|rp|rp]; case Z.compare]. + + now apply F2R_neq_0 ; case sy. +- rewrite <- cexp_abs, Rabs_mult, Rabs_Rinv. + rewrite 2!F2R_cond_Zopp, 2!abs_cond_Ropp, <- Rabs_Rinv. + rewrite <- Rabs_mult, cexp_abs. + apply Z.le_trans with (1 := Z.le_min_l _ _). + apply FLT_exp_monotone. + now apply mag_div_F2R. + now apply F2R_neq_0. + now apply F2R_neq_0 ; case sy. +Qed. + +Definition Bdiv m x y := + match x, y with + | B754_nan, _ | _, B754_nan => B754_nan + | B754_infinity sx, B754_infinity sy => B754_nan + | B754_infinity sx, B754_finite sy _ _ _ => B754_infinity (xorb sx sy) + | B754_finite sx _ _ _, B754_infinity sy => B754_zero (xorb sx sy) + | B754_infinity sx, B754_zero sy => B754_infinity (xorb sx sy) + | B754_zero sx, B754_infinity sy => B754_zero (xorb sx sy) + | B754_finite sx _ _ _, B754_zero sy => B754_infinity (xorb sx sy) + | B754_zero sx, B754_finite sy _ _ _ => B754_zero (xorb sx sy) + | B754_zero sx, B754_zero sy => B754_nan + | B754_finite sx mx ex _, B754_finite sy my ey _ => + SF2B _ (proj1 (Bdiv_correct_aux m sx mx ex sy my ey)) + end. + +Theorem Bdiv_correct : + forall m x y, + B2R y <> 0%R -> + if Rlt_bool (Rabs (round radix2 fexp (round_mode m) (B2R x / B2R y))) (bpow radix2 emax) then + B2R (Bdiv m x y) = round radix2 fexp (round_mode m) (B2R x / B2R y) /\ + is_finite (Bdiv m x y) = is_finite x /\ + (is_nan (Bdiv m x y) = false -> + Bsign (Bdiv m x y) = xorb (Bsign x) (Bsign y)) + else + B2SF (Bdiv m x y) = binary_overflow m (xorb (Bsign x) (Bsign y)). +Proof. +intros m x [sy|sy| |sy my ey Hy] Zy ; try now elim Zy. +revert x. +unfold Rdiv. +intros [sx|sx| |sx mx ex Hx] ; + try ( rewrite Rmult_0_l, round_0, Rabs_R0, Rlt_bool_true ; [ simpl ; try easy ; now rewrite B2R_build_nan, is_finite_build_nan, is_nan_build_nan | apply bpow_gt_0 | auto with typeclass_instances ] ). +simpl. +case Bdiv_correct_aux. +intros H1. +unfold Rdiv. +case Rlt_bool. +intros (H2, (H3, H4)). +split. +now rewrite B2R_SF2B. +split. +now rewrite is_finite_SF2B. +rewrite Bsign_SF2B. congruence. +intros H2. +now rewrite B2SF_SF2B. +Qed. + +(** Square root *) + +Lemma Bsqrt_correct_aux : + forall m mx ex (Hx : bounded mx ex = true), + let x := F2R (Float radix2 (Zpos mx) ex) in + let z := + let '(mz, ez, lz) := SFsqrt_core_binary prec emax (Zpos mx) ex in + binary_round_aux m false mz ez lz in + valid_binary z = true /\ + SF2R radix2 z = round radix2 fexp (round_mode m) (sqrt x) /\ + is_finite_SF z = true /\ sign_SF z = false. +Proof with auto with typeclass_instances. +intros m mx ex Hx. +unfold SFsqrt_core_binary. +rewrite Zdigits2_Zdigits. +set (e' := Z.min _ _). +assert (2 * e' <= ex)%Z as He. +{ assert (e' <= Z.div2 ex)%Z by apply Z.le_min_r. + rewrite (Zdiv2_odd_eqn ex). + destruct Z.odd ; lia. } +generalize (Fsqrt_core_correct radix2 (Zpos mx) ex e' eq_refl He). +unfold Fsqrt_core. +set (mx' := match (ex - 2 * e')%Z with Z0 => _ | _ => _ end). +assert (mx' = Zpos mx * Zpower radix2 (ex - 2 * e'))%Z as <-. +{ unfold mx'. + destruct (ex - 2 * e')%Z as [|p|p]. + now rewrite Zmult_1_r. + now rewrite Z.shiftl_mul_pow2. + easy. } +clearbody mx'. +destruct Z.sqrtrem as [mz r]. +set (lz := if Zeq_bool r 0 then _ else _). +clearbody lz. +intros Bz. +refine (_ (binary_round_aux_correct' m (sqrt (F2R (Float radix2 (Zpos mx) ex))) mz e' lz _ _ _)) ; cycle 1. + now apply Rgt_not_eq, sqrt_lt_R0, F2R_gt_0. + rewrite Rabs_pos_eq. + exact Bz. + apply sqrt_ge_0. + apply Z.le_trans with (1 := Z.le_min_l _ _). + apply FLT_exp_monotone. + rewrite mag_sqrt_F2R by easy. + apply Z.le_refl. +rewrite Rlt_bool_false by apply sqrt_ge_0. +rewrite Rlt_bool_true. +easy. +rewrite Rabs_pos_eq. +refine (_ (relative_error_FLT_ex radix2 emin prec (prec_gt_0 prec) (round_mode m) (sqrt (F2R (Float radix2 (Zpos mx) ex))) _)). +fold fexp. +intros (eps, (Heps, Hr)). +change fexp with (FLT_exp emin prec). +rewrite Hr. +assert (Heps': (Rabs eps < 1)%R). +apply Rlt_le_trans with (1 := Heps). +fold (bpow radix2 0). +apply bpow_le. +generalize (prec_gt_0 prec). +clear ; lia. +apply Rsqr_incrst_0. +3: apply bpow_ge_0. +rewrite Rsqr_mult. +rewrite Rsqr_sqrt. +2: now apply F2R_ge_0. +unfold Rsqr. +apply Rmult_ge_0_gt_0_lt_compat. +apply Rle_ge. +apply Rle_0_sqr. +apply bpow_gt_0. +now apply bounded_lt_emax. +apply Rlt_le_trans with 4%R. +apply (Rsqr_incrst_1 _ 2). +apply Rplus_lt_compat_l. +apply (Rabs_lt_inv _ _ Heps'). +rewrite <- (Rplus_opp_r 1). +apply Rplus_le_compat_l. +apply Rlt_le. +apply (Rabs_lt_inv _ _ Heps'). +now apply IZR_le. +change 4%R with (bpow radix2 2). +apply bpow_le. +generalize (prec_gt_0 prec) (prec_lt_emax prec emax). +clear ; lia. +apply Rmult_le_pos. +apply sqrt_ge_0. +rewrite <- (Rplus_opp_r 1). +apply Rplus_le_compat_l. +apply Rlt_le. +apply (Rabs_lt_inv _ _ Heps'). +rewrite Rabs_pos_eq. +2: apply sqrt_ge_0. +apply Rsqr_incr_0. +2: apply bpow_ge_0. +2: apply sqrt_ge_0. +rewrite Rsqr_sqrt. +2: now apply F2R_ge_0. +apply Rle_trans with (bpow radix2 emin). +unfold Rsqr. +rewrite <- bpow_plus. +apply bpow_le. +unfold emin. +generalize (prec_lt_emax prec emax). +clear ; lia. +apply generic_format_ge_bpow with fexp. +intros. +apply Z.le_max_r. +now apply F2R_gt_0. +apply generic_format_canonical. +apply (canonical_canonical_mantissa false). +apply (andb_prop _ _ Hx). +apply round_ge_generic... +apply generic_format_0. +apply sqrt_ge_0. +Qed. + +Definition Bsqrt m x := + match x with + | B754_nan => B754_nan + | B754_infinity false => x + | B754_infinity true => B754_nan + | B754_finite true _ _ _ => B754_nan + | B754_zero _ => x + | B754_finite sx mx ex Hx => + SF2B _ (proj1 (Bsqrt_correct_aux m mx ex Hx)) + end. + +Theorem Bsqrt_correct : + forall m x, + B2R (Bsqrt m x) = round radix2 fexp (round_mode m) (sqrt (B2R x)) /\ + is_finite (Bsqrt m x) = match x with B754_zero _ => true | B754_finite false _ _ _ => true | _ => false end /\ + (is_nan (Bsqrt m x) = false -> Bsign (Bsqrt m x) = Bsign x). +Proof. +intros m [sx|[|]| |sx mx ex Hx] ; + try ( simpl ; rewrite sqrt_0, round_0, ?B2R_build_nan, ?is_finite_build_nan, ?is_nan_build_nan ; intuition auto with typeclass_instances ; easy). +simpl. +case Bsqrt_correct_aux. +intros H1 (H2, (H3, H4)). +case sx. +refine (conj _ (conj (refl_equal false) _)). +apply sym_eq. +unfold sqrt. +case Rcase_abs. +intros _. +apply round_0. +auto with typeclass_instances. +intros H. +elim Rge_not_lt with (1 := H). +now apply F2R_lt_0. +easy. +split. +now rewrite B2R_SF2B. +split. +now rewrite is_finite_SF2B. +intros _. +now rewrite Bsign_SF2B. +Qed. + +(** A few values *) + +Definition Bone := SF2B _ (proj1 (binary_round_correct mode_NE false 1 0)). + +Theorem Bone_correct : B2R Bone = 1%R. +Proof. +unfold Bone; simpl. +set (Hr := binary_round_correct _ _ _ _). +unfold Hr; rewrite B2R_SF2B. +destruct Hr as (Vz, Hr). +revert Hr. +fold emin; simpl. +rewrite round_generic; [|now apply valid_rnd_N|]. +- unfold F2R; simpl; rewrite Rmult_1_r. + rewrite Rlt_bool_true. + + now intros (Hr, Hr'); rewrite Hr. + + rewrite Rabs_pos_eq; [|lra]. + change 1%R with (bpow radix2 0); apply bpow_lt. + generalize (prec_gt_0 prec) (prec_lt_emax prec emax). + lia. +- apply generic_format_F2R; intros _. + unfold cexp, fexp, FLT_exp, F2R; simpl; rewrite Rmult_1_r, mag_1. + unfold emin. + generalize (prec_gt_0 prec) (prec_lt_emax prec emax). + lia. +Qed. + +Theorem is_finite_strict_Bone : + is_finite_strict Bone = true. +Proof. +apply is_finite_strict_B2R. +rewrite Bone_correct. +apply R1_neq_R0. +Qed. + +Theorem is_nan_Bone : + is_nan Bone = false. +Proof. +unfold Bone. +rewrite is_nan_SF2B. +apply is_nan_binary_round. +Qed. + +Theorem is_finite_Bone : + is_finite Bone = true. +Proof. +generalize is_finite_strict_Bone. +now destruct Bone. +Qed. + +Theorem Bsign_Bone : + Bsign Bone = false. +Proof. +generalize Bone_correct is_finite_strict_Bone. +destruct Bone as [sx|sx| |[|] mx ex Bx] ; try easy. +intros H _. +contradict H. +apply Rlt_not_eq, Rlt_trans with (2 := Rlt_0_1). +now apply F2R_lt_0. +Qed. + +Lemma Bmax_float_proof : + valid_binary + (S754_finite false (shift_pos (Z.to_pos prec) 1 - 1) (emax - prec)) + = true. +Proof. +unfold valid_binary, bounded; apply andb_true_intro; split. +- unfold canonical_mantissa; apply Zeq_bool_true. + set (p := Z.pos (digits2_pos _)). + assert (H : p = prec). + { unfold p; 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 prec_gt_0_; lia. } + apply Zdigits_unique; + rewrite Z.pow_pos_fold, Z2Pos.id; [|exact prec_gt_0_]; 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 prec_gt_0_; 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 prec_gt_0_; 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 prec_gt_0_]. + change 1%Z with (2 ^ 0)%Z; change 2%Z with (radix2 : Z). + apply Zpower_lt; unfold Prec_gt_0 in prec_gt_0_; lia. } + unfold fexp, FLT_exp; rewrite H, Z.max_l; [ring|]. + unfold emin. + generalize (prec_gt_0 prec) (prec_lt_emax prec emax). + lia. +- apply Zle_bool_true; unfold emin; unfold Prec_gt_0 in prec_gt_0_; lia. +Qed. + +Definition Bmax_float := SF2B _ Bmax_float_proof. + +(** Extraction/modification of mantissa/exponent *) + +Definition Bnormfr_mantissa x := SFnormfr_mantissa prec (B2SF x). + +Lemma Bnormfr_mantissa_correct : + forall x, + (/ 2 <= Rabs (B2R x) < 1)%R -> + match x with + | B754_finite _ m e _ => + Bnormfr_mantissa x = N.pos m + /\ Z.pos (digits2_pos m) = prec /\ (e = - prec)%Z + | _ => False + end. +Proof. +intro x. +destruct x as [s|s| |s m e B]; [now simpl; rewrite Rabs_R0; lra..| ]. +unfold Bnormfr_mantissa, SFnormfr_mantissa; simpl. +intro Hx. +cut (e = -prec /\ Z.pos (digits2_pos m) = prec)%Z. +{ now intros [-> ->]; rewrite Z.eqb_refl. } +revert Hx. +change (/ 2)%R with (bpow radix2 (0 - 1)); change 1%R with (bpow radix2 0). +intro H; generalize (mag_unique _ _ _ H); clear H. +rewrite Float_prop.mag_F2R_Zdigits; [ |now case s]. +replace (Digits.Zdigits _ _) + with (Digits.Zdigits radix2 (Z.pos m)); [ |now case s]. +clear s. +rewrite <-Digits.Zpos_digits2_pos. +intro He; replace e with (e - 0)%Z by ring; rewrite <-He. +cut (Z.pos (digits2_pos m) = prec)%Z. +{ now intro H; split; [ |exact H]; ring_simplify; rewrite H. } +revert B; unfold bounded, canonical_mantissa. +intro H; generalize (andb_prop _ _ H); clear H; intros [H _]; revert H. +intro H; generalize (Zeq_bool_eq _ _ H); clear H. +unfold fexp, emin. +unfold Prec_gt_0 in prec_gt_0_; unfold Prec_lt_emax in prec_lt_emax_. +lia. +Qed. + +Definition Bldexp mode f e := + match f with + | B754_finite sx mx ex _ => + SF2B _ (proj1 (binary_round_correct mode sx mx (ex+e))) + | _ => f + end. + +Theorem is_nan_Bldexp : + forall mode x e, + is_nan (Bldexp mode x e) = is_nan x. +Proof. +intros mode [sx|sx| |sx mx ex Bx] e ; try easy. +unfold Bldexp. +rewrite is_nan_SF2B. +apply is_nan_binary_round. +Qed. + +Theorem Bldexp_correct : + forall m (f : binary_float) e, + if Rlt_bool + (Rabs (round radix2 fexp (round_mode m) (B2R f * bpow radix2 e))) + (bpow radix2 emax) then + (B2R (Bldexp m f e) + = round radix2 fexp (round_mode m) (B2R f * bpow radix2 e))%R /\ + is_finite (Bldexp m f e) = is_finite f /\ + Bsign (Bldexp m f e) = Bsign f + else + B2SF (Bldexp m f e) = binary_overflow m (Bsign f). +Proof. +intros m f e. +case f. +- intro s; simpl; rewrite Rmult_0_l, round_0; [|apply valid_rnd_round_mode]. + now rewrite Rabs_R0, Rlt_bool_true; [|now apply bpow_gt_0]. +- intro s; simpl; rewrite Rmult_0_l, round_0; [|apply valid_rnd_round_mode]. + now rewrite Rabs_R0, Rlt_bool_true; [|now apply bpow_gt_0]. +- simpl; rewrite Rmult_0_l, round_0; [|apply valid_rnd_round_mode]. + now rewrite Rabs_R0, Rlt_bool_true; [|now apply bpow_gt_0]. +- intros s mf ef Hmef. + case (Rlt_bool_spec _ _); intro Hover. + + unfold Bldexp; rewrite B2R_SF2B, is_finite_SF2B, Bsign_SF2B. + simpl; unfold F2R; simpl; rewrite Rmult_assoc, <-bpow_plus. + destruct (binary_round_correct m s mf (ef + e)) as (Hf, Hr). + fold emin in Hr; simpl in Hr; rewrite Rlt_bool_true in Hr. + * now destruct Hr as (Hr, (Hfr, Hsr)); rewrite Hr, Hfr, Hsr. + * now revert Hover; unfold B2R, F2R; simpl; rewrite Rmult_assoc, bpow_plus. + + unfold Bldexp; rewrite B2SF_SF2B; simpl. + destruct (binary_round_correct m s mf (ef + e)) as (Hf, Hr). + fold emin in Hr; simpl in Hr; rewrite Rlt_bool_false in Hr; [exact Hr|]. + now revert Hover; unfold B2R, F2R; simpl; rewrite Rmult_assoc, bpow_plus. +Qed. + +Lemma Bldexp_Bopp_NE x e : Bldexp mode_NE (Bopp x) e = Bopp (Bldexp mode_NE x e). +Proof. +case x as [s|s| |s m e' B]; [now simpl..| ]. +apply B2SF_inj. +replace (B2SF (Bopp _)) with (SFopp (B2SF (Bldexp mode_NE (B754_finite s m e' B) e))). +{ unfold Bldexp, Bopp; rewrite !B2SF_SF2B. + unfold binary_round. + set (shl := shl_align_fexp _ _); case shl; intros mz ez. + unfold binary_round_aux. + set (shr := shr_fexp _ _ _); case shr; intros mrs e''. + unfold choice_mode. + set (shr' := shr_fexp _ _ _); case shr'; intros mrs' e'''. + unfold binary_fit_aux. + now case (shr_m mrs') as [|p|p]; [|case Z.leb|]. } +now case Bldexp as [s'|s'| |s' m' e'' B']. +Qed. + +Definition Ffrexp_core_binary s m e := + if Zlt_bool (-prec) emin then + (S754_finite s m e, 0%Z) + else if (Z.to_pos prec <=? digits2_pos m)%positive then + (S754_finite s m (-prec), (e + prec)%Z) + else + let d := (prec - Z.pos (digits2_pos m))%Z in + (S754_finite s (shift_pos (Z.to_pos d) m) (-prec), (e + prec - d)%Z). + +Lemma Bfrexp_correct_aux : + forall sx mx ex (Hx : bounded mx ex = true), + let x := F2R (Float radix2 (cond_Zopp sx (Z.pos mx)) ex) in + let z := fst (Ffrexp_core_binary sx mx ex) in + let e := snd (Ffrexp_core_binary sx mx ex) in + valid_binary z = true /\ + ((2 < emax)%Z -> (/2 <= Rabs (SF2R radix2 z) < 1)%R) /\ + (x = SF2R radix2 z * bpow radix2 e)%R. +Proof. +intros sx mx ex Bx. +set (x := F2R _). +set (z := fst _). +set (e := snd _); simpl. +assert (Dmx_le_prec : (Z.pos (digits2_pos mx) <= prec)%Z). +{ revert Bx; unfold bounded; rewrite Bool.andb_true_iff. + unfold canonical_mantissa; rewrite <-Zeq_is_eq_bool; unfold fexp, FLT_exp. + case (Z.max_spec (Z.pos (digits2_pos mx) + ex - prec) emin); lia. } +assert (Dmx_le_prec' : (digits2_pos mx <= Z.to_pos prec)%positive). +{ change (_ <= _)%positive + with (Z.pos (digits2_pos mx) <= Z.pos (Z.to_pos prec))%Z. + now rewrite Z2Pos.id; [|now apply prec_gt_0_]. } +unfold z, e, Ffrexp_core_binary. +case Z.ltb_spec ; intros Hp ; unfold emin in Hp. +{ apply (conj Bx). + split. + clear -Hp ; lia. + now rewrite Rmult_1_r. } +case (Pos.leb_spec _ _); simpl; intro Dmx. +- unfold bounded, F2R; simpl. + assert (Dmx' : digits2_pos mx = Z.to_pos prec). + { now apply Pos.le_antisym. } + assert (Dmx'' : Z.pos (digits2_pos mx) = prec). + { now rewrite Dmx', Z2Pos.id; [|apply prec_gt_0_]. } + split; [|split]. + + apply andb_true_intro. + split ; cycle 1. + { apply Zle_bool_true. clear -Hp ; lia. } + apply Zeq_bool_true; unfold fexp, FLT_exp. + rewrite Dmx', Z2Pos.id by apply prec_gt_0_. + rewrite Z.max_l. + ring. + clear -Hp. + unfold emin ; lia. + + intros _. + rewrite Rabs_mult, (Rabs_pos_eq (bpow _ _)) by now apply bpow_ge_0. + rewrite <-abs_IZR, abs_cond_Zopp; simpl; split. + * apply (Rmult_le_reg_r (bpow radix2 prec)); [now apply bpow_gt_0|]. + rewrite Rmult_assoc, <-bpow_plus, Z.add_opp_diag_l; simpl. + rewrite Rmult_1_r. + change (/ 2)%R with (bpow radix2 (- 1)); rewrite <-bpow_plus. + rewrite <-Dmx'', Z.add_comm, Zpos_digits2_pos, Zdigits_mag; [|lia]. + set (b := bpow _ _). + rewrite <-(Rabs_pos_eq (IZR _)); [|apply IZR_le; lia]. + apply bpow_mag_le; apply IZR_neq; lia. + * apply (Rmult_lt_reg_r (bpow radix2 prec)); [now apply bpow_gt_0|]. + rewrite Rmult_assoc, <-bpow_plus, Z.add_opp_diag_l; simpl. + rewrite Rmult_1_l, Rmult_1_r. + rewrite <-Dmx'', Zpos_digits2_pos, Zdigits_mag; [|lia]. + set (b := bpow _ _). + rewrite <-(Rabs_pos_eq (IZR _)); [|apply IZR_le; lia]. + apply bpow_mag_gt; apply IZR_neq; lia. + + rewrite Rmult_assoc, <- bpow_plus. + now replace (_ + _)%Z with ex by ring. +- unfold bounded, F2R; simpl. + assert (Dmx' : (Z.pos (digits2_pos mx) < prec)%Z). + { now rewrite <-(Z2Pos.id prec); [|now apply prec_gt_0_]. } + split; [|split]. + + unfold bounded; apply andb_true_intro. + split ; cycle 1. + { apply Zle_bool_true. clear -Hp ; lia. } + apply Zeq_bool_true; unfold fexp, FLT_exp. + rewrite Zpos_digits2_pos, shift_pos_correct, Z.pow_pos_fold. + rewrite Z2Pos.id; [|lia]. + rewrite Z.mul_comm; change 2%Z with (radix2 : Z). + rewrite Zdigits_mult_Zpower; [|lia|lia]. + rewrite Zpos_digits2_pos; replace (_ - _)%Z with (- prec)%Z by ring. + now apply Z.max_l. + + rewrite Rabs_mult, (Rabs_pos_eq (bpow _ _)); [|now apply bpow_ge_0]. + rewrite <-abs_IZR, abs_cond_Zopp; simpl. + rewrite shift_pos_correct, mult_IZR. + change (IZR (Z.pow_pos _ _)) + with (bpow radix2 (Z.pos (Z.to_pos ((prec - Z.pos (digits2_pos mx)))))). + rewrite Z2Pos.id; [|lia]. + rewrite Rmult_comm, <-Rmult_assoc, <-bpow_plus. + set (d := Z.pos (digits2_pos mx)). + replace (_ + _)%Z with (- d)%Z by ring; split. + * apply (Rmult_le_reg_l (bpow radix2 d)); [now apply bpow_gt_0|]. + rewrite <-Rmult_assoc, <-bpow_plus, Z.add_opp_diag_r. + rewrite Rmult_1_l. + change (/ 2)%R with (bpow radix2 (- 1)); rewrite <-bpow_plus. + rewrite <-(Rabs_pos_eq (IZR _)); [|apply IZR_le; lia]. + unfold d; rewrite Zpos_digits2_pos, Zdigits_mag; [|lia]. + apply bpow_mag_le; apply IZR_neq; lia. + * apply (Rmult_lt_reg_l (bpow radix2 d)); [now apply bpow_gt_0|]. + rewrite <-Rmult_assoc, <-bpow_plus, Z.add_opp_diag_r. + rewrite Rmult_1_l, Rmult_1_r. + rewrite <-(Rabs_pos_eq (IZR _)); [|apply IZR_le; lia]. + unfold d; rewrite Zpos_digits2_pos, Zdigits_mag; [|lia]. + apply bpow_mag_gt; apply IZR_neq; lia. + + rewrite Rmult_assoc, <-bpow_plus, shift_pos_correct. + rewrite IZR_cond_Zopp, mult_IZR, cond_Ropp_mult_r, <-IZR_cond_Zopp. + change (IZR (Z.pow_pos _ _)) + with (bpow radix2 (Z.pos (Z.to_pos (prec - Z.pos (digits2_pos mx))))). + rewrite Z2Pos.id; [|lia]. + rewrite Rmult_comm, <-Rmult_assoc, <-bpow_plus. + now replace (_ + _)%Z with ex by ring; rewrite Rmult_comm. +Qed. + +Definition Bfrexp f := + match f with + | B754_finite s m e H => + let e' := snd (Ffrexp_core_binary s m e) in + (SF2B _ (proj1 (Bfrexp_correct_aux s m e H)), e') + | _ => (f, (-2*emax-prec)%Z) + end. + +Theorem is_nan_Bfrexp : + forall x, + is_nan (fst (Bfrexp x)) = is_nan x. +Proof. +intros [sx|sx| |sx mx ex Bx] ; try easy. +simpl. +rewrite is_nan_SF2B. +unfold Ffrexp_core_binary. +destruct Zlt_bool ; try easy. +now destruct Pos.leb. +Qed. + +Theorem Bfrexp_correct : + forall f, + is_finite_strict f = true -> + let (z, e) := Bfrexp f in + (B2R f = B2R z * bpow radix2 e)%R /\ + ( (2 < emax)%Z -> (/2 <= Rabs (B2R z) < 1)%R /\ e = mag radix2 (B2R f) ). +Proof. +intro f; case f; intro s; try discriminate; intros m e Hf _. +generalize (Bfrexp_correct_aux s m e Hf). +intros (_, (Hb, Heq)); simpl; rewrite B2R_SF2B. +split. +easy. +intros Hp. +specialize (Hb Hp). +split. +easy. +rewrite Heq, mag_mult_bpow. +- apply (Z.add_reg_l (- (snd (Ffrexp_core_binary s m e)))). + now ring_simplify; symmetry; apply mag_unique. +- intro H; destruct Hb as (Hb, _); revert Hb; rewrite H, Rabs_R0; lra. +Qed. + +(** Ulp *) + +Lemma Bulp_correct_aux : + bounded 1 emin = true. +Proof. +unfold bounded, canonical_mantissa. +rewrite Zeq_bool_true. +apply Zle_bool_true. +unfold emin. +generalize (prec_gt_0 prec) (prec_lt_emax prec emax). +lia. +apply Z.max_r. +simpl digits2_pos. +generalize (prec_gt_0 prec). +lia. +Qed. + +Definition Bulp x := + match x with + | B754_zero _ => B754_finite false 1 emin Bulp_correct_aux + | B754_infinity _ => B754_infinity false + | B754_nan => B754_nan + | B754_finite _ _ e _ => binary_normalize mode_ZR 1 e false + end. + +Theorem is_nan_Bulp : + forall x, + is_nan (Bulp x) = is_nan x. +Proof. +intros [sx|sx| |sx mx ex Bx] ; try easy. +unfold Bulp. +apply is_nan_binary_normalize. +Qed. + +Theorem Bulp_correct : + forall x, + is_finite x = true -> + B2R (Bulp x) = ulp radix2 fexp (B2R x) /\ + is_finite (Bulp x) = true /\ + Bsign (Bulp x) = false. +Proof. +intros [sx|sx| |sx mx ex Hx] Fx ; try easy ; simpl. +- repeat split. + change fexp with (FLT_exp emin prec). + rewrite ulp_FLT_0 by easy. + apply F2R_bpow. +- destruct (binary_round_correct mode_ZR false 1 ex) as [H1 H2]. + revert H2. + simpl. + destruct (andb_prop _ _ Hx) as [H5 H6]. + replace (round _ _ _ _) with (bpow radix2 ex). + rewrite Rlt_bool_true. + intros [H2 [H3 H4]]. + split ; [|split]. + + rewrite B2R_SF2B. + rewrite ulp_canonical. + exact H2. + now case sx. + now apply canonical_canonical_mantissa. + + now rewrite is_finite_SF2B. + + now rewrite Bsign_SF2B. + + rewrite Rabs_pos_eq by apply bpow_ge_0. + apply bpow_lt. + generalize (prec_gt_0 prec) (Zle_bool_imp_le _ _ H6). + clear ; lia. + + rewrite F2R_bpow. + apply sym_eq, round_generic. + typeclasses eauto. + apply generic_format_FLT_bpow. + easy. + rewrite (canonical_canonical_mantissa false _ _ H5). + apply Z.max_le_iff. + now right. +Qed. + +Theorem is_finite_strict_Bulp : + forall x, + is_finite_strict (Bulp x) = is_finite x. +Proof. +intros [sx|sx| |sx mx ex Bx] ; try easy. +generalize (Bulp_correct (B754_finite sx mx ex Bx) eq_refl). +destruct Bulp as [sy| | |] ; try easy. +intros [H _]. +contradict H. +rewrite ulp_neq_0. +apply Rlt_not_eq. +apply bpow_gt_0. +apply F2R_neq_0. +now destruct sx. +Qed. + +Definition Bulp' x := Bldexp mode_NE Bone (fexp (snd (Bfrexp x))). + +Theorem Bulp'_correct : + (2 < emax)%Z -> + forall x, + is_finite x = true -> + Bulp' x = Bulp x. +Proof. +intros Hp x Fx. +assert (B2R (Bulp' x) = ulp radix2 fexp (B2R x) /\ + is_finite (Bulp' x) = true /\ + Bsign (Bulp' x) = false) as [H1 [H2 H3]]. +{ destruct x as [sx|sx| |sx mx ex Hx] ; unfold Bulp'. +- replace (fexp _) with emin. + + generalize (Bldexp_correct mode_NE Bone emin). + rewrite Bone_correct, Rmult_1_l, round_generic; + [|now apply valid_rnd_N|apply generic_format_bpow; unfold fexp, FLT_exp; + rewrite Z.max_r; unfold Prec_gt_0 in prec_gt_0_; lia]. + rewrite Rlt_bool_true. + * intros (Hr, (Hf, Hs)); rewrite Hr, Hf, Hs. + split; [|now split; [apply is_finite_Bone|apply Bsign_Bone]]. + simpl; unfold ulp; rewrite Req_bool_true; [|reflexivity]. + destruct (negligible_exp_FLT emin prec) as (n, (Hn, Hn')). + change fexp with (FLT_exp emin prec); rewrite Hn. + now unfold FLT_exp; rewrite Z.max_r; + [|unfold Prec_gt_0 in prec_gt_0_; lia]. + * rewrite Rabs_pos_eq; [|now apply bpow_ge_0]; apply bpow_lt. + unfold emin; unfold Prec_gt_0 in prec_gt_0_; lia. + + simpl; change (fexp _) with (fexp (-2 * emax - prec)). + unfold fexp, FLT_exp; rewrite Z.max_r; [reflexivity|]. + unfold emin; unfold Prec_gt_0 in prec_gt_0_; lia. +- discriminate. +- discriminate. +- unfold ulp, cexp. + set (f := B754_finite _ _ _ _). + rewrite Req_bool_false. + + destruct (Bfrexp_correct f (eq_refl _)) as (Hfr1, (Hfr2, Hfr3)). + apply Hp. + simpl. + rewrite Hfr3. + set (e' := fexp _). + generalize (Bldexp_correct mode_NE Bone e'). + rewrite Bone_correct, Rmult_1_l, round_generic; [|now apply valid_rnd_N|]. + { rewrite Rlt_bool_true. + - intros (Hr, (Hf, Hs)); rewrite Hr, Hf, Hs. + now split; [|split; [apply is_finite_Bone|apply Bsign_Bone]]. + - rewrite Rabs_pos_eq; [|now apply bpow_ge_0]. + unfold e', fexp, FLT_exp. + apply bpow_lt. + case (Z.max_spec (mag radix2 (B2R f) - prec) emin) + as [(_, Hm)|(_, Hm)]; rewrite Hm; + [now unfold emin; unfold Prec_gt_0 in prec_gt_0_; lia|]. + apply (Zplus_lt_reg_r _ _ prec); ring_simplify. + assert (mag radix2 (B2R f) <= emax)%Z; + [|now unfold Prec_gt_0 in prec_gt_0_; lia]. + apply mag_le_bpow; [|now apply abs_B2R_lt_emax]. + now unfold f, B2R; apply F2R_neq_0; case sx. } + apply generic_format_bpow, Z.max_lub. + * unfold Prec_gt_0 in prec_gt_0_; lia. + * apply Z.le_max_r. + + now unfold f, B2R; apply F2R_neq_0; case sx. } +destruct (Bulp_correct x Fx) as [H4 [H5 H6]]. +apply B2R_Bsign_inj ; try easy. +now rewrite H4. +now rewrite H3. +Qed. + +(** Successor (and predecessor) *) + +Definition Bsucc x := + match x with + | B754_zero _ => B754_finite false 1 emin Bulp_correct_aux + | B754_infinity false => x + | B754_infinity true => Bopp Bmax_float + | B754_nan => B754_nan + | B754_finite false mx ex _ => + SF2B _ (proj1 (binary_round_correct mode_UP false (mx + 1) ex)) + | B754_finite true mx ex _ => + SF2B _ (proj1 (binary_round_correct mode_ZR true (xO mx - 1) (ex - 1))) + end. + +Theorem is_nan_Bsucc : + forall x, + is_nan (Bsucc x) = is_nan x. +Proof. +unfold Bsucc. +intros [sx|[|]| |[|] mx ex Bx] ; try easy. +rewrite is_nan_SF2B. +apply is_nan_binary_round. +rewrite is_nan_SF2B. +apply is_nan_binary_round. +Qed. + +Theorem Bsucc_correct : + forall x, + is_finite x = true -> + if Rlt_bool (succ radix2 fexp (B2R x)) (bpow radix2 emax) then + B2R (Bsucc x) = succ radix2 fexp (B2R x) /\ + is_finite (Bsucc x) = true /\ + (Bsign (Bsucc x) = Bsign x && is_finite_strict x)%bool + else + B2SF (Bsucc x) = S754_infinity false. +Proof. +intros [sx|sx| | [|] mx ex Bx] Hx ; try easy ; clear Hx. +- simpl. + change fexp with (FLT_exp emin prec). + rewrite succ_0, ulp_FLT_0 by easy. + rewrite Rlt_bool_true. + repeat split ; cycle 1. + now case sx. + apply F2R_bpow. + apply bpow_lt. + unfold emin. + generalize (prec_gt_0 prec) (prec_lt_emax prec emax). + lia. +- assert (Cx := proj1 (andb_prop _ _ Bx)). + change (B2R (B754_finite _ _ _ _)) with (F2R (Fopp (Float radix2 (Zpos mx) ex))). + rewrite F2R_opp, succ_opp. + rewrite Rlt_bool_true ; cycle 1. + { apply Rle_lt_trans with 0%R. + 2: apply bpow_gt_0. + rewrite <- Ropp_0. + apply Ropp_le_contravar. + apply pred_ge_0. + now apply FLT_exp_valid. + now apply F2R_gt_0. + apply generic_format_canonical. + now apply (canonical_canonical_mantissa false). } + simpl. + rewrite B2R_SF2B, is_finite_SF2B, Bsign_SF2B. + generalize (binary_round_correct mode_ZR true (xO mx - 1) (ex - 1)). + set (z := binary_round _ _ _ _). + rewrite F2R_cond_Zopp. + simpl. + rewrite round_ZR_opp. + rewrite round_ZR_DN by now apply F2R_ge_0. + assert (H: F2R (Float radix2 (Zpos (xO mx - 1)) (ex - 1)) = (F2R (Float radix2 (Zpos mx) ex) - F2R (Float radix2 1 (ex - 1)))%R). + { rewrite (F2R_change_exp _ (ex - 1) _ ex) by apply Z.le_pred_l. + rewrite <- F2R_minus, Fminus_same_exp. + apply F2R_eq. + replace (ex - (ex - 1))%Z with 1%Z by ring. + now rewrite Zmult_comm. } + rewrite Rlt_bool_true. + + intros [_ [H1 [H2 H3]]]. + split. + 2: now split. + rewrite H1, H. + apply f_equal. + apply round_DN_minus_eps_pos. + now apply FLT_exp_valid. + now apply F2R_gt_0. + apply (generic_format_B2R (B754_finite false mx ex Bx)). + split. + now apply F2R_gt_0. + rewrite F2R_bpow. + change fexp with (FLT_exp emin prec). + destruct (ulp_FLT_pred_pos radix2 emin prec (F2R (Float radix2 (Zpos mx) ex))) as [Hu|[Hu1 Hu2]]. + * apply (generic_format_B2R (B754_finite false mx ex Bx)). + * now apply F2R_ge_0. + * rewrite Hu. + rewrite ulp_canonical. + apply bpow_le. + apply Z.le_pred_l. + easy. + now apply (canonical_canonical_mantissa false). + * rewrite Hu2. + rewrite ulp_canonical. + rewrite <- (Zmult_1_r radix2). + change (_ / _)%R with (bpow radix2 ex * bpow radix2 (-1))%R. + rewrite <- bpow_plus. + apply Rle_refl. + easy. + now apply (canonical_canonical_mantissa false). + + rewrite Rabs_Ropp, Rabs_pos_eq. + eapply Rle_lt_trans. + 2: apply bounded_lt_emax with (1 := Bx). + apply Rle_trans with (F2R (Float radix2 (Zpos (xO mx - 1)) (ex - 1))). + apply round_DN_pt. + now apply FLT_exp_valid. + rewrite H. + rewrite <- (Rminus_0_r (F2R _)) at 2. + apply Rplus_le_compat_l. + apply Ropp_le_contravar. + now apply F2R_ge_0. + apply round_DN_pt. + now apply FLT_exp_valid. + apply generic_format_0. + now apply F2R_ge_0. +- assert (Cx := proj1 (andb_prop _ _ Bx)). + apply (canonical_canonical_mantissa false) in Cx. + replace (succ _ _ _) with (F2R (Float radix2 (Zpos mx + 1) ex)) ; cycle 1. + { unfold succ, B2R. + rewrite Rle_bool_true by now apply F2R_ge_0. + rewrite ulp_canonical by easy. + rewrite <- F2R_bpow. + rewrite <- F2R_plus. + now rewrite Fplus_same_exp. } + simpl. + rewrite B2R_SF2B, is_finite_SF2B, Bsign_SF2B. + generalize (binary_round_correct mode_UP false (mx + 1) ex). + simpl. + rewrite round_generic. + + rewrite Rabs_pos_eq by now apply F2R_ge_0. + case Rlt_bool_spec ; intros Hs. + now intros [_ H]. + intros H. + rewrite B2SF_SF2B. + now rewrite (proj2 H). + + apply valid_rnd_UP. + + destruct (mag radix2 (F2R (Float radix2 (Zpos mx) ex))) as [e He]. + rewrite Rabs_pos_eq in He by now apply F2R_ge_0. + refine (_ (He _)). + 2: now apply F2R_neq_0. + clear He. intros He. + destruct (F2R_p1_le_bpow _ (Zpos mx) _ _ eq_refl (proj2 He)) as [H|H]. + * apply generic_format_F2R. + intros _. + rewrite Cx at 2. + apply cexp_ge_bpow. + apply FLT_exp_monotone. + rewrite Rabs_pos_eq by now apply F2R_ge_0. + rewrite (mag_unique_pos _ _ e). + apply He. + split. + apply Rle_trans with (1 := proj1 He). + apply F2R_le. + apply Z.le_succ_diag_r. + exact H. + * simpl in H. + rewrite H. + apply generic_format_FLT_bpow. + easy. + apply le_bpow with radix2. + apply Rlt_le. + apply Rle_lt_trans with (2 := proj2 He). + apply generic_format_ge_bpow with fexp. + intros e'. + apply Z.le_max_r. + now apply F2R_gt_0. + now apply generic_format_canonical. +Qed. + +Definition Bpred x := Bopp (Bsucc (Bopp x)). + +Theorem is_nan_Bpred : + forall x, + is_nan (Bpred x) = is_nan x. +Proof. +intros x. +unfold Bpred. +rewrite is_nan_Bopp, is_nan_Bsucc. +apply is_nan_Bopp. +Qed. + +Theorem Bpred_correct : + forall x, + is_finite x = true -> + if Rlt_bool (- bpow radix2 emax) (pred radix2 fexp (B2R x)) then + B2R (Bpred x) = pred radix2 fexp (B2R x) /\ + is_finite (Bpred x) = true /\ + (Bsign (Bpred x) = Bsign x || negb (is_finite_strict x))%bool + else + B2SF (Bpred x) = S754_infinity true. +Proof. +intros x Fx. +assert (Fox : is_finite (Bopp x) = true). +{ now rewrite is_finite_Bopp. } +rewrite <-(Ropp_involutive (B2R x)), <-B2R_Bopp. +rewrite pred_opp, Rlt_bool_opp. +generalize (Bsucc_correct _ Fox). +case (Rlt_bool _ _). +- intros (HR, (HF, HS)); unfold Bpred. + rewrite B2R_Bopp, HR, is_finite_Bopp. + rewrite <-(Bool.negb_involutive (Bsign x)), <-Bool.negb_andb. + apply (conj eq_refl). + apply (conj HF). + rewrite Bsign_Bopp, <-(Bsign_Bopp x), HS. + + now rewrite is_finite_strict_Bopp. + + now revert Fx; case x. + + now revert HF; case (Bsucc _). +- now unfold Bpred; case (Bsucc _); intro s; case s. +Qed. + +Definition Bpred_pos' x := + match x with + | B754_finite _ mx _ _ => + let d := + if (mx~0 =? shift_pos (Z.to_pos prec) 1)%positive then + Bldexp mode_NE Bone (fexp (snd (Bfrexp x) - 1)) + else + Bulp' x in + Bminus mode_NE x d + | _ => x + end. + +Theorem Bpred_pos'_correct : + (2 < emax)%Z -> + forall x, + (0 < B2R x)%R -> + Bpred_pos' x = Bpred x. +Proof. +intros Hp x Fx. +assert (B2R (Bpred_pos' x) = pred_pos radix2 fexp (B2R x) /\ + is_finite (Bpred_pos' x) = true /\ + Bsign (Bpred_pos' x) = false) as [H1 [H2 H3]]. +{ generalize (Bfrexp_correct x). + destruct x as [sx|sx| |sx mx ex Bx] ; try elim (Rlt_irrefl _ Fx). + intros Hfrexpx. + assert (Hsx : sx = false). + { apply gt_0_F2R in Fx. + revert Fx. + now case sx. } + clear Fx. + rewrite Hsx in Hfrexpx |- *; clear Hsx sx. + specialize (Hfrexpx (eq_refl _)). + simpl in Hfrexpx; rewrite B2R_SF2B in Hfrexpx. + destruct Hfrexpx as (Hfrexpx_bounds, (Hfrexpx_eq, Hfrexpx_exp)). + apply Hp. + unfold Bpred_pos', Bfrexp. + simpl (snd (_, snd _)). + rewrite Hfrexpx_exp. + set (x' := B754_finite _ _ _ _). + set (xr := F2R _). + assert (Nzxr : xr <> 0%R). + { unfold xr, F2R; simpl. + rewrite <-(Rmult_0_l (bpow radix2 ex)); intro H. + apply Rmult_eq_reg_r in H; [|apply Rgt_not_eq, bpow_gt_0]. + apply eq_IZR in H; lia. } + assert (Hulp := Bulp_correct x' (eq_refl _)). + rewrite <- (Bulp'_correct Hp x') in Hulp by easy. + assert (Hldexp := Bldexp_correct mode_NE Bone (fexp (mag radix2 xr - 1))). + rewrite Bone_correct, Rmult_1_l in Hldexp. + assert (Fbpowxr : generic_format radix2 fexp + (bpow radix2 (fexp (mag radix2 xr - 1)))). + { apply generic_format_bpow, Z.max_lub. + - unfold Prec_gt_0 in prec_gt_0_; lia. + - apply Z.le_max_r. } + assert (H : Rlt_bool (Rabs + (round radix2 fexp (round_mode mode_NE) + (bpow radix2 (fexp (mag radix2 xr - 1))))) + (bpow radix2 emax) = true); [|rewrite H in Hldexp; clear H]. + { apply Rlt_bool_true; rewrite round_generic; + [|apply valid_rnd_round_mode|apply Fbpowxr]. + rewrite Rabs_pos_eq; [|apply bpow_ge_0]; apply bpow_lt. + apply Z.max_lub_lt; [|unfold emin; unfold Prec_gt_0 in prec_gt_0_; lia]. + apply (Zplus_lt_reg_r _ _ (prec + 1)); ring_simplify. + rewrite Z.add_1_r; apply Zle_lt_succ, mag_le_bpow. + - exact Nzxr. + - apply (Rlt_le_trans _ (bpow radix2 emax)). + + change xr with (B2R x'); apply abs_B2R_lt_emax. + + apply bpow_le; unfold Prec_gt_0 in prec_gt_0_; lia. } + set (d := if (mx~0 =? _)%positive then _ else _). + assert (Hminus := Bminus_correct mode_NE x' d (eq_refl _)). + assert (Fd : is_finite d = true). + { unfold d; case (_ =? _)%positive. + - now rewrite (proj1 (proj2 Hldexp)), is_finite_Bone. + - now rewrite (proj1 (proj2 Hulp)). } + specialize (Hminus Fd). + assert (Px : (0 <= B2R x')%R). + { unfold B2R, x', F2R; simpl. + now apply Rmult_le_pos; [apply IZR_le|apply bpow_ge_0]. } + assert (Pd : (0 <= B2R d)%R). + { unfold d; case (_ =? _)%positive. + - rewrite (proj1 Hldexp). + now rewrite round_generic; [apply bpow_ge_0|apply valid_rnd_N|]. + - rewrite (proj1 Hulp); apply ulp_ge_0. } + assert (Hdlex : (B2R d <= B2R x')%R). + { unfold d; case (_ =? _)%positive. + - rewrite (proj1 Hldexp). + rewrite round_generic; [|now apply valid_rnd_N|now simpl]. + apply (Rle_trans _ (bpow radix2 (mag radix2 xr - 1))). + + apply bpow_le, Z.max_lub. + * unfold Prec_gt_0 in prec_gt_0_; lia. + * apply (Zplus_le_reg_r _ _ 1); ring_simplify. + apply mag_ge_bpow. + replace (_ - 1)%Z with emin by ring. + now change xr with (B2R x'); apply abs_B2R_ge_emin. + + rewrite <-(Rabs_pos_eq _ Px). + now change xr with (B2R x'); apply bpow_mag_le. + - rewrite (proj1 Hulp); apply ulp_le_id. + + assert (B2R x' <> 0%R); [exact Nzxr|lra]. + + apply generic_format_B2R. } + assert (H : Rlt_bool + (Rabs + (round radix2 fexp + (round_mode mode_NE) (B2R x' - B2R d))) + (bpow radix2 emax) = true); [|rewrite H in Hminus; clear H]. + { apply Rlt_bool_true. + rewrite <-round_NE_abs; [|now apply FLT_exp_valid]. + rewrite Rabs_pos_eq; [|lra]. + apply (Rle_lt_trans _ (B2R x')). + - apply round_le_generic; + [now apply FLT_exp_valid|now apply valid_rnd_N| |lra]. + apply generic_format_B2R. + - apply (Rle_lt_trans _ _ _ (Rle_abs _)), abs_B2R_lt_emax. } + rewrite (proj1 Hminus). + rewrite (proj1 (proj2 Hminus)). + rewrite (proj2 (proj2 Hminus)). + split; [|split; [reflexivity|now case (Rcompare_spec _ _); [lra| |]]]. + unfold pred_pos, d. + case (Pos.eqb_spec _ _); intro Hd; case (Req_bool_spec _ _); intro Hpred. + + rewrite (proj1 Hldexp). + rewrite (round_generic _ _ _ _ Fbpowxr). + change xr with (B2R x'). + replace (_ - _)%R with (pred_pos radix2 fexp (B2R x')). + * rewrite round_generic; [reflexivity|now apply valid_rnd_N|]. + apply generic_format_pred_pos; + [now apply FLT_exp_valid|apply generic_format_B2R|]. + change xr with (B2R x') in Nzxr; lra. + * now unfold pred_pos; rewrite Req_bool_true. + + exfalso; apply Hpred. + assert (Hmx : IZR (Z.pos mx) = bpow radix2 (prec - 1)). + { apply (Rmult_eq_reg_l 2); [|lra]; rewrite <-mult_IZR. + change (2 * Z.pos mx)%Z with (Z.pos mx~0); rewrite Hd. + rewrite shift_pos_correct, Z.mul_1_r. + change (IZR (Z.pow_pos _ _)) with (bpow radix2 (Z.pos (Z.to_pos prec))). + rewrite Z2Pos.id; [|exact prec_gt_0_]. + change 2%R with (bpow radix2 1); rewrite <-bpow_plus. + f_equal; ring. } + unfold x' at 1; unfold B2R at 1; unfold F2R; simpl. + rewrite Hmx, <-bpow_plus; f_equal. + apply (Z.add_reg_l 1); ring_simplify; symmetry; apply mag_unique_pos. + unfold F2R; simpl; rewrite Hmx, <-bpow_plus; split. + * right; f_equal; ring. + * apply bpow_lt; lia. + + rewrite (proj1 Hulp). + assert (H : ulp radix2 fexp (B2R x') + = bpow radix2 (fexp (mag radix2 (B2R x') - 1))); + [|rewrite H; clear H]. + { unfold ulp; rewrite Req_bool_false; [|now simpl]. + unfold cexp; f_equal. + assert (H : (mag radix2 (B2R x') <= emin + prec)%Z). + { assert (Hcm : canonical_mantissa mx ex = true). + { now generalize Bx; unfold bounded; rewrite Bool.andb_true_iff. } + apply (canonical_canonical_mantissa false) in Hcm. + revert Hcm; fold emin; unfold canonical, cexp; simpl. + change (F2R _) with (B2R x'); intro Hex. + apply Z.nlt_ge; intro H'; apply Hd. + apply Pos2Z.inj_pos; rewrite shift_pos_correct, Z.mul_1_r. + apply eq_IZR; change (IZR (Z.pow_pos _ _)) + with (bpow radix2 (Z.pos (Z.to_pos prec))). + rewrite Z2Pos.id; [|exact prec_gt_0_]. + change (Z.pos mx~0) with (2 * Z.pos mx)%Z. + rewrite Z.mul_comm, mult_IZR. + apply (Rmult_eq_reg_r (bpow radix2 (ex - 1))); + [|apply Rgt_not_eq, bpow_gt_0]. + change 2%R with (bpow radix2 1); rewrite Rmult_assoc, <-!bpow_plus. + replace (1 + _)%Z with ex by ring. + unfold B2R at 1, F2R in Hpred; simpl in Hpred; rewrite Hpred. + change (F2R _) with (B2R x'); rewrite Hex. + unfold fexp, FLT_exp; rewrite Z.max_l; [f_equal; ring|lia]. } + now unfold fexp, FLT_exp; do 2 (rewrite Z.max_r; [|lia]). } + replace (_ - _)%R with (pred_pos radix2 fexp (B2R x')). + * rewrite round_generic; [reflexivity|apply valid_rnd_N|]. + apply generic_format_pred_pos; + [now apply FLT_exp_valid| |change xr with (B2R x') in Nzxr; lra]. + apply generic_format_B2R. + * now unfold pred_pos; rewrite Req_bool_true. + + rewrite (proj1 Hulp). + replace (_ - _)%R with (pred_pos radix2 fexp (B2R x')). + * rewrite round_generic; [reflexivity|now apply valid_rnd_N|]. + apply generic_format_pred_pos; + [now apply FLT_exp_valid|apply generic_format_B2R|]. + change xr with (B2R x') in Nzxr; lra. + * now unfold pred_pos; rewrite Req_bool_false. } +assert (is_finite x = true /\ Bsign x = false) as [H4 H5]. +{ clear -Fx. + destruct x as [| | |sx mx ex Hx] ; try elim Rlt_irrefl with (1 := Fx). + repeat split. + destruct sx. + elim Rlt_not_le with (1 := Fx). + now apply F2R_le_0. + easy. } +generalize (Bpred_correct x H4). +rewrite Rlt_bool_true ; cycle 1. +{ apply Rlt_le_trans with 0%R. + rewrite <- Ropp_0. + apply Ropp_lt_contravar. + apply bpow_gt_0. + apply pred_ge_0. + now apply FLT_exp_valid. + exact Fx. + apply generic_format_B2R. } +intros [H7 [H8 H9]]. +apply eq_sym. +apply B2R_Bsign_inj ; try easy. +rewrite H7, H1. +apply pred_eq_pos. +now apply Rlt_le. +rewrite H9, H3. +rewrite is_finite_strict_B2R by now apply Rgt_not_eq. +now rewrite H5. +Qed. + +Definition Bsucc' x := + match x with + | B754_zero _ => Bldexp mode_NE Bone emin + | B754_infinity false => x + | B754_infinity true => Bopp Bmax_float + | B754_nan => B754_nan + | B754_finite false _ _ _ => Bplus mode_NE x (Bulp x) + | B754_finite true _ _ _ => Bopp (Bpred_pos' (Bopp x)) + end. + +Theorem Bsucc'_correct : + (2 < emax)%Z -> + forall x, + is_finite x = true -> + Bsucc' x = Bsucc x. +Proof. +intros Hp x Fx. +destruct x as [sx|sx| |sx mx ex Bx] ; try easy. +{ generalize (Bldexp_correct mode_NE Bone emin). + rewrite Bone_correct, Rmult_1_l. + rewrite round_generic. + rewrite Rlt_bool_true. + simpl. + intros [H1 [H2 H3]]. + apply B2R_inj. + apply is_finite_strict_B2R. + rewrite H1. + apply Rgt_not_eq. + apply bpow_gt_0. + easy. + rewrite H1. + apply eq_sym, F2R_bpow. + rewrite Rabs_pos_eq. + apply bpow_lt. + unfold emin. + generalize (prec_gt_0 prec) (prec_lt_emax prec emax). + lia. + apply bpow_ge_0. + apply valid_rnd_N. + apply generic_format_bpow. + unfold fexp. + rewrite Z.max_r. + apply Z.le_refl. + generalize (prec_gt_0 prec). + lia. } +set (x := B754_finite sx mx ex Bx). +assert (H: + if Rlt_bool (succ radix2 fexp (B2R x)) (bpow radix2 emax) then + B2R (Bsucc' x) = succ radix2 fexp (B2R x) /\ + is_finite (Bsucc' x) = true /\ + Bsign (Bsucc' x) = sx + else + B2SF (Bsucc' x) = S754_infinity false). +{ + assert (Hsucc : succ radix2 fexp 0 = bpow radix2 emin). + { rewrite succ_0. + now apply ulp_FLT_0. } + unfold Bsucc', x; destruct sx. + + case Rlt_bool_spec; intro Hover. + * rewrite B2R_Bopp; simpl (Bopp (B754_finite _ _ _ _)). + rewrite is_finite_Bopp. + set (ox := B754_finite false mx ex Bx). + assert (Hpred := Bpred_correct ox eq_refl). + rewrite Bpred_pos'_correct ; cycle 1. + exact Hp. + now apply F2R_gt_0. + rewrite Rlt_bool_true in Hpred. + rewrite (proj1 Hpred), (proj1 (proj2 Hpred)). + split. + rewrite <- succ_opp. + simpl. + now rewrite <- F2R_opp. + apply (conj eq_refl). + rewrite Bsign_Bopp, (proj2 (proj2 Hpred)). + easy. + generalize (proj1 (proj2 Hpred)). + now case Bpred. + apply Rlt_le_trans with 0%R. + rewrite <- Ropp_0. + apply Ropp_lt_contravar, bpow_gt_0. + apply pred_ge_0. + now apply FLT_exp_valid. + now apply F2R_gt_0. + apply generic_format_B2R. + * exfalso; revert Hover; apply Rlt_not_le. + apply (Rle_lt_trans _ (succ radix2 fexp 0)). + { apply succ_le; [now apply FLT_exp_valid|apply generic_format_B2R| + apply generic_format_0|]. + unfold B2R, F2R; simpl; change (Z.neg mx) with (- Z.pos mx)%Z. + rewrite opp_IZR, <-Ropp_mult_distr_l, <-Ropp_0; apply Ropp_le_contravar. + now apply Rmult_le_pos; [apply IZR_le|apply bpow_ge_0]. } + rewrite Hsucc; apply bpow_lt. + unfold emin. + generalize (prec_gt_0 prec) (prec_lt_emax prec emax). + lia. + + fold x. + assert (Hulp := Bulp_correct x (eq_refl _)). + assert (Hplus := Bplus_correct mode_NE x (Bulp x) (eq_refl _)). + rewrite (proj1 (proj2 Hulp)) in Hplus; specialize (Hplus (eq_refl _)). + assert (Px : (0 <= B2R x)%R). + { now apply F2R_ge_0. } + assert (Hsucc' : (succ radix2 fexp (B2R x) + = B2R x + ulp radix2 fexp (B2R x))%R). + { now unfold succ; rewrite (Rle_bool_true _ _ Px). } + rewrite (proj1 Hulp), <- Hsucc' in Hplus. + rewrite round_generic in Hplus; + [|apply valid_rnd_N| now apply generic_format_succ; + [apply FLT_exp_valid|apply generic_format_B2R]]. + rewrite Rabs_pos_eq in Hplus; [|apply (Rle_trans _ _ _ Px), succ_ge_id]. + revert Hplus; case Rlt_bool_spec; intros Hover Hplus. + * split; [now simpl|split; [now simpl|]]. + rewrite (proj2 (proj2 Hplus)); case Rcompare_spec. + { intro H; exfalso; revert H. + apply Rle_not_lt, (Rle_trans _ _ _ Px), succ_ge_id. } + { intro H; exfalso; revert H; apply Rgt_not_eq, Rlt_gt. + apply (Rlt_le_trans _ (B2R x)); [|apply succ_ge_id]. + now apply Rmult_lt_0_compat; [apply IZR_lt|apply bpow_gt_0]. } + now simpl. + * now rewrite (proj1 Hplus). } +generalize (Bsucc_correct x Fx). +revert H. +case Rlt_bool_spec ; intros H. +intros [H1 [H2 H3]] [H4 [H5 H6]]. +apply B2R_Bsign_inj ; try easy. +now rewrite H4. +rewrite H3, H6. +simpl. +now case sx. +intros H1 H2. +apply B2SF_inj. +now rewrite H1, H2. +Qed. + +End Binary. + +Arguments B754_zero {prec} {emax}. +Arguments B754_infinity {prec} {emax}. +Arguments B754_nan {prec} {emax}. +Arguments B754_finite {prec} {emax}. + +Arguments SF2B {prec} {emax}. +Arguments B2SF {prec} {emax}. +Arguments B2R {prec} {emax}. + +Arguments is_finite_strict {prec} {emax}. +Arguments is_finite {prec} {emax}. +Arguments is_nan {prec} {emax}. + +Arguments erase {prec} {emax}. +Arguments Bsign {prec} {emax}. +Arguments Bcompare {prec} {emax}. +Arguments Beqb {prec} {emax}. +Arguments Bltb {prec} {emax}. +Arguments Bleb {prec} {emax}. +Arguments Bopp {prec} {emax}. +Arguments Babs {prec} {emax}. +Arguments Bone {prec} {emax} {prec_gt_0_} {prec_lt_emax_}. +Arguments Bmax_float {prec} {emax} {prec_gt_0_} {prec_lt_emax_}. + +Arguments Bplus {prec} {emax} {prec_gt_0_} {prec_lt_emax_}. +Arguments Bminus {prec} {emax} {prec_gt_0_} {prec_lt_emax_}. +Arguments Bmult {prec} {emax} {prec_gt_0_} {prec_lt_emax_}. +Arguments Bfma {prec} {emax} {prec_gt_0_} {prec_lt_emax_}. +Arguments Bdiv {prec} {emax} {prec_gt_0_} {prec_lt_emax_}. +Arguments Bsqrt {prec} {emax} {prec_gt_0_} {prec_lt_emax_}. + +Arguments Bldexp {prec} {emax} {prec_gt_0_} {prec_lt_emax_}. +Arguments Bnormfr_mantissa {prec} {emax}. +Arguments Bfrexp {prec} {emax} {prec_gt_0_}. +Arguments Bulp {prec} {emax} {prec_gt_0_} {prec_lt_emax_}. +Arguments Bulp' {prec} {emax} {prec_gt_0_} {prec_lt_emax_}. +Arguments Bsucc {prec} {emax} {prec_gt_0_} {prec_lt_emax_}. +Arguments Bpred {prec} {emax} {prec_gt_0_} {prec_lt_emax_}. +Arguments Bpred_pos' {prec} {emax} {prec_gt_0_} {prec_lt_emax_}. diff --git a/flocq/IEEE754/Bits.v b/flocq/IEEE754/Bits.v index b38d4900..0a8e6127 100644 --- a/flocq/IEEE754/Bits.v +++ b/flocq/IEEE754/Bits.v @@ -19,8 +19,9 @@ COPYING file for more details. (** * IEEE-754 encoding of binary floating-point data *) -From Coq Require Import Lia. -Require Import Core Digits Binary. +From Coq Require Import ZArith Reals Lia SpecFloat. + +Require Import Core BinarySingleNaN Binary. Section Binary_Bits. @@ -128,10 +129,11 @@ Qed. Hypothesis Hmw : (0 < mw)%Z. Hypothesis Hew : (0 < ew)%Z. -Let emax := Zpower 2 (ew - 1). Let prec := (mw + 1)%Z. -Let emin := (3 - emax - prec)%Z. -Let binary_float := binary_float prec emax. +Let emax := Zpower 2 (ew - 1). +Notation emin := (emin prec emax) (only parsing). +Notation fexp := (fexp prec emax) (only parsing). +Notation binary_float := (binary_float prec emax) (only parsing). Let Hprec : (0 < prec)%Z. Proof. @@ -247,7 +249,7 @@ Theorem split_bits_of_binary_float_correct : Proof. intros [sx|sx|sx plx Hplx|sx mx ex Hx] ; try ( simpl ; apply split_join_bits ; split ; try apply Z.le_refl ; try apply Zlt_pred ; trivial ; lia ). -simpl. apply split_join_bits; split; try (zify; lia). +simpl. apply split_join_bits; split; try lia. destruct (digits2_Pnat_correct plx). unfold nan_pl in Hplx. rewrite Zpos_digits2_pos, <- Z_of_nat_S_digits2_Pnat in Hplx. @@ -255,7 +257,7 @@ rewrite Zpower_nat_Z in H0. eapply Z.lt_le_trans. apply H0. change 2%Z with (radix_val radix2). apply Zpower_le. rewrite Z.ltb_lt in Hplx. -unfold prec in *. zify; lia. +unfold prec in *. lia. (* *) unfold bits_of_binary_float, split_bits_of_binary_float. assert (Hf: (emin <= ex /\ Zdigits radix2 (Zpos mx) <= prec)%Z). @@ -263,9 +265,8 @@ destruct (andb_prop _ _ Hx) as (Hx', _). unfold canonical_mantissa in Hx'. rewrite Zpos_digits2_pos in Hx'. generalize (Zeq_bool_eq _ _ Hx'). -unfold FLT_exp. -unfold emin. -clear ; zify ; lia. +unfold fexp, FLT_exp, emin. +clear ; lia. case Zle_bool_spec ; intros H ; [ apply -> Z.le_0_sub in H | apply -> Z.lt_sub_0 in H ] ; apply split_join_bits ; try now split. @@ -319,7 +320,7 @@ intros [sx|sx|sx pl pl_range|sx mx ex H]. - unfold bounded in H. apply Bool.andb_true_iff in H ; destruct H as [A B]. apply Z.leb_le in B. - unfold canonical_mantissa, FLT_exp in A. apply Zeq_bool_eq in A. + unfold canonical_mantissa, fexp, FLT_exp in A. apply Zeq_bool_eq in A. case Zle_bool_spec ; intros H. + apply join_bits_range. * split. @@ -331,9 +332,10 @@ intros [sx|sx|sx pl pl_range|sx mx ex H]. change (2^1)%Z with 2%Z. clear ; lia. apply (Zpower_gt_Zdigits radix2 _ (Zpos mx)). - clear -A ; zify ; lia. + unfold emin in A. + clear -A ; lia. * split. - unfold emin ; clear -A ; zify ; lia. + unfold emin in A |- * ; clear -A ; lia. replace ew with ((ew - 1) + 1)%Z by ring. rewrite Zpower_plus by (clear - Hew ; lia). unfold emin, emax in *. @@ -444,7 +446,7 @@ now apply Z.lt_gt. apply bounded_canonical_lt_emax ; try assumption. unfold canonical, cexp. rewrite mag_F2R_Zdigits. 2: discriminate. -unfold Fexp, FLT_exp. +unfold Fexp, fexp, FLT_exp. rewrite <- H. set (ex := ((x / 2^mw) mod 2^ew)%Z). replace (prec + (ex + emin - 1) - prec)%Z with (ex + emin - 1)%Z by ring. @@ -536,7 +538,8 @@ rewrite Zpos_digits2_pos. unfold FLT_exp, emin. generalize (Zdigits radix2 (Zpos mx)). clear. -intros ; zify ; lia. +unfold fexp, emin. +intros ; lia. (* . *) rewrite Zeq_bool_true. 2: apply refl_equal. simpl. @@ -549,7 +552,8 @@ apply -> Z.lt_sub_0 in Hm. generalize (Zdigits_le_Zpower radix2 _ (Zpos mx) Hm). generalize (Zdigits radix2 (Zpos mx)). clear. -intros ; zify ; lia. +unfold fexp, emin. +intros ; lia. Qed. Theorem bits_of_binary_float_of_bits : @@ -590,7 +594,7 @@ case Zeq_bool_spec ; intros He2. case_eq mx; intros Hm. now rewrite He2. now rewrite He2. -intros. zify; lia. +intros ; lia. (* normal *) case_eq (mx + 2 ^ mw)%Z. intros Hm. @@ -603,7 +607,7 @@ now ring_simplify (mx + 2^mw - 2^mw)%Z (ex + emin - 1 - emin + 1)%Z. now ring_simplify. intros p Hm. apply False_ind. -clear -Bm Hm ; zify ; lia. +clear -Bm Hm ; lia. Qed. End Binary_Bits. @@ -658,8 +662,8 @@ Definition ternop_nan_pl32 (f1 f2 f3 : binary32) : { nan : binary32 | is_nan 24 Definition b32_erase : binary32 -> binary32 := erase 24 128. Definition b32_opp : binary32 -> binary32 := Bopp 24 128 unop_nan_pl32. Definition b32_abs : binary32 -> binary32 := Babs 24 128 unop_nan_pl32. -Definition b32_pred : binary32 -> binary32 := Bpred _ _ Hprec Hprec_emax Hemax unop_nan_pl32. -Definition b32_succ : binary32 -> binary32 := Bsucc _ _ Hprec Hprec_emax Hemax unop_nan_pl32. +Definition b32_pred : binary32 -> binary32 := Bpred _ _ Hprec Hprec_emax. +Definition b32_succ : binary32 -> binary32 := Bsucc _ _ Hprec Hprec_emax. Definition b32_sqrt : mode -> binary32 -> binary32 := Bsqrt _ _ Hprec Hprec_emax unop_nan_pl32. Definition b32_plus : mode -> binary32 -> binary32 -> binary32 := Bplus _ _ Hprec Hprec_emax binop_nan_pl32. @@ -725,8 +729,8 @@ Definition ternop_nan_pl64 (f1 f2 f3 : binary64) : { nan : binary64 | is_nan 53 Definition b64_erase : binary64 -> binary64 := erase 53 1024. Definition b64_opp : binary64 -> binary64 := Bopp 53 1024 unop_nan_pl64. Definition b64_abs : binary64 -> binary64 := Babs 53 1024 unop_nan_pl64. -Definition b64_pred : binary64 -> binary64 := Bpred _ _ Hprec Hprec_emax Hemax unop_nan_pl64. -Definition b64_succ : binary64 -> binary64 := Bsucc _ _ Hprec Hprec_emax Hemax unop_nan_pl64. +Definition b64_pred : binary64 -> binary64 := Bpred _ _ Hprec Hprec_emax. +Definition b64_succ : binary64 -> binary64 := Bsucc _ _ Hprec Hprec_emax. Definition b64_sqrt : mode -> binary64 -> binary64 := Bsqrt _ _ Hprec Hprec_emax unop_nan_pl64. Definition b64_plus : mode -> binary64 -> binary64 -> binary64 := Bplus _ _ Hprec Hprec_emax binop_nan_pl64. diff --git a/flocq/IEEE754/SpecFloatCompat.v b/flocq/IEEE754/SpecFloatCompat.v deleted file mode 100644 index e2ace4d5..00000000 --- a/flocq/IEEE754/SpecFloatCompat.v +++ /dev/null @@ -1,435 +0,0 @@ -(** -This file is part of the Flocq formalization of floating-point -arithmetic in Coq: http://flocq.gforge.inria.fr/ - -Copyright (C) 2018-2019 Guillaume Bertholon -#
# -Copyright (C) 2018-2019 Érik Martin-Dorel -#
# -Copyright (C) 2018-2019 Pierre Roux - -This library is free software; 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; either -version 3 of the License, or (at your option) any later version. - -This library 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 -COPYING file for more details. -*) - -Require Import ZArith. - -(** ** Inductive specification of floating-point numbers - -Similar to [IEEE754.Binary.full_float], but with no NaN payload. *) -Variant spec_float := - | S754_zero (s : bool) - | S754_infinity (s : bool) - | S754_nan - | S754_finite (s : bool) (m : positive) (e : Z). - -(** ** Parameterized definitions - -[prec] is the number of bits of the mantissa including the implicit one; -[emax] is the exponent of the infinities. - -For instance, Binary64 is defined by [prec = 53] and [emax = 1024]. *) -Section FloatOps. - Variable prec emax : Z. - - Definition emin := (3-emax-prec)%Z. - Definition fexp e := Z.max (e - prec) emin. - - Section Zdigits2. - Fixpoint digits2_pos (n : positive) : positive := - match n with - | xH => xH - | xO p => Pos.succ (digits2_pos p) - | xI p => Pos.succ (digits2_pos p) - end. - - Definition Zdigits2 n := - match n with - | Z0 => n - | Zpos p => Zpos (digits2_pos p) - | Zneg p => Zpos (digits2_pos p) - end. - End Zdigits2. - - Section ValidBinary. - Definition canonical_mantissa m e := - Zeq_bool (fexp (Zpos (digits2_pos m) + e)) e. - - Definition bounded m e := - andb (canonical_mantissa m e) (Zle_bool e (emax - prec)). - - Definition valid_binary x := - match x with - | S754_finite _ m e => bounded m e - | _ => true - end. - End ValidBinary. - - Section Iter. - Context {A : Type}. - Variable (f : A -> A). - - Fixpoint iter_pos (n : positive) (x : A) {struct n} : A := - match n with - | xI n' => iter_pos n' (iter_pos n' (f x)) - | xO n' => iter_pos n' (iter_pos n' x) - | xH => f x - end. - End Iter. - - Section Rounding. - Inductive location := loc_Exact | loc_Inexact : comparison -> location. - - Record shr_record := { shr_m : Z ; shr_r : bool ; shr_s : bool }. - - Definition shr_1 mrs := - let '(Build_shr_record m r s) := mrs in - let s := orb r s in - match m with - | Z0 => Build_shr_record Z0 false s - | Zpos xH => Build_shr_record Z0 true s - | Zpos (xO p) => Build_shr_record (Zpos p) false s - | Zpos (xI p) => Build_shr_record (Zpos p) true s - | Zneg xH => Build_shr_record Z0 true s - | Zneg (xO p) => Build_shr_record (Zneg p) false s - | Zneg (xI p) => Build_shr_record (Zneg p) true s - end. - - Definition loc_of_shr_record mrs := - match mrs with - | Build_shr_record _ false false => loc_Exact - | Build_shr_record _ false true => loc_Inexact Lt - | Build_shr_record _ true false => loc_Inexact Eq - | Build_shr_record _ true true => loc_Inexact Gt - end. - - Definition shr_record_of_loc m l := - match l with - | loc_Exact => Build_shr_record m false false - | loc_Inexact Lt => Build_shr_record m false true - | loc_Inexact Eq => Build_shr_record m true false - | loc_Inexact Gt => Build_shr_record m true true - end. - - Definition shr mrs e n := - match n with - | Zpos p => (iter_pos shr_1 p mrs, (e + n)%Z) - | _ => (mrs, e) - end. - - Definition shr_fexp m e l := - shr (shr_record_of_loc m l) e (fexp (Zdigits2 m + e) - e). - - Definition round_nearest_even mx lx := - match lx with - | loc_Exact => mx - | loc_Inexact Lt => mx - | loc_Inexact Eq => if Z.even mx then mx else (mx + 1)%Z - | loc_Inexact Gt => (mx + 1)%Z - end. - - Definition binary_round_aux sx mx ex lx := - let '(mrs', e') := shr_fexp mx ex lx in - let '(mrs'', e'') := shr_fexp (round_nearest_even (shr_m mrs') (loc_of_shr_record mrs')) e' loc_Exact in - match shr_m mrs'' with - | Z0 => S754_zero sx - | Zpos m => if Zle_bool e'' (emax - prec) then S754_finite sx m e'' else S754_infinity sx - | _ => S754_nan - end. - - Definition shl_align mx ex ex' := - match (ex' - ex)%Z with - | Zneg d => (shift_pos d mx, ex') - | _ => (mx, ex) - end. - - Definition binary_round sx mx ex := - let '(mz, ez) := shl_align mx ex (fexp (Zpos (digits2_pos mx) + ex))in - binary_round_aux sx (Zpos mz) ez loc_Exact. - - Definition binary_normalize m e szero := - match m with - | Z0 => S754_zero szero - | Zpos m => binary_round false m e - | Zneg m => binary_round true m e - end. - End Rounding. - - (** ** Define operations *) - - Definition SFopp x := - match x with - | S754_nan => S754_nan - | S754_infinity sx => S754_infinity (negb sx) - | S754_finite sx mx ex => S754_finite (negb sx) mx ex - | S754_zero sx => S754_zero (negb sx) - end. - - Definition SFabs x := - match x with - | S754_nan => S754_nan - | S754_infinity sx => S754_infinity false - | S754_finite sx mx ex => S754_finite false mx ex - | S754_zero sx => S754_zero false - end. - - Definition SFcompare f1 f2 := - match f1, f2 with - | S754_nan , _ | _, S754_nan => None - | S754_infinity s1, S754_infinity s2 => - Some match s1, s2 with - | true, true => Eq - | false, false => Eq - | true, false => Lt - | false, true => Gt - end - | S754_infinity s, _ => Some (if s then Lt else Gt) - | _, S754_infinity s => Some (if s then Gt else Lt) - | S754_finite s _ _, S754_zero _ => Some (if s then Lt else Gt) - | S754_zero _, S754_finite s _ _ => Some (if s then Gt else Lt) - | S754_zero _, S754_zero _ => Some Eq - | S754_finite s1 m1 e1, S754_finite s2 m2 e2 => - Some match s1, s2 with - | true, false => Lt - | false, true => Gt - | false, false => - match Z.compare e1 e2 with - | Lt => Lt - | Gt => Gt - | Eq => Pcompare m1 m2 Eq - end - | true, true => - match Z.compare e1 e2 with - | Lt => Gt - | Gt => Lt - | Eq => CompOpp (Pcompare m1 m2 Eq) - end - end - end. - - Definition SFeqb f1 f2 := - match SFcompare f1 f2 with - | Some Eq => true - | _ => false - end. - - Definition SFltb f1 f2 := - match SFcompare f1 f2 with - | Some Lt => true - | _ => false - end. - - Definition SFleb f1 f2 := - match SFcompare f1 f2 with - | Some (Lt | Eq) => true - | _ => false - end. - - Variant float_class : Set := - | PNormal | NNormal | PSubn | NSubn | PZero | NZero | PInf | NInf | NaN. - - Definition SFclassify f := - match f with - | S754_nan => NaN - | S754_infinity false => PInf - | S754_infinity true => NInf - | S754_zero false => NZero - | S754_zero true => PZero - | S754_finite false m _ => - if (digits2_pos m =? Z.to_pos prec)%positive then PNormal - else PSubn - | S754_finite true m _ => - if (digits2_pos m =? Z.to_pos prec)%positive then NNormal - else NSubn - end. - - Definition SFmul x y := - match x, y with - | S754_nan, _ | _, S754_nan => S754_nan - | S754_infinity sx, S754_infinity sy => S754_infinity (xorb sx sy) - | S754_infinity sx, S754_finite sy _ _ => S754_infinity (xorb sx sy) - | S754_finite sx _ _, S754_infinity sy => S754_infinity (xorb sx sy) - | S754_infinity _, S754_zero _ => S754_nan - | S754_zero _, S754_infinity _ => S754_nan - | S754_finite sx _ _, S754_zero sy => S754_zero (xorb sx sy) - | S754_zero sx, S754_finite sy _ _ => S754_zero (xorb sx sy) - | S754_zero sx, S754_zero sy => S754_zero (xorb sx sy) - | S754_finite sx mx ex, S754_finite sy my ey => - binary_round_aux (xorb sx sy) (Zpos (mx * my)) (ex + ey) loc_Exact - end. - - Definition cond_Zopp (b : bool) m := if b then Z.opp m else m. - - Definition SFadd x y := - match x, y with - | S754_nan, _ | _, S754_nan => S754_nan - | S754_infinity sx, S754_infinity sy => - if Bool.eqb sx sy then x else S754_nan - | S754_infinity _, _ => x - | _, S754_infinity _ => y - | S754_zero sx, S754_zero sy => - if Bool.eqb sx sy then x else - S754_zero false - | S754_zero _, _ => y - | _, S754_zero _ => x - | S754_finite sx mx ex, S754_finite sy my ey => - let ez := Z.min ex ey in - binary_normalize (Zplus (cond_Zopp sx (Zpos (fst (shl_align mx ex ez)))) (cond_Zopp sy (Zpos (fst (shl_align my ey ez))))) - ez false - end. - - Definition SFsub x y := - match x, y with - | S754_nan, _ | _, S754_nan => S754_nan - | S754_infinity sx, S754_infinity sy => - if Bool.eqb sx (negb sy) then x else S754_nan - | S754_infinity _, _ => x - | _, S754_infinity sy => S754_infinity (negb sy) - | S754_zero sx, S754_zero sy => - if Bool.eqb sx (negb sy) then x else - S754_zero false - | S754_zero _, S754_finite sy my ey => S754_finite (negb sy) my ey - | _, S754_zero _ => x - | S754_finite sx mx ex, S754_finite sy my ey => - let ez := Z.min ex ey in - binary_normalize (Zminus (cond_Zopp sx (Zpos (fst (shl_align mx ex ez)))) (cond_Zopp sy (Zpos (fst (shl_align my ey ez))))) - ez false - end. - - Definition new_location_even nb_steps k := - if Zeq_bool k 0 then loc_Exact - else loc_Inexact (Z.compare (2 * k) nb_steps). - - Definition new_location_odd nb_steps k := - if Zeq_bool k 0 then loc_Exact - else - loc_Inexact - match Z.compare (2 * k + 1) nb_steps with - | Lt => Lt - | Eq => Lt - | Gt => Gt - end. - - Definition new_location nb_steps := - if Z.even nb_steps then new_location_even nb_steps else new_location_odd nb_steps. - - Definition SFdiv_core_binary m1 e1 m2 e2 := - let d1 := Zdigits2 m1 in - let d2 := Zdigits2 m2 in - let e' := Z.min (fexp (d1 + e1 - (d2 + e2))) (e1 - e2) in - let s := (e1 - e2 - e')%Z in - let m' := - match s with - | Zpos _ => Z.shiftl m1 s - | Z0 => m1 - | Zneg _ => Z0 - end in - let '(q, r) := Z.div_eucl m' m2 in - (q, e', new_location m2 r). - - Definition SFdiv x y := - match x, y with - | S754_nan, _ | _, S754_nan => S754_nan - | S754_infinity sx, S754_infinity sy => S754_nan - | S754_infinity sx, S754_finite sy _ _ => S754_infinity (xorb sx sy) - | S754_finite sx _ _, S754_infinity sy => S754_zero (xorb sx sy) - | S754_infinity sx, S754_zero sy => S754_infinity (xorb sx sy) - | S754_zero sx, S754_infinity sy => S754_zero (xorb sx sy) - | S754_finite sx _ _, S754_zero sy => S754_infinity (xorb sx sy) - | S754_zero sx, S754_finite sy _ _ => S754_zero (xorb sx sy) - | S754_zero sx, S754_zero sy => S754_nan - | S754_finite sx mx ex, S754_finite sy my ey => - let '(mz, ez, lz) := SFdiv_core_binary (Zpos mx) ex (Zpos my) ey in - binary_round_aux (xorb sx sy) mz ez lz - end. - - Definition SFsqrt_core_binary m e := - let d := Zdigits2 m in - let e' := Z.min (fexp (Z.div2 (d + e + 1))) (Z.div2 e) in - let s := (e - 2 * e')%Z in - let m' := - match s with - | Zpos p => Z.shiftl m s - | Z0 => m - | Zneg _ => Z0 - end in - let (q, r) := Z.sqrtrem m' in - let l := - if Zeq_bool r 0 then loc_Exact - else loc_Inexact (if Zle_bool r q then Lt else Gt) in - (q, e', l). - - Definition SFsqrt x := - match x with - | S754_nan => S754_nan - | S754_infinity false => x - | S754_infinity true => S754_nan - | S754_finite true _ _ => S754_nan - | S754_zero _ => x - | S754_finite sx mx ex => - let '(mz, ez, lz) := SFsqrt_core_binary (Zpos mx) ex in - binary_round_aux false mz ez lz - end. - - Definition SFnormfr_mantissa f := - match f with - | S754_finite _ mx ex => - if Z.eqb ex (-prec) then Npos mx else 0%N - | _ => 0%N - end. - - Definition SFldexp f e := - match f with - | S754_finite sx mx ex => binary_round sx mx (ex+e) - | _ => f - end. - - Definition SFfrexp f := - match f with - | S754_finite sx mx ex => - if (Z.to_pos prec <=? digits2_pos mx)%positive then - (S754_finite sx mx (-prec), (ex+prec)%Z) - else - let d := (prec - Z.pos (digits2_pos mx))%Z in - (S754_finite sx (shift_pos (Z.to_pos d) mx) (-prec), (ex+prec-d)%Z) - | _ => (f, (-2*emax-prec)%Z) - end. - - Definition SFone := binary_round false 1 0. - - Definition SFulp x := SFldexp SFone (fexp (snd (SFfrexp x))). - - Definition SFpred_pos x := - match x with - | S754_finite _ mx _ => - let d := - if (mx~0 =? shift_pos (Z.to_pos prec) 1)%positive then - SFldexp SFone (fexp (snd (SFfrexp x) - 1)) - else - SFulp x in - SFsub x d - | _ => x - end. - - Definition SFmax_float := - S754_finite false (shift_pos (Z.to_pos prec) 1 - 1) (emax - prec). - - Definition SFsucc x := - match x with - | S754_zero _ => SFldexp SFone emin - | S754_infinity false => x - | S754_infinity true => SFopp SFmax_float - | S754_nan => x - | S754_finite false _ _ => SFadd x (SFulp x) - | S754_finite true _ _ => SFopp (SFpred_pos (SFopp x)) - end. - - Definition SFpred f := SFopp (SFsucc (SFopp f)). -End FloatOps. diff --git a/flocq/Prop/Div_sqrt_error.v b/flocq/Prop/Div_sqrt_error.v index 9aa9c508..49c46b7e 100644 --- a/flocq/Prop/Div_sqrt_error.v +++ b/flocq/Prop/Div_sqrt_error.v @@ -19,7 +19,8 @@ COPYING file for more details. (** * Remainder of the division and square root are in the FLX format *) -Require Import Psatz. +From Coq Require Import ZArith Reals Psatz. + Require Import Core Operations Relative Sterbenz Mult_error. Section Fprop_divsqrt_error. diff --git a/flocq/Prop/Double_rounding.v b/flocq/Prop/Double_rounding.v index 3e942fe0..0580ab5e 100644 --- a/flocq/Prop/Double_rounding.v +++ b/flocq/Prop/Double_rounding.v @@ -21,8 +21,9 @@ COPYING file for more details. (** * Conditions for innocuous double rounding. *) -Require Import Psatz. -Require Import Raux Defs Generic_fmt Operations Ulp FLX FLT FTZ. +From Coq Require Import ZArith Reals Psatz. + +Require Import Core FTZ. Open Scope R_scope. @@ -460,11 +461,11 @@ assert (Hx''pow : x'' = bpow (mag x)). unfold x'', round, F2R, scaled_mantissa, cexp; simpl. apply (Rmult_le_reg_r (bpow (- fexp2 (mag x)))); [now apply bpow_gt_0|]. bpow_simplify. - rewrite <- (IZR_Zpower _ (_ - _)); [|lia]. + rewrite <- (IZR_Zpower _ (_ - _)) by lia. apply IZR_le. apply Zlt_succ_le; unfold Z.succ. apply lt_IZR. - rewrite plus_IZR; rewrite IZR_Zpower; [|lia]. + rewrite plus_IZR; rewrite IZR_Zpower by lia. apply (Rmult_lt_reg_r (bpow (fexp2 (mag x)))); [now apply bpow_gt_0|]. rewrite Rmult_plus_distr_r; rewrite Rmult_1_l. bpow_simplify. @@ -487,7 +488,7 @@ unfold round, F2R, scaled_mantissa, cexp; simpl. assert (Hf : (0 <= mag x - fexp1 (mag x''))%Z). { rewrite Hx''pow. rewrite mag_bpow. - assert (fexp1 (mag x + 1) <= mag x)%Z; [|lia]. + cut (fexp1 (mag x + 1) <= mag x)%Z. lia. destruct (Zle_or_lt (mag x) (fexp1 (mag x))) as [Hle|Hlt]; [|now apply Vfexp1]. assert (H : (mag x = fexp1 (mag x) :> Z)%Z); @@ -496,10 +497,10 @@ assert (Hf : (0 <= mag x - fexp1 (mag x''))%Z). now apply Vfexp1. } rewrite (Znearest_imp _ _ (beta ^ (mag x - fexp1 (mag x'')))%Z). - rewrite (Znearest_imp _ _ (beta ^ (mag x - fexp1 (mag x)))%Z). - + rewrite IZR_Zpower; [|exact Hf]. - rewrite IZR_Zpower; [|lia]. + + rewrite IZR_Zpower by exact Hf. + rewrite IZR_Zpower by lia. now bpow_simplify. - + rewrite IZR_Zpower; [|lia]. + + rewrite IZR_Zpower by lia. apply (Rmult_lt_reg_r (bpow (fexp1 (mag x)))); [now apply bpow_gt_0|]. rewrite <- (Rabs_right (bpow (fexp1 _))) at 1; [|now apply Rle_ge; apply bpow_ge_0]. @@ -831,7 +832,7 @@ split. apply succ_le_lt; [apply Vfexp|idtac|exact Fx|assumption]. apply (generic_format_bpow beta fexp (mag x - 1)). replace (_ + _)%Z with (mag x : Z) by ring. - assert (fexp (mag x) < mag x)%Z; [|lia]. + cut (fexp (mag x) < mag x)%Z. lia. now apply mag_generic_gt; [|now apply Rgt_not_eq|]. - rewrite Rabs_right. + apply Rlt_trans with x. @@ -884,7 +885,7 @@ destruct (Req_dec x 0) as [Zx|Nzx]. rewrite Rmult_plus_distr_r. rewrite <- Fx. rewrite mult_IZR. - rewrite IZR_Zpower; [|lia]. + rewrite IZR_Zpower by lia. bpow_simplify. now rewrite <- Fy. } apply generic_format_F2R' with (f := fxy); [now rewrite Hxy|]. @@ -1053,7 +1054,7 @@ apply round_round_lt_mid. - lra. - now rewrite Lxy. - rewrite Lxy. - assert (fexp1 (mag x) < mag x)%Z; [|lia]. + cut (fexp1 (mag x) < mag x)%Z. lia. now apply mag_generic_gt; [|apply Rgt_not_eq|]. - unfold midp. apply (Rplus_lt_reg_r (- round beta fexp1 Zfloor (x + y))). @@ -1198,8 +1199,7 @@ assert (Lyx : (mag y <= mag x)%Z); [now apply mag_le; [|apply Rlt_le]|]. destruct (Z.lt_ge_cases (mag x - 2) (mag y)) as [Hlt|Hge]. - (* mag x - 2 < mag y *) - assert (Hor : (mag y = mag x :> Z) - \/ (mag y = mag x - 1 :> Z)%Z) by lia. + assert (Hor : (mag y = mag x :> Z) \/ (mag y = mag x - 1 :> Z)%Z) by lia. destruct Hor as [Heq|Heqm1]. + (* mag y = mag x *) apply (round_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy]. @@ -1344,10 +1344,10 @@ destruct (Rlt_or_le (bpow (mag x - 1)) x) as [Hx|Hx]. apply (Rmult_le_reg_r (bpow (- fexp (mag x - 1)%Z))); [now apply bpow_gt_0|]. bpow_simplify. - rewrite <- (IZR_Zpower beta (_ - _ - _)); [|lia]. + rewrite <- (IZR_Zpower beta (_ - _ - _)) by lia. apply IZR_le. apply Zceil_glb. - rewrite IZR_Zpower; [|lia]. + rewrite IZR_Zpower by lia. rewrite Xpow at 1. rewrite Rmult_minus_distr_r. bpow_simplify. @@ -1402,7 +1402,7 @@ apply round_round_gt_mid. - exact Vfexp2. - lra. - apply Hexp4; lia. -- assert (fexp1 (mag (x - y)) < mag (x - y))%Z; [|lia]. +- cut (fexp1 (mag (x - y)) < mag (x - y))%Z. lia. apply (valid_exp_large fexp1 (mag x - 1)). + apply (valid_exp_large fexp1 (mag y)); [|lia]. now apply mag_generic_gt; [|apply Rgt_not_eq|]. @@ -1880,7 +1880,7 @@ apply round_round_lt_mid. - lra. - now rewrite Lxy. - rewrite Lxy. - assert (fexp1 (mag x) < mag x)%Z; [|lia]. + cut (fexp1 (mag x) < mag x)%Z. lia. now apply mag_generic_gt; [|apply Rgt_not_eq|]. - unfold midp. apply (Rplus_lt_reg_r (- round beta fexp1 Zfloor (x + y))). @@ -2008,8 +2008,7 @@ assert (Lyx : (mag y <= mag x)%Z); [now apply mag_le; [|apply Rlt_le]|]. destruct (Z.lt_ge_cases (mag x - 2) (mag y)) as [Hlt|Hge]. - (* mag x - 2 < mag y *) - assert (Hor : (mag y = mag x :> Z) - \/ (mag y = mag x - 1 :> Z)%Z) by lia. + assert (Hor : (mag y = mag x :> Z) \/ (mag y = mag x - 1 :> Z)%Z) by lia. destruct Hor as [Heq|Heqm1]. + (* mag y = mag x *) apply (round_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy]. @@ -2114,7 +2113,7 @@ apply round_round_gt_mid. - exact Vfexp2. - lra. - apply Hexp4; lia. -- assert (fexp1 (mag (x - y)) < mag (x - y))%Z; [|lia]. +- cut (fexp1 (mag (x - y)) < mag (x - y))%Z. lia. apply (valid_exp_large fexp1 (mag x - 1)). + apply (valid_exp_large fexp1 (mag y)); [|lia]. now apply mag_generic_gt; [|apply Rgt_not_eq|]. @@ -2744,11 +2743,11 @@ destruct (Req_dec a 0) as [Za|Nza]. apply (Rmult_le_reg_r (bpow (- 2 * fexp1 (mag (sqrt x))))); [now apply bpow_gt_0|bpow_simplify]. rewrite Fx at 1; bpow_simplify. - rewrite <- IZR_Zpower; [|lia]. + rewrite <- IZR_Zpower by lia. rewrite <- plus_IZR, <- 2!mult_IZR. apply IZR_le, Zlt_succ_le, lt_IZR. unfold Z.succ; rewrite plus_IZR; do 2 rewrite mult_IZR; rewrite plus_IZR. - rewrite IZR_Zpower; [|lia]. + rewrite IZR_Zpower by lia. apply (Rmult_lt_reg_r (bpow (2 * fexp1 (mag (sqrt x))))); [now apply bpow_gt_0|bpow_simplify]. rewrite <- Fx. @@ -3163,11 +3162,11 @@ destruct (Req_dec a 0) as [Za|Nza]. apply (Rmult_le_reg_r (bpow (- 2 * fexp1 (mag (sqrt x))))); [now apply bpow_gt_0|bpow_simplify]. rewrite Fx at 1; bpow_simplify. - rewrite <- IZR_Zpower; [|lia]. + rewrite <- IZR_Zpower by lia. rewrite <- plus_IZR, <- 2!mult_IZR. apply IZR_le, Zlt_succ_le, lt_IZR. unfold Z.succ; rewrite plus_IZR; do 2 rewrite mult_IZR; rewrite plus_IZR. - rewrite IZR_Zpower; [|lia]. + rewrite IZR_Zpower by lia. apply (Rmult_lt_reg_r (bpow (2 * fexp1 (mag (sqrt x))))); [now apply bpow_gt_0|bpow_simplify]. rewrite <- Fx. @@ -3481,7 +3480,7 @@ assert (Hf : F2R f = x). rewrite plus_IZR. rewrite Rmult_plus_distr_r. rewrite mult_IZR. - rewrite IZR_Zpower; [|lia]. + rewrite IZR_Zpower by lia. unfold cexp at 2; bpow_simplify. unfold Zminus; rewrite bpow_plus. rewrite (Rmult_comm _ (bpow (- 1))). @@ -3527,12 +3526,12 @@ assert (Hf : F2R f = x). unfold round, F2R, scaled_mantissa, cexp; simpl. bpow_simplify. rewrite Lrd. - rewrite <- (IZR_Zpower _ (_ - _)); [|lia]. + rewrite <- (IZR_Zpower _ (_ - _)) by lia. rewrite <- mult_IZR. rewrite (Zfloor_imp (Zfloor (x * bpow (- fexp1 (mag x))) * beta ^ (fexp1 (mag x) - fexp2 (mag x)))). + rewrite mult_IZR. - rewrite IZR_Zpower; [|lia]. + rewrite IZR_Zpower by lia. bpow_simplify. now unfold rd. + split; [now apply Rle_refl|]. @@ -3843,7 +3842,7 @@ destruct (Zle_or_lt Z0 (fexp1 (mag x) - mag (x / y) bpow_simplify. rewrite (Rmult_comm p). unfold p; bpow_simplify. - rewrite <- IZR_Zpower; [|lia]. + rewrite <- IZR_Zpower by lia. rewrite <- mult_IZR. rewrite <- minus_IZR. apply IZR_le. @@ -3851,7 +3850,7 @@ destruct (Zle_or_lt Z0 (fexp1 (mag x) - mag (x / y) apply Zlt_le_succ. apply lt_IZR. rewrite mult_IZR. - rewrite IZR_Zpower; [|lia]. + rewrite IZR_Zpower by lia. apply (Rmult_lt_reg_r (bpow (fexp1 (mag x)))); [now apply bpow_gt_0|bpow_simplify]. rewrite <- Fx. @@ -4017,7 +4016,7 @@ destruct (Zle_or_lt Z0 (fexp1 (mag x) - fexp1 (mag (x / y)) rewrite (Rmult_comm u1). unfold x', u1, round, F2R, ulp, scaled_mantissa, cexp; simpl. bpow_simplify. - rewrite <- (IZR_Zpower _ (_ - _)%Z); [|lia]. + rewrite <- (IZR_Zpower _ (_ - _)%Z) by lia. do 5 rewrite <- mult_IZR. rewrite <- plus_IZR. rewrite <- minus_IZR. @@ -4027,7 +4026,7 @@ destruct (Zle_or_lt Z0 (fexp1 (mag x) - fexp1 (mag (x / y)) apply lt_IZR. rewrite plus_IZR. do 5 rewrite mult_IZR; simpl. - rewrite IZR_Zpower; [|lia]. + rewrite IZR_Zpower by lia. apply (Rmult_lt_reg_r (bpow (fexp1 (mag x)))); [now apply bpow_gt_0|]. rewrite Rmult_assoc. @@ -4226,7 +4225,7 @@ destruct (Zle_or_lt Z0 (fexp1 (mag x) - fexp1 (mag (x / y)) rewrite (Rmult_comm u1). unfold x', u1, round, F2R, ulp, scaled_mantissa, cexp; simpl. bpow_simplify. - rewrite <- (IZR_Zpower _ (_ - _)%Z); [|lia]. + rewrite <- (IZR_Zpower _ (_ - _)%Z) by lia. do 5 rewrite <- mult_IZR. do 2 rewrite <- plus_IZR. apply IZR_le. @@ -4234,7 +4233,7 @@ destruct (Zle_or_lt Z0 (fexp1 (mag x) - fexp1 (mag (x / y)) apply lt_IZR. rewrite plus_IZR. do 5 rewrite mult_IZR; simpl. - rewrite IZR_Zpower; [|lia]. + rewrite IZR_Zpower by lia. apply (Rmult_lt_reg_r (bpow (fexp1 (mag x)))); [now apply bpow_gt_0|]. rewrite (Rmult_assoc _ (IZR mx)). diff --git a/flocq/Prop/Mult_error.v b/flocq/Prop/Mult_error.v index f4467025..ce909350 100644 --- a/flocq/Prop/Mult_error.v +++ b/flocq/Prop/Mult_error.v @@ -19,7 +19,8 @@ COPYING file for more details. (** * Error of the multiplication is in the FLX/FLT format *) -From Coq Require Import Lia. +From Coq Require Import ZArith Reals Lia. + Require Import Core Operations Plus_error. Section Fprop_mult_error. @@ -243,8 +244,7 @@ destruct (mag beta x) as (ex,Ex) ; simpl. specialize (Ex Hx0). destruct (mag beta y) as (ey,Ey) ; simpl. specialize (Ey Hy0). -assert (emin + 2 * prec -1 < ex + ey)%Z. -2: lia. +cut (emin + 2 * prec -1 < ex + ey)%Z. lia. apply (lt_bpow beta). apply Rle_lt_trans with (1:=Hxy). rewrite Rabs_mult, bpow_plus. @@ -298,7 +298,7 @@ destruct (mag beta x) as (ex,Hx). destruct (mag beta y) as (ey,Hy). simpl; apply Z.le_trans with ((ex-prec)+(ey-prec))%Z. 2: apply Zplus_le_compat; apply Z.le_max_l. -assert (e + 2*prec -1< ex+ey)%Z;[idtac|lia]. +cut (e + 2*prec -1< ex+ey)%Z. lia. apply lt_bpow with beta. apply Rle_lt_trans with (1:=H1). rewrite Rabs_mult, bpow_plus. @@ -329,7 +329,7 @@ apply (generic_format_F2R' _ _ _ f). { now unfold F2R; simpl; rewrite bpow_plus, Rmult_assoc. } intro Nzmx; unfold mx, ex; rewrite <- Fx. unfold f, ex; simpl; unfold cexp; rewrite (mag_mult_bpow _ _ _ Nzx). -unfold FLT_exp; rewrite Z.max_l; [|lia]; rewrite <- Z.add_max_distr_r. +unfold FLT_exp; rewrite Z.max_l by lia; rewrite <- Z.add_max_distr_r. set (n := (_ - _ + _)%Z); apply (Z.le_trans _ n); [unfold n; lia|]. apply Z.le_max_l. Qed. diff --git a/flocq/Prop/Plus_error.v b/flocq/Prop/Plus_error.v index 514d3aab..bf0b28cd 100644 --- a/flocq/Prop/Plus_error.v +++ b/flocq/Prop/Plus_error.v @@ -19,11 +19,9 @@ COPYING file for more details. (** * Error of the rounded-to-nearest addition is representable. *) -Require Import Psatz. -Require Import Raux Defs Float_prop Generic_fmt. -Require Import FIX FLX FLT Ulp Operations. -Require Import Relative. +From Coq Require Import ZArith Reals Psatz. +Require Import Core Operations Relative. Section Fprop_plus_error. @@ -519,7 +517,7 @@ rewrite <- mag_minus1; try assumption. unfold FLT_exp; apply bpow_le. apply Z.le_trans with (2:=Z.le_max_l _ _). destruct (mag beta x) as (n,Hn); simpl. -assert (e + prec < n)%Z; try lia. +cut (e + prec < n)%Z. lia. apply lt_bpow with beta. apply Rle_lt_trans with (1:=He). now apply Hn. @@ -567,7 +565,7 @@ unfold cexp. rewrite <- mag_minus1 by easy. unfold FLX_exp; apply bpow_le. destruct (mag beta x) as (n,Hn); simpl. -assert (e + prec < n)%Z; try lia. +cut (e + prec < n)%Z. lia. apply lt_bpow with beta. apply Rle_lt_trans with (1:=He). now apply Hn. diff --git a/flocq/Prop/Relative.v b/flocq/Prop/Relative.v index 6b8e8f77..a87e5666 100644 --- a/flocq/Prop/Relative.v +++ b/flocq/Prop/Relative.v @@ -18,8 +18,10 @@ COPYING file for more details. *) (** * Relative error of the roundings *) + +From Coq Require Import ZArith Reals Psatz. + Require Import Core. -Require Import Psatz. (* for lra *) Section Fprop_relative. diff --git a/flocq/Prop/Round_odd.v b/flocq/Prop/Round_odd.v index a433c381..a7d98eb4 100644 --- a/flocq/Prop/Round_odd.v +++ b/flocq/Prop/Round_odd.v @@ -20,7 +20,8 @@ COPYING file for more details. (** * Rounding to odd and its properties, including the equivalence between rnd_NE and double rounding with rnd_odd and then rnd_NE *) -Require Import Reals Psatz. +From Coq Require Import ZArith Reals Psatz. + Require Import Core Operations. Definition Zrnd_odd x := match Req_EM_T x (IZR (Zfloor x)) with diff --git a/flocq/Prop/Sterbenz.v b/flocq/Prop/Sterbenz.v index 9594ac5d..8f516d0e 100644 --- a/flocq/Prop/Sterbenz.v +++ b/flocq/Prop/Sterbenz.v @@ -19,7 +19,9 @@ COPYING file for more details. (** * Sterbenz conditions for exact subtraction *) -Require Import Raux Defs Generic_fmt Operations. +From Coq Require Import ZArith Reals. + +Require Import Zaux Raux Defs Generic_fmt Operations. Section Fprop_Sterbenz. diff --git a/flocq/Version.v b/flocq/Version.v index aebb0d76..55afdadb 100644 --- a/flocq/Version.v +++ b/flocq/Version.v @@ -29,4 +29,4 @@ Definition Flocq_version := Eval vm_compute in parse t major (minor * 10 + N_of_ascii h - N_of_ascii "0"%char)%N | Empty_string => (major * 100 + minor)%N end in - parse "3.4.0"%string N0 N0. + parse "4.0.0"%string N0 N0. diff --git a/lib/Floats.v b/lib/Floats.v index fd0a3d32..33e48524 100644 --- a/lib/Floats.v +++ b/lib/Floats.v @@ -17,8 +17,9 @@ (** Formalization of floating-point numbers, using the Flocq library. *) +Require Import Reals. Require Import Coqlib Zbits Integers. -From Flocq Require Import Binary Bits Core. +From Flocq Require Import BinarySingleNaN Binary Bits Core. Require Import IEEE754_extra. Require Import Program. Require Archi. @@ -31,6 +32,12 @@ Set Asymmetric Patterns. Definition float := binary64. (**r the type of IEE754 double-precision FP numbers *) Definition float32 := binary32. (**r the type of IEE754 single-precision FP numbers *) +Lemma integer_representable_n : + forall n : Z, - 2 ^ 53 <= n <= 2 ^ 53 -> integer_representable 53 1024 n. +Proof. +now apply integer_representable_n. +Qed. + (** Boolean-valued comparisons *) Definition cmp_of_comparison (c: comparison) (x: option Datatypes.comparison) : bool := @@ -477,9 +484,9 @@ Proof. set (y := Int.sub x ox8000_0000). pose proof (Int.unsigned_range x); pose proof (Int.signed_range y). assert (Ry: integer_representable 53 1024 (Int.signed y)). - { apply integer_representable_n; auto; smart_omega. } + { apply integer_representable_n. smart_omega. } assert (R8: integer_representable 53 1024 (Int.unsigned ox8000_0000)). - { apply integer_representable_2p with (p := 31);auto; smart_omega. } + { apply integer_representable_2p with (p := 31); easy. } rewrite BofZ_plus by auto. f_equal. unfold Int.ltu in H. destruct zlt in H; try discriminate. @@ -496,7 +503,7 @@ Proof. set (lo := Int.and x ox7FFF_FFFF). assert (R: forall n, integer_representable 53 1024 (Int.signed n)). { intros. pose proof (Int.signed_range n). - apply integer_representable_n; auto; smart_omega. } + apply integer_representable_n. smart_omega. } unfold sub, of_int. rewrite BofZ_minus by auto. unfold of_intu. f_equal. assert (E: Int.add hi lo = x). { unfold hi, lo. rewrite Int.add_is_or. @@ -645,8 +652,8 @@ Proof. intros. pose proof (Int.unsigned_range x). rewrite ! from_words_eq. unfold sub. rewrite BofZ_minus. unfold of_intu. apply (f_equal (BofZ 53 1024 __ __)). rewrite Int.unsigned_zero. lia. - apply integer_representable_n; auto; smart_omega. - apply integer_representable_n; auto; rewrite Int.unsigned_zero; smart_omega. + apply integer_representable_n. smart_omega. + apply integer_representable_n. easy. Qed. Lemma ox8000_0000_signed_unsigned: @@ -672,8 +679,8 @@ Proof. change (Int.unsigned ox8000_0000) with Int.half_modulus. unfold sub. rewrite BofZ_minus. unfold of_int. apply f_equal. lia. - apply integer_representable_n; auto; smart_omega. - apply integer_representable_n; auto; smart_omega. + apply integer_representable_n. smart_omega. + apply integer_representable_n. easy. Qed. Definition ox4530_0000 := Int.repr 1160773632. (**r [0x4530_0000] *) @@ -718,7 +725,7 @@ Proof. destruct (BofZ_representable 53 1024 __ __ (2^84 + Int.unsigned x * 2^32)) as (D & E & F). replace (2^84 + Int.unsigned x * 2^32) with ((2^52 + Int.unsigned x) * 2^32) by ring. - apply integer_representable_n2p; auto. smart_omega. lia. lia. + apply integer_representable_n2p; try easy. smart_omega. apply B2R_Bsign_inj; auto. rewrite A, D. rewrite <- IZR_Zpower by lia. rewrite <- plus_IZR. auto. rewrite C, F. symmetry. apply Zlt_bool_false. @@ -748,13 +755,13 @@ Proof. unfold of_longu. f_equal. rewrite <- (Int64.ofwords_recompose l) at 1. rewrite Int64.ofwords_add'. fold xh; fold xl. compute_this (two_p 32); compute_this p20; ring. - apply integer_representable_n2p; auto. - compute_this p20; smart_omega. lia. lia. - apply integer_representable_n; auto; smart_omega. + apply integer_representable_n2p; try easy. + compute_this p20; smart_omega. + apply integer_representable_n. smart_omega. replace (2^84 + xh * 2^32) with ((2^52 + xh) * 2^32) by ring. - apply integer_representable_n2p; auto. smart_omega. lia. lia. + apply integer_representable_n2p; try easy. smart_omega. change (2^84 + p20 * 2^32) with ((2^52 + 1048576) * 2^32). - apply integer_representable_n2p; auto. lia. lia. + apply integer_representable_n2p; easy. Qed. Theorem of_long_from_words: @@ -782,16 +789,15 @@ Proof. unfold of_long. apply f_equal. rewrite <- (Int64.ofwords_recompose l) at 1. rewrite Int64.ofwords_add''. fold xh; fold xl. compute_this (two_p 32); ring. - apply integer_representable_n2p; auto. - compute_this (2^20); smart_omega. lia. lia. - apply integer_representable_n; auto; smart_omega. + apply integer_representable_n2p; try easy. + compute_this (2^20); smart_omega. + apply integer_representable_n. smart_omega. replace (2^84 + (xh + Int.half_modulus) * 2^32) with ((2^52 + xh + Int.half_modulus) * 2^32) by (compute_this Int.half_modulus; ring). - apply integer_representable_n2p; auto. smart_omega. lia. lia. + apply integer_representable_n2p; try easy. smart_omega. change (2^84 + p * 2^32) with ((2^52 + p) * 2^32). - apply integer_representable_n2p; auto. - compute_this p; smart_omega. lia. + apply integer_representable_n2p; easy. Qed. (** Conversions from 64-bit integers can be expressed in terms of @@ -813,11 +819,11 @@ Proof. assert (DECOMP: x = yh * 2^32 + yl). { unfold x. rewrite <- (Int64.ofwords_recompose l). apply Int64.ofwords_add'. } rewrite BofZ_mult. rewrite BofZ_plus. rewrite DECOMP; auto. - apply integer_representable_n2p; auto. smart_omega. lia. lia. - apply integer_representable_n; auto; smart_omega. - apply integer_representable_n; auto; smart_omega. - apply integer_representable_n; auto; smart_omega. - compute; auto. + apply integer_representable_n2p; try easy. smart_omega. + apply integer_representable_n. smart_omega. + apply integer_representable_n. smart_omega. + apply integer_representable_n. easy. + easy. Qed. Theorem of_long_decomp: @@ -836,11 +842,11 @@ Proof. assert (DECOMP: x = yh * 2^32 + yl). { unfold x. rewrite <- (Int64.ofwords_recompose l), Int64.ofwords_add''. auto. } rewrite BofZ_mult. rewrite BofZ_plus. rewrite DECOMP; auto. - apply integer_representable_n2p; auto. smart_omega. lia. lia. - apply integer_representable_n; auto; smart_omega. - apply integer_representable_n; auto; smart_omega. - apply integer_representable_n; auto. compute; intuition congruence. - compute; auto. + apply integer_representable_n2p; try easy. smart_omega. + apply integer_representable_n. smart_omega. + apply integer_representable_n. smart_omega. + apply integer_representable_n. easy. + easy. Qed. (** Conversions from unsigned longs can be expressed in terms of conversions from signed longs. @@ -901,7 +907,7 @@ Proof. } assert (EQ: Int64.signed n * 2 = int_round_odd (Int64.unsigned x) 1). { - symmetry. apply int_round_odd_bits. lia. + symmetry. apply int_round_odd_bits. easy. intros. rewrite NB2 by lia. replace i with 0 by lia. auto. rewrite NB2 by lia. rewrite dec_eq_false by lia. rewrite dec_eq_true. rewrite orb_comm. unfold Int64.testbit. change (2^1) with 2. @@ -1221,7 +1227,7 @@ Theorem of_int_double: forall n, of_int n = of_double (Float.of_int n). Proof. intros. symmetry. apply Bconv_BofZ. - apply integer_representable_n; auto. generalize (Int.signed_range n); Float.smart_omega. + apply integer_representable_n. generalize (Int.signed_range n); Float.smart_omega. Qed. Theorem of_intu_double: @@ -1337,11 +1343,9 @@ Proof. apply Z.le_trans with (2^64). lia. compute; intuition congruence. lia. exact (proj1 H). - unfold int_round_odd. apply integer_representable_n2p_wide. auto. lia. + unfold int_round_odd. apply integer_representable_n2p_wide; try easy. unfold int_round_odd in H0, H1. split; (apply Zmult_le_reg_r with (2^11); [compute; auto | assumption]). - lia. - lia. Qed. Theorem of_longu_double_1: diff --git a/lib/IEEE754_extra.v b/lib/IEEE754_extra.v index b0d1944e..f7505c49 100644 --- a/lib/IEEE754_extra.v +++ b/lib/IEEE754_extra.v @@ -18,8 +18,11 @@ (** Additional operations and proofs about IEEE-754 binary floating-point numbers, on top of the Flocq library. *) +Require Import Reals. +Require Import SpecFloat. From Flocq Require Import Core Digits Operations Round Bracket Sterbenz - Binary Round_odd. + BinarySingleNaN Binary Round_odd. +Require Import ZArith. Require Import Psatz. Require Import Bool. Require Import Eqdep_dec. @@ -34,10 +37,10 @@ Section Extra_ops. Variable prec emax : Z. Context (prec_gt_0_ : Prec_gt_0 prec). -Let emin := (3 - emax - prec)%Z. -Let fexp := FLT_exp emin prec. -Hypothesis Hmax : (prec < emax)%Z. -Let binary_float := binary_float prec emax. +Context (prec_lt_emax_ : Prec_lt_emax prec emax). +Notation emin := (emin prec emax). +Notation fexp := (fexp prec emax). +Notation binary_float := (binary_float prec emax). (** Remarks on [is_finite] *) @@ -117,10 +120,12 @@ Defined. Definition integer_representable (n: Z): Prop := Z.abs n <= 2^emax - 2^(emax - prec) /\ generic_format radix2 fexp (IZR n). -Let int_upper_bound_eq: 2^emax - 2^(emax - prec) = (2^prec - 1) * 2^(emax - prec). +Lemma int_upper_bound_eq: 2^emax - 2^(emax - prec) = (2^prec - 1) * 2^(emax - prec). Proof. - red in prec_gt_0_. - ring_simplify. rewrite <- (Zpower_plus radix2) by lia. f_equal. f_equal. lia. + red in prec_gt_0_, prec_lt_emax_. + ring_simplify. + rewrite <- (Zpower_plus radix2) by lia. + now replace (emax - prec + prec)%Z with emax by ring. Qed. Lemma integer_representable_n2p: @@ -129,16 +134,16 @@ Lemma integer_representable_n2p: integer_representable (n * 2^p). Proof. intros; split. -- red in prec_gt_0_. replace (Z.abs (n * 2^p)) with (Z.abs n * 2^p). +- red in prec_gt_0_, prec_lt_emax_. replace (Z.abs (n * 2^p)) with (Z.abs n * 2^p). rewrite int_upper_bound_eq. - apply Zmult_le_compat. zify; lia. apply (Zpower_le radix2); lia. - zify; lia. apply (Zpower_ge_0 radix2). + apply Zmult_le_compat. lia. apply (Zpower_le radix2); lia. + lia. apply (Zpower_ge_0 radix2). rewrite Z.abs_mul. f_equal. rewrite Z.abs_eq. auto. apply (Zpower_ge_0 radix2). - apply generic_format_FLT. exists (Float radix2 n p). unfold F2R; simpl. rewrite <- IZR_Zpower by auto. apply mult_IZR. - simpl; zify; lia. - unfold emin, Fexp; red in prec_gt_0_; lia. + simpl; lia. + unfold emin, Fexp; red in prec_gt_0_, prec_lt_emax_; lia. Qed. Lemma integer_representable_2p: @@ -157,7 +162,7 @@ Proof. assert (2^(emax - prec) <= 2^(emax - 1)). { apply (Zpower_le radix2). lia. } lia. -- red in prec_gt_0_. +- red in prec_gt_0_, prec_lt_emax_. apply generic_format_FLT. exists (Float radix2 1 p). unfold F2R; simpl. rewrite Rmult_1_l. rewrite <- IZR_Zpower. auto. lia. @@ -190,7 +195,7 @@ Qed. Lemma integer_representable_n: forall n, -2^prec <= n <= 2^prec -> integer_representable n. Proof. - red in prec_gt_0_. intros. + red in prec_gt_0_, prec_lt_emax_. intros. replace n with (n * 2^0) by (change (2^0) with 1; ring). apply integer_representable_n2p_wide. auto. lia. lia. Qed. @@ -200,7 +205,7 @@ Lemma round_int_no_overflow: Z.abs n <= 2^emax - 2^(emax-prec) -> (Rabs (round radix2 fexp (round_mode mode_NE) (IZR n)) < bpow radix2 emax)%R. Proof. - intros. red in prec_gt_0_. + intros. red in prec_gt_0_, prec_lt_emax_. rewrite <- round_NE_abs. apply Rle_lt_trans with (IZR (2^emax - 2^(emax-prec))). apply round_le_generic. apply fexp_correct; auto. apply valid_rnd_N. @@ -220,7 +225,7 @@ Qed. (** Conversion from an integer. Round to nearest. *) Definition BofZ (n: Z) : binary_float := - binary_normalize prec emax prec_gt_0_ Hmax mode_NE n 0 false. + binary_normalize prec emax _ _ mode_NE n 0 false. Theorem BofZ_correct: forall n, @@ -233,7 +238,7 @@ Theorem BofZ_correct: B2FF prec emax (BofZ n) = binary_overflow prec emax mode_NE (Z.ltb n 0). Proof. intros. - generalize (binary_normalize_correct prec emax prec_gt_0_ Hmax mode_NE n 0 false). + generalize (binary_normalize_correct prec emax _ _ mode_NE n 0 false). fold emin; fold fexp; fold (BofZ n). replace (F2R {| Fnum := n; Fexp := 0 |}) with (IZR n). destruct Rlt_bool. @@ -287,7 +292,7 @@ Lemma BofZ_finite_pos0: Z.abs n <= 2^emax - 2^(emax-prec) -> is_finite_pos0 (BofZ n) = true. Proof. intros. - generalize (binary_normalize_correct prec emax prec_gt_0_ Hmax mode_NE n 0 false). + generalize (binary_normalize_correct prec emax _ _ mode_NE n 0 false). fold emin; fold fexp; fold (BofZ n). replace (F2R {| Fnum := n; Fexp := 0 |}) with (IZR n) by (unfold F2R; simpl; ring). @@ -295,12 +300,13 @@ Proof. intros (A & B & C). destruct (BofZ n); auto; try discriminate. simpl in *. rewrite C. rewrite Rcompare_IZR. - generalize (Zcompare_spec n 0); intros SPEC; inversion SPEC; auto. + generalize (Zcompare_spec n 0); intros SPEC; destruct SPEC; auto. assert ((round radix2 fexp ZnearestE (IZR n) <= -1)%R). { apply round_le_generic. apply fexp_correct. auto. apply valid_rnd_N. apply (integer_representable_opp 1). apply (integer_representable_2p 0). - red in prec_gt_0_; lia. + + red in prec_gt_0_, prec_lt_emax_; lia. apply IZR_le; lia. } lra. @@ -321,12 +327,12 @@ Qed. Theorem BofZ_plus: forall nan p q, integer_representable p -> integer_representable q -> - Bplus _ _ _ Hmax nan mode_NE (BofZ p) (BofZ q) = BofZ (p + q). + Bplus _ _ _ _ nan mode_NE (BofZ p) (BofZ q) = BofZ (p + q). Proof. intros. destruct (BofZ_representable p) as (A & B & C); auto. destruct (BofZ_representable q) as (D & E & F); auto. - generalize (Bplus_correct _ _ _ Hmax nan mode_NE (BofZ p) (BofZ q) B E). + generalize (Bplus_correct _ _ _ _ nan mode_NE (BofZ p) (BofZ q) B E). fold emin; fold fexp. rewrite A, D. rewrite <- plus_IZR. generalize (BofZ_correct (p + q)). destruct Rlt_bool. @@ -351,12 +357,12 @@ Qed. Theorem BofZ_minus: forall nan p q, integer_representable p -> integer_representable q -> - Bminus _ _ _ Hmax nan mode_NE (BofZ p) (BofZ q) = BofZ (p - q). + Bminus _ _ _ _ nan mode_NE (BofZ p) (BofZ q) = BofZ (p - q). Proof. intros. destruct (BofZ_representable p) as (A & B & C); auto. destruct (BofZ_representable q) as (D & E & F); auto. - generalize (Bminus_correct _ _ _ Hmax nan mode_NE (BofZ p) (BofZ q) B E). + generalize (Bminus_correct _ _ _ _ nan mode_NE (BofZ p) (BofZ q) B E). fold emin; fold fexp. rewrite A, D. rewrite <- minus_IZR. generalize (BofZ_correct (p - q)). destruct Rlt_bool. @@ -385,7 +391,7 @@ Theorem BofZ_mult: forall nan p q, integer_representable p -> integer_representable q -> 0 < q -> - Bmult _ _ _ Hmax nan mode_NE (BofZ p) (BofZ q) = BofZ (p * q). + Bmult _ _ _ _ nan mode_NE (BofZ p) (BofZ q) = BofZ (p * q). Proof. intros. assert (SIGN: xorb (p 2^prec <= Z.abs x -> 0 <= p <= emax - 1 -> - Bmult _ _ _ Hmax nan mode_NE (BofZ x) (BofZ (2^p)) = BofZ (x * 2^p). + Bmult _ _ _ _ nan mode_NE (BofZ x) (BofZ (2^p)) = BofZ (x * 2^p). Proof. intros. destruct (Z.eq_dec x 0). @@ -475,7 +481,7 @@ Proof. apply Zlt_bool_true. apply Z.mul_neg_pos; auto. apply Zlt_bool_false. apply Z.mul_nonneg_nonneg; lia. } - generalize (Bmult_correct _ _ _ Hmax nan mode_NE (BofZ x) (BofZ (2^p))) + generalize (Bmult_correct _ _ _ _ nan mode_NE (BofZ x) (BofZ (2^p))) (BofZ_correct (x * 2^p)). fold emin; fold fexp. rewrite A, B, C, D, E, F, H4, H5. destruct Rlt_bool. @@ -524,7 +530,7 @@ Proof. { unfold cexp, FLT_exp, FIX_exp. replace (mag radix2 x - prec') with p by (unfold prec'; lia). - apply Z.max_l. unfold emin', emin. red in prec_gt_0_; lia. + apply Z.max_l. unfold emin', emin. red in prec_gt_0_, prec_lt_emax_; lia. } assert (RND: round radix2 (FIX_exp p) Zrnd_odd x = round radix2 (FLT_exp emin' prec') Zrnd_odd x). @@ -806,7 +812,7 @@ Qed. Theorem ZofB_minus: forall minus_nan m f p q, ZofB f = Some p -> 0 <= p < 2*q -> q <= 2^prec -> (IZR q <= B2R _ _ f)%R -> - ZofB (Bminus _ _ _ Hmax minus_nan m f (BofZ q)) = Some (p - q). + ZofB (Bminus _ _ _ _ minus_nan m f (BofZ q)) = Some (p - q). Proof. intros. assert (Q: -2^prec <= q <= 2^prec). @@ -820,7 +826,7 @@ Proof. apply sterbenz_aux. now apply FLT_exp_valid. apply FLT_exp_monotone. apply generic_format_B2R. apply integer_representable_n. auto. lra. } destruct (BofZ_exact q Q) as (A & B & C). - generalize (Bminus_correct _ _ _ Hmax minus_nan m f (BofZ q) FIN B). + generalize (Bminus_correct _ _ _ _ minus_nan m f (BofZ q) FIN B). rewrite Rlt_bool_true. - fold emin; fold fexp. intros (D & E & F). rewrite ZofB_correct. rewrite E. rewrite D. rewrite A. rewrite EXACT. @@ -870,10 +876,10 @@ Qed. Theorem ZofB_range_minus: forall minus_nan m f p q, ZofB_range f 0 (2 * q - 1) = Some p -> q <= 2^prec -> (IZR q <= B2R _ _ f)%R -> - ZofB_range (Bminus _ _ _ Hmax minus_nan m f (BofZ q)) (-q) (q - 1) = Some (p - q). + ZofB_range (Bminus _ _ _ _ minus_nan m f (BofZ q)) (-q) (q - 1) = Some (p - q). Proof. intros. destruct (ZofB_range_inversion _ _ _ _ H) as (A & B & C). - set (f' := Bminus prec emax prec_gt_0_ Hmax minus_nan m f (BofZ q)). + set (f' := Bminus prec emax _ _ minus_nan m f (BofZ q)). assert (D: ZofB f' = Some (p - q)). { apply ZofB_minus. auto. lia. auto. auto. } unfold ZofB_range. rewrite D. rewrite Zle_bool_true by lia. rewrite Zle_bool_true by lia. auto. @@ -886,70 +892,30 @@ Qed. Theorem Bplus_commut: forall plus_nan mode (x y: binary_float), plus_nan x y = plus_nan y x -> - Bplus _ _ _ Hmax plus_nan mode x y = Bplus _ _ _ Hmax plus_nan mode y x. + Bplus _ _ _ _ plus_nan mode x y = Bplus _ _ _ _ plus_nan mode y x. Proof. intros until y; intros NAN. - pose proof (Bplus_correct _ _ _ Hmax plus_nan mode x y). - pose proof (Bplus_correct _ _ _ Hmax plus_nan mode y x). - unfold Bplus in *; destruct x as [sx|sx|sx px Hx|sx mx ex Hx]; destruct y as [sy|sy|sy py Hy|sy my ey Hy]; auto. + unfold Bplus. rewrite NAN. f_equal. + destruct x as [sx|sx|sx px Hx|sx mx ex Hx]; destruct y as [sy|sy|sy py Hy|sy my ey Hy]; auto; simpl. - rewrite (eqb_sym sy sx). destruct (eqb sx sy) eqn:EQB; auto. f_equal; apply eqb_prop; auto. -- rewrite NAN; auto. -- rewrite (eqb_sym sy sx). destruct (eqb sx sy) eqn:EQB. +- rewrite (eqb_sym sy sx). destruct (eqb sx sy) eqn:EQB; auto. f_equal; apply eqb_prop; auto. - rewrite NAN; auto. -- rewrite NAN; auto. -- rewrite NAN; auto. -- rewrite NAN; auto. -- rewrite NAN; auto. -- rewrite NAN; auto. -- rewrite NAN; auto. -- generalize (H (eq_refl _) (eq_refl _)); clear H. - generalize (H0 (eq_refl _) (eq_refl _)); clear H0. - fold emin. fold fexp. - set (x := B754_finite prec emax sx mx ex Hx). set (rx := B2R _ _ x). - set (y := B754_finite prec emax sy my ey Hy). set (ry := B2R _ _ y). - rewrite (Rplus_comm ry rx). destruct Rlt_bool. - + intros (A1 & A2 & A3) (B1 & B2 & B3). - apply B2R_Bsign_inj; auto. rewrite <- B1 in A1. auto. - rewrite Z.add_comm. rewrite Z.min_comm. auto. - + intros (A1 & A2) (B1 & B2). apply B2FF_inj. rewrite B2 in B1. rewrite <- B1 in A1. auto. +- rewrite Z.min_comm. f_equal. + apply Zplus_comm. Qed. Theorem Bmult_commut: forall mult_nan mode (x y: binary_float), mult_nan x y = mult_nan y x -> - Bmult _ _ _ Hmax mult_nan mode x y = Bmult _ _ _ Hmax mult_nan mode y x. + Bmult _ _ _ _ mult_nan mode x y = Bmult _ _ _ _ mult_nan mode y x. Proof. intros until y; intros NAN. - pose proof (Bmult_correct _ _ _ Hmax mult_nan mode x y). - pose proof (Bmult_correct _ _ _ Hmax mult_nan mode y x). - unfold Bmult in *; destruct x as [sx|sx|sx px Hx|sx mx ex Hx]; destruct y as [sy|sy|sy py Hy|sy my ey Hy]; auto. -- rewrite (xorb_comm sx sy); auto. -- rewrite NAN; auto. -- rewrite NAN; auto. -- rewrite (xorb_comm sx sy); auto. -- rewrite NAN; auto. -- rewrite (xorb_comm sx sy); auto. -- rewrite NAN; auto. -- rewrite (xorb_comm sx sy); auto. -- rewrite NAN; auto. -- rewrite NAN; auto. -- rewrite NAN; auto. -- rewrite NAN; auto. -- rewrite (xorb_comm sx sy); auto. -- rewrite (xorb_comm sx sy); auto. -- rewrite NAN; auto. -- revert H H0. fold emin. fold fexp. - set (x := B754_finite prec emax sx mx ex Hx). set (rx := B2R _ _ x). - set (y := B754_finite prec emax sy my ey Hy). set (ry := B2R _ _ y). - rewrite (Rmult_comm ry rx). - destruct (Rlt_bool (Rabs (round radix2 fexp (round_mode mode) (rx * ry))) - (bpow radix2 emax)). - + intros (A1 & A2 & A3) (B1 & B2 & B3). - apply B2R_Bsign_inj; auto. rewrite <- B1 in A1. auto. - rewrite ! Bsign_FF2B. f_equal. f_equal. apply xorb_comm. now rewrite Pos.mul_comm. apply Z.add_comm. - + intros A B. apply B2FF_inj. etransitivity. eapply A. rewrite xorb_comm. auto. + unfold Bmult. rewrite NAN. f_equal. + destruct x as [sx|sx|sx px Hx|sx mx ex Hx]; destruct y as [sy|sy|sy py Hy|sy my ey Hy]; auto; + simpl; try rewrite xorb_comm; auto. + apply B2SF_inj. rewrite 2!B2SF_SF2B. + now rewrite xorb_comm, Pos.mul_comm, Zplus_comm. Qed. (** Multiplication by 2 is diagonal addition. *) @@ -958,15 +924,15 @@ Theorem Bmult2_Bplus: forall plus_nan mult_nan mode (f: binary_float), (forall (x y: binary_float), is_nan _ _ x = true -> is_finite _ _ y = true -> plus_nan x x = mult_nan x y) -> - Bplus _ _ _ Hmax plus_nan mode f f = Bmult _ _ _ Hmax mult_nan mode f (BofZ 2%Z). + Bplus _ _ _ _ plus_nan mode f f = Bmult _ _ _ _ mult_nan mode f (BofZ 2%Z). Proof. intros until f; intros NAN. destruct (BofZ_representable 2) as (A & B & C). - apply (integer_representable_2p 1). red in prec_gt_0_; lia. - pose proof (Bmult_correct _ _ _ Hmax mult_nan mode f (BofZ 2%Z)). fold emin in H. + apply (integer_representable_2p 1). red in prec_gt_0_, prec_lt_emax_; lia. + pose proof (Bmult_correct _ _ _ _ mult_nan mode f (BofZ 2%Z)). fold emin in H. rewrite A, B, C in H. rewrite xorb_false_r in H. destruct (is_finite _ _ f) eqn:FIN. -- pose proof (Bplus_correct _ _ _ Hmax plus_nan mode f f FIN FIN). fold emin in H0. +- pose proof (Bplus_correct _ _ _ _ plus_nan mode f f FIN FIN). fold emin in H0. assert (EQ: (B2R prec emax f * IZR 2%Z = B2R prec emax f + B2R prec emax f)%R). { ring. } rewrite <- EQ in H0. destruct Rlt_bool. @@ -981,12 +947,12 @@ Proof. rewrite Rcompare_F2R. destruct s; auto. unfold F2R. simpl. ring. apply IZR_lt. lia. - destruct (Bmult prec emax prec_gt_0_ Hmax mult_nan mode f (BofZ 2)); reflexivity || discriminate. + destruct (Bmult prec emax _ _ mult_nan mode f (BofZ 2)); reflexivity || discriminate. + destruct H0 as (P & Q). apply B2FF_inj. rewrite P, H. auto. - destruct f as [sf|sf|sf pf Hf|sf mf ef Hf]; try discriminate. - + simpl Bplus. rewrite eqb_true. destruct (BofZ 2) as [| | |s2 m2 e2 H2] eqn:B2; try discriminate; simpl in *. + + unfold Bplus. simpl BSN.Bplus. rewrite eqb_true. destruct (BofZ 2) as [| | |s2 m2 e2 H2] eqn:B2; try discriminate; simpl in *. assert ((0 = 2)%Z) by (apply eq_IZR; auto). discriminate. - subst s2. rewrite xorb_false_r. auto. + subst s2. unfold Bmult. simpl. rewrite xorb_false_r. auto. auto. + unfold Bplus, Bmult. rewrite <- NAN by auto. auto. Qed. @@ -1028,9 +994,7 @@ Proof. intros. unfold bounded, canonical_mantissa. rewrite andb_true_iff. rewrite <- Zeq_is_eq_bool. rewrite <- Zle_is_le_bool. rewrite Bexact_inverse_mantissa_digits2_pos. - split. -- intros; split. unfold FLT_exp. unfold emin in H. zify; lia. lia. -- intros [A B]. unfold FLT_exp in A. unfold emin. zify; lia. + unfold fexp, FLT_exp, emin. lia. Qed. Program Definition Bexact_inverse (f: binary_float) : option binary_float := @@ -1083,12 +1047,12 @@ Theorem Bdiv_mult_inverse: is_nan _ _ x = true -> is_finite _ _ y = true -> is_finite _ _ z = true -> div_nan x y = mult_nan x z) -> Bexact_inverse y = Some z -> - Bdiv _ _ _ Hmax div_nan mode x y = Bmult _ _ _ Hmax mult_nan mode x z. + Bdiv _ _ _ _ div_nan mode x y = Bmult _ _ _ _ mult_nan mode x z. Proof. intros until z; intros NAN; intros. destruct (Bexact_inverse_correct _ _ H) as (A & B & C & D & E). - pose proof (Bmult_correct _ _ _ Hmax mult_nan mode x z). + pose proof (Bmult_correct _ _ _ _ mult_nan mode x z). fold emin in H0. fold fexp in H0. - pose proof (Bdiv_correct _ _ _ Hmax div_nan mode x y D). + pose proof (Bdiv_correct _ _ _ _ div_nan mode x y D). fold emin in H1. fold fexp in H1. unfold Rdiv in H1. rewrite <- C in H1. destruct (is_finite _ _ x) eqn:FINX. @@ -1102,8 +1066,8 @@ Proof. apply is_finite_not_is_nan. rewrite Q. simpl. apply is_finite_strict_finite; auto. + apply B2FF_inj. rewrite H0, H1. rewrite E. auto. - destruct y; try discriminate. destruct z; try discriminate. destruct x; try discriminate; simpl. - + simpl in E; congruence. - + erewrite NAN; eauto. + + simpl in E. now rewrite E. + + unfold Bdiv. now rewrite (NAN _ _ (B754_finite prec emax s0 m0 e1 e2)). Qed. (** ** Conversion from scientific notation *) @@ -1136,7 +1100,7 @@ Qed. division with [m]. However, we treat specially very large or very small values of [e], when the result is known to be [+infinity] or [0.0] respectively. *) -Definition Bparse (base: positive) (m: positive) (e: Z): binary_float := +Program Definition Bparse (base: positive) (m: positive) (e: Z): binary_float := match e with | Z0 => BofZ (Zpos m) @@ -1147,9 +1111,21 @@ Definition Bparse (base: positive) (m: positive) (e: Z): binary_float := | Zneg p => if e * Z.log2 (Zpos base) + Z.log2_up (Zpos m)