Flocq_rnd_generic.v 17.9 KB
Newer Older
Guillaume Melquiond's avatar
Guillaume Melquiond committed
1 2 3
Require Import Flocq_Raux.
Require Import Flocq_defs.
Require Import Flocq_rnd_ex.
Guillaume Melquiond's avatar
Guillaume Melquiond committed
4
Require Import Flocq_float_prop.
Guillaume Melquiond's avatar
Guillaume Melquiond committed
5 6 7 8 9 10 11 12 13

Section RND_generic.

Variable beta : radix.

Notation bpow := (epow beta).

Variable fexp : Z -> Z.

14 15 16 17 18 19 20 21
Definition valid_exp :=
  forall k : Z,
  ( (fexp k < k)%Z -> (fexp (k + 1) <= k)%Z ) /\
  ( (k <= fexp k)%Z ->
    (fexp (fexp k + 1) <= fexp k)%Z /\
    forall l : Z, (l <= fexp k)%Z -> fexp l = fexp k ).

Variable prop_exp : valid_exp.
Guillaume Melquiond's avatar
Guillaume Melquiond committed
22 23 24

Definition generic_format (x : R) :=
  exists f : float beta,
25 26
  x = F2R f /\ forall (H : x <> R0),
  Fexp f = fexp (projT1 (ln_beta beta _ (Rabs_pos_lt _ H))).
Guillaume Melquiond's avatar
Guillaume Melquiond committed
27

Guillaume Melquiond's avatar
Guillaume Melquiond committed
28 29 30 31 32
Theorem generic_DN_pt_large_pos_ge_pow :
  forall x ex,
  (fexp ex < ex)%Z ->
  (bpow (ex - 1)%Z <= x)%R ->
  (bpow (ex - 1)%Z <= F2R (Float beta (up (x * bpow (- fexp ex)%Z) - 1) (fexp ex)))%R.
Guillaume Melquiond's avatar
Guillaume Melquiond committed
33
Proof.
Guillaume Melquiond's avatar
Guillaume Melquiond committed
34
intros x ex He1 Hx1.
35
unfold F2R. simpl.
Guillaume Melquiond's avatar
Guillaume Melquiond committed
36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71
replace (ex - 1)%Z with ((ex - 1 - fexp ex) + fexp ex)%Z by ring.
rewrite epow_add.
apply Rmult_le_compat_r.
apply epow_ge_0.
assert (bpow (ex - 1 - fexp ex)%Z < Z2R (up (x * bpow (- fexp ex)%Z)))%R.
rewrite Z2R_IZR.
apply Rle_lt_trans with (2 := proj1 (archimed _)).
unfold Zminus.
rewrite epow_add.
apply Rmult_le_compat_r.
apply epow_ge_0.
exact Hx1.
case_eq (ex - 1 - fexp ex)%Z.
intros He2.
change (bpow 0%Z) with (Z2R 1).
apply Z2R_le.
change 1%Z at 1 with (1 + 1 - 1)%Z.
apply Zplus_le_compat_r.
apply (Zlt_le_succ 1).
apply lt_Z2R.
now rewrite He2 in H.
intros ep He2.
simpl.
apply Z2R_le.
replace (Zpower_pos (radix_val beta) ep) with (Zpower_pos (radix_val beta) ep + 1 - 1)%Z by ring.
apply Zplus_le_compat_r.
apply Zlt_le_succ.
apply lt_Z2R.
change (bpow (Zpos ep) < Z2R (up (x * bpow (- fexp ex)%Z)))%R.
now rewrite <- He2.
clear H Hx1.
intros.
assert (ex - 1 - fexp ex < 0)%Z.
now rewrite H.
apply False_ind.
omega.
Guillaume Melquiond's avatar
Guillaume Melquiond committed
72 73 74 75 76 77 78 79 80 81 82 83
Qed.

Theorem generic_DN_pt_pos :
  forall x ex,
  (bpow (ex - 1)%Z <= x < bpow ex)%R ->
  Rnd_DN_pt generic_format x (F2R (Float beta (up (x * bpow (Zopp (fexp ex))) - 1) (fexp ex))).
Proof.
intros x ex (Hx1, Hx2).
destruct (Z_lt_le_dec (fexp ex) ex) as [He1|He1].
(* - positive big enough *)
assert (Hbl : (bpow (ex - 1)%Z <= F2R (Float beta (up (x * bpow (- fexp ex)%Z) - 1) (fexp ex)))%R).
now apply generic_DN_pt_large_pos_ge_pow.
Guillaume Melquiond's avatar
Guillaume Melquiond committed
84 85
split.
(* - . rounded *)
86
eexists ; split ; [ reflexivity | idtac ].
Guillaume Melquiond's avatar
Guillaume Melquiond committed
87 88 89 90 91 92 93 94 95 96
intros He9.
simpl.
apply f_equal.
apply sym_eq.
apply ln_beta_unique.
clear He9.
rewrite Rabs_right.
split.
exact Hbl.
apply Rle_lt_trans with (2 := Hx2).
97
unfold F2R. simpl.
Guillaume Melquiond's avatar
Guillaume Melquiond committed
98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119
pattern x at 2 ; replace x with ((x * bpow (- fexp ex)%Z) * bpow (fexp ex))%R.
generalize (x * bpow (- fexp ex)%Z)%R.
clear.
intros x.
apply Rmult_le_compat_r.
apply epow_ge_0.
rewrite minus_Z2R.
rewrite Z2R_IZR.
simpl.
apply Rplus_le_reg_l with (- x + 1)%R.
ring_simplify.
rewrite Rplus_comm.
exact (proj2 (archimed x)).
rewrite Rmult_assoc.
rewrite <- epow_add.
rewrite Zplus_opp_l.
apply Rmult_1_r.
apply Rle_ge.
apply Rle_trans with (2 := Hbl).
apply epow_ge_0.
split.
(* - . smaller *)
120
unfold F2R. simpl.
Guillaume Melquiond's avatar
Guillaume Melquiond committed
121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143
generalize (fexp ex).
clear.
intros e.
pattern x at 2 ; rewrite <- Rmult_1_r.
change R1 with (bpow Z0).
rewrite <- (Zplus_opp_l e).
rewrite epow_add, <- Rmult_assoc.
apply Rmult_le_compat_r.
apply epow_ge_0.
rewrite minus_Z2R.
rewrite Z2R_IZR.
simpl.
apply Rplus_le_reg_l with (1 - x * bpow (-e)%Z)%R.
ring_simplify.
rewrite Rplus_comm.
rewrite Ropp_mult_distr_l_reverse.
exact (proj2 (archimed _)).
(* - . biggest *)
intros g ((gm, ge), (Hg1, Hg2)) Hgx.
destruct (Rle_or_lt g R0) as [Hg3|Hg3].
apply Rle_trans with (2 := Hbl).
apply Rle_trans with (1 := Hg3).
apply epow_ge_0.
144
specialize (Hg2 (Rgt_not_eq _ _ Hg3)).
Guillaume Melquiond's avatar
Guillaume Melquiond committed
145 146 147 148 149 150 151
apply Rnot_lt_le.
intros Hrg.
assert (bpow (ex - 1)%Z <= g < bpow ex)%R.
split.
apply Rle_trans with (1 := Hbl).
now apply Rlt_le.
now apply Rle_lt_trans with (1 := Hgx).
152
rewrite <- (Rabs_pos_eq g (Rlt_le _ _ Hg3)) in H.
Guillaume Melquiond's avatar
Guillaume Melquiond committed
153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185
rewrite ln_beta_unique with (1 := H) in Hg2.
simpl in Hg2.
apply Rlt_not_le with (1 := Hrg).
rewrite Hg1, Hg2.
unfold F2R. simpl.
apply Rmult_le_compat_r.
apply epow_ge_0.
apply Z2R_le.
cut (gm < up (x * bpow (- fexp ex)%Z))%Z.
omega.
apply lt_IZR.
apply Rle_lt_trans with (2 := proj1 (archimed _)).
apply Rmult_le_reg_r with (bpow (fexp ex)).
apply epow_gt_0.
rewrite <- Hg2 at 1.
rewrite <- Z2R_IZR.
rewrite Rmult_assoc.
rewrite <- epow_add.
rewrite Zplus_opp_l.
rewrite Rmult_1_r.
unfold F2R in Hg1.
simpl in Hg1.
now rewrite <- Hg1.
(* - positive too small *)
cutrewrite (up (x * bpow (- fexp ex)%Z) = 1%Z).
(* - . rounded *)
unfold F2R. simpl.
rewrite Rmult_0_l.
split.
exists (Float beta Z0 (fexp ex)).
split.
unfold F2R. simpl.
now rewrite Rmult_0_l.
186 187
intros H.
now elim H.
Guillaume Melquiond's avatar
Guillaume Melquiond committed
188
split.
Guillaume Melquiond's avatar
Guillaume Melquiond committed
189 190
apply Rle_trans with (2 := Hx1).
apply epow_ge_0.
Guillaume Melquiond's avatar
Guillaume Melquiond committed
191 192 193 194
(* - . biggest *)
intros g ((gm, ge), (Hg1, Hg2)) Hgx.
apply Rnot_lt_le.
intros Hg3.
195
specialize (Hg2 (Rgt_not_eq _ _ Hg3)).
Guillaume Melquiond's avatar
Guillaume Melquiond committed
196
destruct (ln_beta beta g Hg3) as (ge', Hg4).
197 198 199
generalize Hg4. intros Hg5.
rewrite <- (Rabs_pos_eq g (Rlt_le _ _ Hg3)) in Hg5.
rewrite ln_beta_unique with (1 := Hg5) in Hg2.
Guillaume Melquiond's avatar
Guillaume Melquiond committed
200 201 202
apply (Rlt_not_le _ _ (Rle_lt_trans _ _ _ Hgx Hx2)).
apply Rle_trans with (bpow ge).
apply -> epow_le.
203
simpl in Hg2.
Guillaume Melquiond's avatar
Guillaume Melquiond committed
204
rewrite Hg2.
205
rewrite (proj2 (proj2 (prop_exp ex) He1) ge').
Guillaume Melquiond's avatar
Guillaume Melquiond committed
206 207
exact He1.
apply Zle_trans with (2 := He1).
208
cut (ge' - 1 < ex)%Z. omega.
Guillaume Melquiond's avatar
Guillaume Melquiond committed
209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231
apply <- epow_lt.
apply Rle_lt_trans with (2 := Hx2).
apply Rle_trans with (2 := Hgx).
exact (proj1 Hg4).
rewrite Hg1.
unfold F2R. simpl.
pattern (bpow ge) at 1 ; rewrite <- Rmult_1_l.
apply Rmult_le_compat_r.
apply epow_ge_0.
apply (Z2R_le 1).
apply (Zlt_le_succ 0).
apply lt_Z2R.
apply Rmult_lt_reg_r with (bpow ge).
apply epow_gt_0.
rewrite Rmult_0_l.
unfold F2R in Hg1. simpl in Hg1.
now rewrite <- Hg1.
(* - . . *)
apply sym_eq.
rewrite <- (Zplus_0_l 1).
apply up_tech.
apply Rlt_le.
apply Rmult_lt_0_compat.
Guillaume Melquiond's avatar
Guillaume Melquiond committed
232 233
apply Rlt_le_trans with (2 := Hx1).
apply epow_gt_0.
Guillaume Melquiond's avatar
Guillaume Melquiond committed
234 235 236 237 238 239 240 241
apply epow_gt_0.
change (IZR (0 + 1)) with (bpow Z0).
rewrite <- (Zplus_opp_r (fexp ex)).
rewrite epow_add.
apply Rmult_lt_compat_r.
apply epow_gt_0.
apply Rlt_le_trans with (1 := Hx2).
now apply -> epow_le.
Guillaume Melquiond's avatar
Guillaume Melquiond committed
242 243 244 245 246 247 248 249 250 251 252 253 254
Qed.

Theorem generic_DN_pt_neg :
  forall x ex,
  (bpow (ex - 1)%Z <= -x < bpow ex)%R ->
  Rnd_DN_pt generic_format x (F2R (Float beta (up (x * bpow (Zopp (fexp ex))) - 1) (fexp ex))).
Proof.
intros x ex (Hx1, Hx2).
assert (Hx : (x < 0)%R).
apply Ropp_lt_cancel.
rewrite Ropp_0.
apply Rlt_le_trans with (2 := Hx1).
apply epow_gt_0.
Guillaume Melquiond's avatar
Guillaume Melquiond committed
255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306
assert (Hbr : (F2R (Float beta (up (x * bpow (- fexp ex)%Z) - 1) (fexp ex)) <= x)%R).
(* - bounded right *)
unfold F2R. simpl.
pattern x at 2 ; rewrite <- Rmult_1_r.
change R1 with (bpow Z0).
rewrite <- (Zplus_opp_l (fexp ex)).
rewrite epow_add.
rewrite <- Rmult_assoc.
generalize (x * bpow (- fexp ex)%Z)%R.
clear.
intros x.
apply Rmult_le_compat_r.
apply epow_ge_0.
rewrite minus_Z2R.
simpl.
rewrite Z2R_IZR.
apply Rplus_le_reg_l with (-x + 1)%R.
ring_simplify.
rewrite Rplus_comm.
exact (proj2 (archimed x)).
destruct (Z_lt_le_dec (fexp ex) ex) as [He1|He1].
(* - negative big enough *)
assert (Hbl : (- bpow ex <= F2R (Float beta (up (x * bpow (- fexp ex)%Z) - 1) (fexp ex)))%R).
(* - . bounded left *)
unfold F2R. simpl.
pattern ex at 1 ; replace ex with (ex - fexp ex + fexp ex)%Z by ring.
rewrite epow_add.
rewrite <- Ropp_mult_distr_l_reverse.
apply Rmult_le_compat_r.
apply epow_ge_0.
cut (0 < ex - fexp ex)%Z. 2: omega.
case_eq (ex - fexp ex)%Z ; try (intros ; discriminate H0).
intros ep Hp _.
simpl.
rewrite <- opp_Z2R.
apply Z2R_le.
cut (- Zpower_pos (radix_val beta) ep < up (x * bpow (- fexp ex)%Z))%Z.
omega.
apply lt_Z2R.
apply Rle_lt_trans with (x * bpow (- fexp ex)%Z)%R.
rewrite opp_Z2R.
change (- bpow (Zpos ep) <= x * bpow (- fexp ex)%Z)%R.
rewrite <- Hp.
apply Rmult_le_reg_r with (bpow (fexp ex)).
apply epow_gt_0.
rewrite Rmult_assoc.
rewrite <- epow_add.
rewrite Zplus_opp_l.
rewrite Rmult_1_r.
rewrite Ropp_mult_distr_l_reverse.
rewrite <- epow_add.
replace (ex - fexp ex + fexp ex)%Z with ex by ring.
Guillaume Melquiond's avatar
Guillaume Melquiond committed
307 308
apply Ropp_le_cancel.
rewrite Ropp_involutive.
Guillaume Melquiond's avatar
Guillaume Melquiond committed
309 310 311 312 313 314 315 316 317 318 319 320 321
now apply Rlt_le.
rewrite Z2R_IZR.
exact (proj1 (archimed _)).
split.
(* - . rounded *)
destruct (Rle_lt_or_eq_dec _ _ Hbl) as [Hbl2|Hbl2].
(* - . . not a radix power *)
eexists ; split ; [ reflexivity | idtac ].
intros Hr.
simpl.
apply f_equal.
apply sym_eq.
apply ln_beta_unique.
322
rewrite Rabs_left.
Guillaume Melquiond's avatar
Guillaume Melquiond committed
323
split.
324 325
apply Ropp_le_cancel.
rewrite Ropp_involutive.
Guillaume Melquiond's avatar
Guillaume Melquiond committed
326
apply Rle_trans with (1 := Hbr).
327 328 329 330
apply Ropp_le_cancel.
now rewrite Ropp_involutive.
apply Ropp_lt_cancel.
now rewrite Ropp_involutive.
Guillaume Melquiond's avatar
Guillaume Melquiond committed
331 332 333 334
apply Rle_lt_trans with (1 := Hbr).
exact Hx.
(* - . . a radix power *)
rewrite <- Hbl2.
335
generalize (proj1 (prop_exp _) He1).
Guillaume Melquiond's avatar
Guillaume Melquiond committed
336 337 338 339 340 341 342 343 344 345 346 347 348 349 350
clear.
intros He2.
exists (Float beta (- Zpower (radix_val beta) (ex - fexp (ex + 1))) (fexp (ex + 1))).
unfold F2R. simpl.
split.
clear -He2.
pattern ex at 1 ; replace ex with (ex - fexp (ex + 1) + fexp (ex + 1))%Z by ring.
rewrite epow_add.
rewrite <- Ropp_mult_distr_l_reverse.
rewrite opp_Z2R.
apply (f_equal (fun x => (- x * _)%R)).
cut (0 <= ex - fexp (ex + 1))%Z. 2: omega.
case (ex - fexp (ex + 1))%Z ; trivial.
intros ep H.
now elim H.
351
intros H.
Guillaume Melquiond's avatar
Guillaume Melquiond committed
352 353 354
apply f_equal.
apply sym_eq.
apply ln_beta_unique.
355 356
rewrite Rabs_Ropp.
rewrite Rabs_right.
Guillaume Melquiond's avatar
Guillaume Melquiond committed
357 358 359 360 361 362 363 364 365 366 367 368 369 370 371
split.
apply -> epow_le.
omega.
apply -> epow_lt.
apply Zlt_succ.
apply Rle_ge.
apply epow_ge_0.
split.
exact Hbr.
(* - . biggest *)
intros g ((gm, ge), (Hg1, Hg2)) Hgx.
apply Rnot_lt_le.
intros Hg3.
assert (Hg4 : (g < 0)%R).
now apply Rle_lt_trans with (1 := Hgx).
372 373
specialize (Hg2 (Rlt_not_eq _ _ Hg4)).
destruct (ln_beta beta (Rabs g) (Rabs_pos_lt g (Rlt_not_eq g 0 Hg4))) as (ge', Hge).
Guillaume Melquiond's avatar
Guillaume Melquiond committed
374 375 376 377 378 379 380 381 382
simpl in Hg2.
apply Rlt_not_le with (1 := Hg3).
rewrite Hg1.
unfold F2R. simpl.
rewrite Hg2.
assert (Hge' : ge' = ex).
apply epow_unique with (1 := Hge).
split.
apply Rle_trans with (1 := Hx1).
383
rewrite Rabs_left with (1 := Hg4).
Guillaume Melquiond's avatar
Guillaume Melquiond committed
384 385
now apply Ropp_le_contravar.
apply Ropp_lt_cancel.
386 387 388
rewrite Rabs_left with (1 := Hg4).
rewrite Ropp_involutive.
now apply Rle_lt_trans with (1 := Hbl).
Guillaume Melquiond's avatar
Guillaume Melquiond committed
389 390 391 392
rewrite Hge'.
apply Rmult_le_compat_r.
apply epow_ge_0.
apply Z2R_le.
393
cut (gm < up (x * bpow (- fexp ex)%Z))%Z. omega.
Guillaume Melquiond's avatar
Guillaume Melquiond committed
394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413
apply lt_IZR.
apply Rle_lt_trans with (2 := proj1 (archimed _)).
rewrite <- Z2R_IZR.
apply Rmult_le_reg_r with (bpow (fexp ex)).
apply epow_gt_0.
rewrite Rmult_assoc.
rewrite <- epow_add.
rewrite Zplus_opp_l.
rewrite Rmult_1_r.
rewrite <- Hge'.
rewrite <- Hg2.
unfold F2R in Hg1. simpl in Hg1.
now rewrite <- Hg1.
(* - negative too small *)
cutrewrite (up (x * bpow (- fexp ex)%Z) = 0%Z).
unfold F2R. simpl.
rewrite Ropp_mult_distr_l_reverse.
rewrite Rmult_1_l.
(* - . rounded *)
split.
414
destruct (proj2 (prop_exp _) He1) as (He2, _).
Guillaume Melquiond's avatar
Guillaume Melquiond committed
415 416 417 418 419 420 421 422 423 424 425 426 427
exists (Float beta (- Zpower (radix_val beta) (fexp ex - fexp (fexp ex + 1))) (fexp (fexp ex + 1))).
unfold F2R. simpl.
split.
rewrite opp_Z2R.
pattern (fexp ex) at 1 ; replace (fexp ex) with (fexp ex - fexp (fexp ex + 1) + fexp (fexp ex + 1))%Z by ring.
rewrite epow_add.
rewrite Ropp_mult_distr_l_reverse.
apply (f_equal (fun x => (- (x * _))%R)).
cut (0 <= fexp ex - fexp (fexp ex + 1))%Z. 2: omega.
clear.
case (fexp ex - fexp (fexp ex + 1))%Z ; trivial.
intros ep Hp.
now elim Hp.
428
intros H.
Guillaume Melquiond's avatar
Guillaume Melquiond committed
429 430 431
apply f_equal.
apply sym_eq.
apply ln_beta_unique.
432 433
rewrite Rabs_left.
rewrite Ropp_involutive.
Guillaume Melquiond's avatar
Guillaume Melquiond committed
434 435 436 437 438
split.
replace (fexp ex + 1 - 1)%Z with (fexp ex) by ring.
apply Rle_refl.
apply -> epow_lt.
apply Zlt_succ.
439 440 441
rewrite <- Ropp_0.
apply Ropp_lt_contravar.
apply epow_gt_0.
Guillaume Melquiond's avatar
Guillaume Melquiond committed
442 443
split.
(* - . smaller *)
444 445
apply Ropp_le_cancel.
rewrite Ropp_involutive.
Guillaume Melquiond's avatar
Guillaume Melquiond committed
446 447 448 449 450 451 452 453 454
apply Rlt_le.
apply Rlt_le_trans with (1 := Hx2).
now apply -> epow_le.
(* - . biggest *)
intros g ((gm, ge), (Hg1, Hg2)) Hgx.
apply Rnot_lt_le.
intros Hg3.
assert (Hg4 : (g < 0)%R).
now apply Rle_lt_trans with (1 := Hgx).
455 456
specialize (Hg2 (Rlt_not_eq _ _ Hg4)).
destruct (ln_beta beta (Rabs g) (Rabs_pos_lt g (Rlt_not_eq g 0 Hg4))) as (ge', Hge).
Guillaume Melquiond's avatar
Guillaume Melquiond committed
457
simpl in Hg2.
458
rewrite (Rabs_left _ Hg4) in Hge.
Guillaume Melquiond's avatar
Guillaume Melquiond committed
459 460 461 462 463 464
assert (Hge' : (ge' <= fexp ex)%Z).
cut (ge' - 1 < fexp ex)%Z. omega.
apply <- epow_lt.
apply Rle_lt_trans with (1 := proj1 Hge).
apply Ropp_lt_cancel.
now rewrite Ropp_involutive.
465
rewrite (proj2 (proj2 (prop_exp _) He1) _ Hge') in Hg2.
Guillaume Melquiond's avatar
Guillaume Melquiond committed
466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483
rewrite <- Hg2 in Hge'.
apply Rlt_not_le with (1 := proj2 Hge).
rewrite Hg1.
unfold F2R. simpl.
rewrite <- Ropp_mult_distr_l_reverse.
replace ge with (ge - ge' + ge')%Z by ring.
rewrite epow_add.
rewrite <- Rmult_assoc.
pattern (bpow ge') at 1 ; rewrite <- Rmult_1_l.
apply Rmult_le_compat_r.
apply epow_ge_0.
rewrite <- opp_Z2R.
assert (1 <= -gm)%Z.
apply (Zlt_le_succ 0).
apply lt_Z2R.
apply Rmult_lt_reg_r with (bpow ge).
apply epow_gt_0.
rewrite Rmult_0_l.
Guillaume Melquiond's avatar
Guillaume Melquiond committed
484 485
change (0 < F2R (Float beta (-gm) ge))%R.
rewrite <- opp_F2R.
486 487 488
rewrite <- Hg1.
rewrite <- Ropp_0.
now apply Ropp_lt_contravar.
Guillaume Melquiond's avatar
Guillaume Melquiond committed
489 490 491 492 493 494 495 496 497 498 499
apply Rle_trans with (1 * bpow (ge - ge')%Z)%R.
rewrite Rmult_1_l.
cut (0 <= ge - ge')%Z. 2: omega.
clear.
case (ge - ge')%Z.
intros _.
apply Rle_refl.
intros ep _.
simpl.
apply (Z2R_le 1).
apply (Zlt_le_succ 0).
500
apply Zpower_pos_gt_0.
Guillaume Melquiond's avatar
Guillaume Melquiond committed
501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527
now apply Zlt_le_trans with (2 := radix_prop beta).
intros ep Hp. now elim Hp.
apply Rmult_le_compat_r.
apply epow_ge_0.
now apply (Z2R_le 1).
(* - . . *)
apply sym_eq.
apply (up_tech _ (-1)).
apply Ropp_le_cancel.
simpl.
rewrite Ropp_involutive.
change R1 with (bpow Z0).
rewrite <- (Zplus_opp_r (fexp ex)).
rewrite epow_add.
rewrite <- Ropp_mult_distr_l_reverse.
apply Rmult_le_compat_r.
apply epow_ge_0.
apply Rlt_le.
apply Rlt_le_trans with (1 := Hx2).
now apply -> epow_le.
simpl.
rewrite <- (Rmult_0_l (bpow (- fexp ex)%Z)).
apply Rmult_lt_compat_r.
apply epow_gt_0.
exact Hx.
Qed.

Guillaume Melquiond's avatar
Guillaume Melquiond committed
528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595
Theorem generic_format_satisfies_any :
  satisfies_any generic_format.
Proof.
refine ((fun D => Satisfies_any _ _ _ (projT1 D) (projT2 D)) _).
(* symmetric set *)
exists (Float beta 0 0).
split.
unfold F2R. simpl.
now rewrite Rmult_0_l.
intros H.
now elim H.
intros x ((m,e),(H1,H2)).
exists (Float beta (-m) e).
split.
rewrite H1.
apply opp_F2R.
intros H3.
simpl in H2.
assert (H4 := Ropp_neq_0_compat _ H3).
rewrite Ropp_involutive in H4.
rewrite (H2 H4).
clear H2.
destruct (ln_beta beta (Rabs x)) as (ex, H5).
simpl.
apply f_equal.
apply sym_eq.
apply ln_beta_unique.
now rewrite Rabs_Ropp.
(* rounding down *)
assert (Hxx : forall x, (0 > x)%R -> (0 < -x)%R).
intros.
now apply Ropp_0_gt_lt_contravar.
exists (fun x =>
  match total_order_T 0 x with
  | inleft (left Hx) =>
    let e := fexp (projT1 (ln_beta beta _ Hx)) in
    F2R (Float beta (up (x * bpow (Zopp e)) - 1) e)
  | inleft (right _) => R0
  | inright Hx =>
    let e := fexp (projT1 (ln_beta beta _ (Hxx _ Hx))) in
    F2R (Float beta (up (x * bpow (Zopp e)) - 1) e)
  end).
intros x.
destruct (total_order_T 0 x) as [[Hx|Hx]|Hx].
(* positive *)
destruct (ln_beta beta x Hx) as (ex, Hx').
simpl.
now apply generic_DN_pt_pos.
(* zero *)
split.
exists (Float beta 0 0).
split.
unfold F2R.
now rewrite Rmult_0_l.
intros H.
now elim H.
rewrite <- Hx.
split.
apply Rle_refl.
intros g _ H.
exact H.
(* negative *)
destruct (ln_beta beta (- x) (Hxx x Hx)) as (ex, Hx').
simpl.
now apply generic_DN_pt_neg.
Qed.

Theorem generic_DN_pt_small_pos :
596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638
  forall x ex,
  (bpow (ex - 1)%Z <= x < bpow ex)%R ->
  (ex <= fexp ex)%Z ->
  Rnd_DN_pt generic_format x R0.
Proof.
intros x ex Hx He.
split.
exists (Float beta 0 0).
unfold F2R. simpl.
split.
now rewrite Rmult_0_l.
intros H.
now elim H.
split.
apply Rle_trans with (2 := proj1 Hx).
apply epow_ge_0.
(* . *)
intros g ((gm, ge), (Hg1, Hg2)) Hgx.
apply Rnot_lt_le.
intros Hg3.
specialize (Hg2 (Rgt_not_eq _ _ Hg3)).
destruct (ln_beta beta (Rabs g) (Rabs_pos_lt g (Rgt_not_eq g 0 Hg3))) as (eg, Hg4).
simpl in Hg2.
rewrite Rabs_right in Hg4.
apply Rle_not_lt with (1 := Hgx).
rewrite Hg1.
apply Rlt_le_trans with (1 := proj2 Hx).
rewrite (proj2 (proj2 (prop_exp _) He) eg) in Hg2.
rewrite Hg2.
apply Rle_trans with (bpow (fexp ex)).
now apply -> epow_le.
rewrite <- Hg2.
rewrite Hg1 in Hg3.
apply epow_le_F2R with (1 := Hg3).
apply epow_lt_epow with beta.
apply Rlt_le_trans with (bpow ex).
apply Rle_lt_trans with (2 := proj2 Hx).
now apply Rle_trans with g.
now apply -> epow_le.
apply Rle_ge.
now apply Rlt_le.
Qed.

Guillaume Melquiond's avatar
Guillaume Melquiond committed
639
Theorem generic_UP_pt_small_pos :
640 641 642 643 644 645 646 647 648 649
  forall x ex,
  (bpow (ex - 1)%Z <= x < bpow ex)%R ->
  (ex <= fexp ex)%Z ->
  Rnd_UP_pt generic_format x (bpow (fexp ex)).
Proof.
intros x ex Hx He.
assert (bpow (fexp ex) = F2R (Float beta 1 (fexp ex))).
unfold F2R. simpl.
now rewrite Rmult_1_l.
destruct (F2R_prec_normalize beta 1 (fexp ex) (fexp ex) ((fexp ex + 1) - fexp (fexp ex + 1))) as (m, H0).
650
apply Zpower_gt_1.
651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711
generalize (proj1 (proj2 (prop_exp ex) He)).
omega.
rewrite <- H.
apply RRle_abs.
split.
(* . *)
rewrite H.
eexists ; split ; [ apply H0 | idtac ].
simpl.
intros H1.
ring_simplify.
apply f_equal.
apply sym_eq.
apply ln_beta_unique.
rewrite <- H.
split.
replace (fexp ex + 1 - 1)%Z with (fexp ex) by ring.
apply RRle_abs.
rewrite Rabs_right.
apply -> epow_lt.
apply Zle_lt_succ.
apply Zle_refl.
apply Rle_ge.
apply epow_ge_0.
split.
(* . *)
apply Rlt_le.
apply Rlt_le_trans with (1 := proj2 Hx).
now apply -> epow_le.
(* . *)
intros g ((gm, ge), (Hg1, Hg2)) Hgx.
assert (g <> R0).
apply Rgt_not_eq.
apply Rlt_le_trans with (2 := Hgx).
apply Rlt_le_trans with (2 := proj1 Hx).
apply epow_gt_0.
specialize (Hg2 H1).
destruct (ln_beta beta (Rabs g) (Rabs_pos_lt g H1)) as (eg, Hg3).
simpl in Hg2.
apply Rnot_lt_le.
intros Hgp.
apply Rlt_not_le with (1 := Hgp).
rewrite <- (proj2 (proj2 (prop_exp ex) He) eg).
rewrite <- Hg2.
rewrite Hg1.
apply (epow_le_F2R _ (Float beta gm ge)).
rewrite <- Hg1.
apply Rlt_le_trans with (2 := Hgx).
apply Rlt_le_trans with (2 := proj1 Hx).
apply epow_gt_0.
apply epow_lt_epow with beta.
apply Rle_lt_trans with g.
rewrite <- (Rabs_right g).
apply Hg3.
apply Rle_ge.
apply Rle_trans with (2 := Hgx).
apply Rle_trans with (2 := proj1 Hx).
apply epow_ge_0.
exact Hgp.
Qed.

Guillaume Melquiond's avatar
Guillaume Melquiond committed
712
Theorem generic_UP_pt_large_pos_le_pow :
713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744
  forall x xu ex,
  (bpow (ex - 1)%Z <= x < bpow ex)%R ->
  (fexp ex < ex)%Z ->
  Rnd_UP_pt generic_format x xu ->
  (xu <= bpow ex)%R.
Proof.
intros x xu ex Hx He (((dm, de), (Hu1, Hu2)), (Hu3, Hu4)).
apply Hu4 with (2 := (Rlt_le _ _ (proj2 Hx))).
exists (Float beta (Zpower (radix_val beta) (ex - fexp (ex + 1))) (fexp (ex + 1))).
unfold F2R. simpl.
split.
(* . *)
rewrite Z2R_Zpower.
rewrite <- epow_add.
apply f_equal.
ring.
generalize (proj1 (prop_exp _) He).
omega.
(* . *)
intros H.
apply f_equal.
apply sym_eq.
apply ln_beta_unique.
rewrite Rabs_pos_eq.
split.
ring_simplify (ex + 1 - 1)%Z.
apply Rle_refl.
apply -> epow_lt.
apply Zlt_succ.
apply epow_ge_0.
Qed.

745
End RND_generic.