Fcore_FTZ.v 8.15 KB
Newer Older
1
(**
2 3 4
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/

5
Copyright (C) 2010-2013 Sylvie Boldo
6
#<br />#
7
Copyright (C) 2010-2013 Guillaume Melquiond
8 9 10 11 12 13 14 15 16 17 18 19

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.
*)

20
(** * Floating-point format with abrupt underflow *)
21 22 23 24 25 26
Require Import Fcore_Raux.
Require Import Fcore_defs.
Require Import Fcore_rnd.
Require Import Fcore_generic_fmt.
Require Import Fcore_float_prop.
Require Import Fcore_FLX.
27 28 29 30 31

Section RND_FTZ.

Variable beta : radix.

32
Notation bpow e := (bpow beta e).
33 34

Variable emin prec : Z.
35 36

Context { prec_gt_0_ : Prec_gt_0 prec }.
37 38 39 40

(* floating-point format with abrupt underflow *)
Definition FTZ_format (x : R) :=
  exists f : float beta,
41
  x = F2R f /\ (x <> R0 -> Zpower beta (prec - 1) <= Zabs (Fnum f) < Zpower beta prec)%Z /\
42 43 44 45
  (emin <= Fexp f)%Z.

Definition FTZ_exp e := if Zlt_bool (e - prec) emin then (emin + prec - 1)%Z else (e - prec)%Z.

46
(** Properties of the FTZ format *)
47
Global Instance FTZ_exp_valid : Valid_exp FTZ_exp.
48 49 50 51 52 53 54 55 56 57 58 59
Proof.
intros k.
unfold FTZ_exp.
generalize (Zlt_cases (k - prec) emin).
case (Zlt_bool (k - prec) emin) ; intros H1.
split ; intros H2.
omega.
split.
generalize (Zlt_cases (emin + prec + 1 - prec) emin).
case (Zlt_bool (emin + prec + 1 - prec) emin) ; intros H3.
omega.
generalize (Zlt_cases (emin + prec - 1 + 1 - prec) emin).
60
generalize (prec_gt_0 prec).
61 62 63 64 65 66 67
case (Zlt_bool (emin + prec - 1 + 1 - prec) emin) ; omega.
intros l H3.
generalize (Zlt_cases (l - prec) emin).
case (Zlt_bool (l - prec) emin) ; omega.
split ; intros H2.
generalize (Zlt_cases (k + 1 - prec) emin).
case (Zlt_bool (k + 1 - prec) emin) ; omega.
68
generalize (prec_gt_0 prec).
69 70 71
split ; intros ; omega.
Qed.

Guillaume Melquiond's avatar
Guillaume Melquiond committed
72 73 74 75 76 77 78 79
Theorem FLXN_format_FTZ :
  forall x, FTZ_format x -> FLXN_format beta prec x.
Proof.
intros x ((xm, xe), (Hx1, (Hx2, Hx3))).
eexists.
apply (conj Hx1 Hx2).
Qed.

80 81
Theorem generic_format_FTZ :
  forall x, FTZ_format x -> generic_format beta FTZ_exp x.
82
Proof.
Guillaume Melquiond's avatar
Guillaume Melquiond committed
83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99
intros x Hx.
cut (generic_format beta (FLX_exp prec) x).
apply generic_inclusion_ln_beta.
intros Zx.
destruct Hx as ((xm, xe), (Hx1, (Hx2, Hx3))).
simpl in Hx2, Hx3.
specialize (Hx2 Zx).
assert (Zxm: xm <> Z0).
contradict Zx.
rewrite Hx1, Zx.
apply F2R_0.
unfold FTZ_exp, FLX_exp.
rewrite Zlt_bool_false.
apply Zle_refl.
rewrite Hx1, ln_beta_F2R with (1 := Zxm).
cut (prec - 1 < ln_beta beta (Z2R xm))%Z.
clear -Hx3 ; omega.
100
apply ln_beta_gt_Zpower with (1 := Zxm).
101
apply Hx2.
Guillaume Melquiond's avatar
Guillaume Melquiond committed
102 103
apply generic_format_FLXN.
now apply FLXN_format_FTZ.
104 105 106 107 108 109
Qed.

Theorem FTZ_format_generic :
  forall x, generic_format beta FTZ_exp x -> FTZ_format x.
Proof.
intros x Hx.
110 111 112 113 114 115 116 117 118
destruct (Req_dec x 0) as [Hx3|Hx3].
exists (Float beta 0 emin).
split.
unfold F2R. simpl.
now rewrite Rmult_0_l.
split.
intros H.
now elim H.
apply Zle_refl.
BOLDO Sylvie's avatar
BOLDO Sylvie committed
119
unfold generic_format, scaled_mantissa, canonic_exp, FTZ_exp in Hx.
120
destruct (ln_beta beta x) as (ex, Hx4).
121
simpl in Hx.
122
specialize (Hx4 Hx3).
123
generalize (Zlt_cases (ex - prec) emin) Hx. clear Hx.
124 125 126
case (Zlt_bool (ex - prec) emin) ; intros Hx5 Hx2.
elim Rlt_not_ge with (1 := proj2 Hx4).
apply Rle_ge.
BOLDO Sylvie's avatar
BOLDO Sylvie committed
127
rewrite Hx2, <- F2R_Zabs.
128 129 130 131
rewrite <- (Rmult_1_l (bpow ex)).
unfold F2R. simpl.
apply Rmult_le_compat.
now apply (Z2R_le 0 1).
132
apply bpow_ge_0.
133 134 135
apply (Z2R_le 1).
apply (Zlt_le_succ 0).
apply lt_Z2R.
136
apply Rmult_lt_reg_r with (bpow (emin + prec - 1)).
137
apply bpow_gt_0.
138
rewrite Rmult_0_l.
139
change (0 < F2R (Float beta (Zabs (Ztrunc (x * bpow (- (emin + prec - 1))))) (emin + prec - 1)))%R.
BOLDO Sylvie's avatar
BOLDO Sylvie committed
140
rewrite F2R_Zabs, <- Hx2.
141
now apply Rabs_pos_lt.
142
apply bpow_le.
143
omega.
144 145
rewrite Hx2.
eexists ; repeat split ; simpl.
146 147 148
apply le_Z2R.
rewrite Z2R_Zpower.
apply Rmult_le_reg_r with (bpow (ex - prec)).
149
apply bpow_gt_0.
150
rewrite <- bpow_plus.
151
replace (prec - 1 + (ex - prec))%Z with (ex - 1)%Z by ring.
152
change (bpow (ex - 1) <= F2R (Float beta (Zabs (Ztrunc (x * bpow (- (ex - prec))))) (ex - prec)))%R.
BOLDO Sylvie's avatar
BOLDO Sylvie committed
153
rewrite F2R_Zabs, <- Hx2.
154 155 156 157 158 159
apply Hx4.
apply Zle_minus_le_0.
now apply (Zlt_le_succ 0).
apply lt_Z2R.
rewrite Z2R_Zpower.
apply Rmult_lt_reg_r with (bpow (ex - prec)).
160
apply bpow_gt_0.
161
rewrite <- bpow_plus.
162
replace (prec + (ex - prec))%Z with ex by ring.
163
change (F2R (Float beta (Zabs (Ztrunc (x * bpow (- (ex - prec))))) (ex - prec)) < bpow ex)%R.
BOLDO Sylvie's avatar
BOLDO Sylvie committed
164
rewrite F2R_Zabs, <- Hx2.
165 166 167 168 169
apply Hx4.
now apply Zlt_le_weak.
now apply Zge_le.
Qed.

170 171 172
Theorem FTZ_format_satisfies_any :
  satisfies_any FTZ_format.
Proof.
173
refine (satisfies_any_eq _ _ _ (generic_format_satisfies_any beta FTZ_exp)).
Guillaume Melquiond's avatar
Guillaume Melquiond committed
174
intros x.
175
split.
Guillaume Melquiond's avatar
Guillaume Melquiond committed
176
apply FTZ_format_generic.
177
apply generic_format_FTZ.
178 179 180 181 182
Qed.

Theorem FTZ_format_FLXN :
  forall x : R,
  (bpow (emin + prec - 1) <= Rabs x)%R ->
183 184 185 186 187 188 189 190 191 192 193 194
  FLXN_format beta prec x -> FTZ_format x.
Proof.
intros x Hx Fx.
apply FTZ_format_generic.
apply generic_format_FLXN in Fx.
revert Hx Fx.
apply generic_inclusion_ge.
intros e He.
unfold FTZ_exp.
rewrite Zlt_bool_false.
apply Zle_refl.
omega.
195 196
Qed.

197
Section FTZ_round.
198

199
(** Rounding with FTZ *)
200 201
Variable rnd : R -> Z.
Context { valid_rnd : Valid_rnd rnd }.
202

203
Definition Zrnd_FTZ x :=
204
  if Rle_bool R1 (Rabs x) then rnd x else Z0.
205

206 207 208 209
Global Instance valid_rnd_FTZ : Valid_rnd Zrnd_FTZ.
Proof with auto with typeclass_instances.
split.
(* *)
210
intros x y Hxy.
211 212 213 214 215
unfold Zrnd_FTZ.
case Rle_bool_spec ; intros Hx ;
  case Rle_bool_spec ; intros Hy.
4: easy.
(* 1 <= |x| *)
216
now apply Zrnd_le.
217
rewrite <- (Zrnd_Z2R rnd 0).
218
apply Zrnd_le...
219
apply Rle_trans with (Z2R (-1)). 2: now apply Z2R_le.
220
destruct (Rabs_ge_inv _ _ Hx) as [Hx1|Hx1].
221 222 223 224 225 226
exact Hx1.
elim Rle_not_lt with (1 := Hx1).
apply Rle_lt_trans with (2 := Hy).
apply Rle_trans with (1 := Hxy).
apply RRle_abs.
(* |x| < 1 *)
227
rewrite <- (Zrnd_Z2R rnd 0).
228
apply Zrnd_le...
229 230
apply Rle_trans with (Z2R 1).
now apply Z2R_le.
231
destruct (Rabs_ge_inv _ _ Hy) as [Hy1|Hy1].
232 233 234 235
elim Rle_not_lt with (1 := Hy1).
apply Rlt_le_trans with (2 := Hxy).
apply (Rabs_def2 _ _ Hx).
exact Hy1.
236 237 238 239 240 241 242 243 244 245 246
(* *)
intros n.
unfold Zrnd_FTZ.
rewrite Zrnd_Z2R...
case Rle_bool_spec.
easy.
rewrite <- Z2R_abs.
intros H.
generalize (lt_Z2R _ 1 H).
clear.
now case n ; trivial ; simpl ; intros [p|p|].
247 248
Qed.

249
Theorem round_FTZ_FLX :
250 251
  forall x : R,
  (bpow (emin + prec - 1) <= Rabs x)%R ->
252
  round beta FTZ_exp Zrnd_FTZ x = round beta (FLX_exp prec) rnd x.
253 254
Proof.
intros x Hx.
BOLDO Sylvie's avatar
BOLDO Sylvie committed
255
unfold round, scaled_mantissa, canonic_exp.
256 257 258 259 260 261 262 263 264 265 266 267
destruct (ln_beta beta x) as (ex, He). simpl.
assert (Hx0: x <> R0).
intros Hx0.
apply Rle_not_lt with (1 := Hx).
rewrite Hx0, Rabs_R0.
apply bpow_gt_0.
specialize (He Hx0).
assert (He': (emin + prec <= ex)%Z).
apply (bpow_lt_bpow beta).
apply Rle_lt_trans with (1 := Hx).
apply He.
replace (FTZ_exp ex) with (FLX_exp prec ex).
268
unfold Zrnd_FTZ.
269 270 271 272 273 274
rewrite Rle_bool_true.
apply refl_equal.
rewrite Rabs_mult.
rewrite (Rabs_pos_eq (bpow (- FLX_exp prec ex))).
change R1 with (bpow 0).
rewrite <- (Zplus_opp_r (FLX_exp prec ex)).
275
rewrite bpow_plus.
276 277 278
apply Rmult_le_compat_r.
apply bpow_ge_0.
apply Rle_trans with (2 := proj1 He).
279
apply bpow_le.
280
unfold FLX_exp.
281 282
generalize (prec_gt_0 prec).
clear -He' ; omega.
283 284
apply bpow_ge_0.
unfold FLX_exp, FTZ_exp.
285 286 287
rewrite Zlt_bool_false.
apply refl_equal.
clear -He' ; omega.
288 289
Qed.

290
Theorem round_FTZ_small :
291 292
  forall x : R,
  (Rabs x < bpow (emin + prec - 1))%R ->
293 294
  round beta FTZ_exp Zrnd_FTZ x = R0.
Proof with auto with typeclass_instances.
295 296 297
intros x Hx.
destruct (Req_dec x 0) as [Hx0|Hx0].
rewrite Hx0.
298
apply round_0...
BOLDO Sylvie's avatar
BOLDO Sylvie committed
299
unfold round, scaled_mantissa, canonic_exp.
300 301 302 303 304 305 306 307 308
destruct (ln_beta beta x) as (ex, He). simpl.
specialize (He Hx0).
unfold Zrnd_FTZ.
rewrite Rle_bool_false.
apply F2R_0.
rewrite Rabs_mult.
rewrite (Rabs_pos_eq (bpow (- FTZ_exp ex))).
change R1 with (bpow 0).
rewrite <- (Zplus_opp_r (FTZ_exp ex)).
309
rewrite bpow_plus.
310 311 312
apply Rmult_lt_compat_r.
apply bpow_gt_0.
apply Rlt_le_trans with (1 := Hx).
313
apply bpow_le.
314 315 316 317 318 319 320 321
unfold FTZ_exp.
generalize (Zlt_cases (ex - prec) emin).
case Zlt_bool.
intros _.
apply Zle_refl.
intros He'.
elim Rlt_not_le with (1 := Hx).
apply Rle_trans with (2 := proj1 He).
322
apply bpow_le.
323 324 325 326
omega.
apply bpow_ge_0.
Qed.

327
End FTZ_round.
328

329
End RND_FTZ.