Une MAJ de sécurité est nécessaire sur notre version actuelle. Elle sera effectuée lundi 02/08 entre 12h30 et 13h. L'interruption de service devrait durer quelques minutes (probablement moins de 5 minutes).

Commit 18e98705 authored by Guillaume Melquiond's avatar Guillaume Melquiond
Browse files

Split truncate_correct.

parent 9540d864
...@@ -480,14 +480,13 @@ Definition truncate t := ...@@ -480,14 +480,13 @@ Definition truncate t :=
(Zdiv m p, (e + k)%Z, new_location p (Zmod m p) l) (Zdiv m p, (e + k)%Z, new_location p (Zmod m p) l)
else t. else t.
Theorem truncate_correct : Theorem truncate_correct_partial :
forall x m e l, forall x m e l,
(0 <= x)%R -> (0 < x)%R ->
inbetween_float beta m e x l -> inbetween_float beta m e x l ->
(e <= fexp (digits beta m + e))%Z \/ l = loc_Exact -> (e <= fexp (digits beta m + e))%Z ->
let '(m', e', l') := truncate (m, e, l) in let '(m', e', l') := truncate (m, e, l) in
inbetween_float beta m' e' x l' /\ inbetween_float beta m' e' x l' /\ e' = canonic_exponent beta fexp x.
(e' = canonic_exponent beta fexp x \/ (l' = loc_Exact /\ format x)).
Proof. Proof.
intros x m e l Hx H1 H2. intros x m e l Hx H1 H2.
unfold truncate. unfold truncate.
...@@ -503,15 +502,13 @@ assert (Hm: (0 <= m)%Z). ...@@ -503,15 +502,13 @@ assert (Hm: (0 <= m)%Z).
cut (0 < m + 1)%Z. omega. cut (0 < m + 1)%Z. omega.
apply F2R_lt_reg with beta e. apply F2R_lt_reg with beta e.
rewrite F2R_0. rewrite F2R_0.
apply Rle_lt_trans with (1 := Hx). apply Rlt_trans with (1 := Hx).
apply Hx'. apply Hx'.
destruct Hx as [Hx|Hx].
(* . 0 < x *)
assert (He: (e + k = canonic_exponent beta fexp x)%Z). assert (He: (e + k = canonic_exponent beta fexp x)%Z).
(* .. *) (* . *)
unfold canonic_exponent. unfold canonic_exponent.
destruct (Zle_lt_or_eq _ _ Hm) as [Hm'|Hm']. destruct (Zle_lt_or_eq _ _ Hm) as [Hm'|Hm'].
(* ... 0 < m *) (* .. 0 < m *)
rewrite ln_beta_F2R_bounds with (1 := Hm') (2 := Hx'). rewrite ln_beta_F2R_bounds with (1 := Hm') (2 := Hx').
assert (H: m <> Z0). assert (H: m <> Z0).
apply sym_not_eq. apply sym_not_eq.
...@@ -520,8 +517,7 @@ rewrite ln_beta_F2R with (1 := H). ...@@ -520,8 +517,7 @@ rewrite ln_beta_F2R with (1 := H).
rewrite <- digits_ln_beta with (1 := H). rewrite <- digits_ln_beta with (1 := H).
unfold k. unfold k.
ring. ring.
destruct H2 as [H2|H2]. (* .. m = 0 *)
(* ... m = 0 and enough digits *)
rewrite <- Hm' in H2. rewrite <- Hm' in H2.
destruct (ln_beta beta x) as (ex, Hex). destruct (ln_beta beta x) as (ex, Hex).
simpl. simpl.
...@@ -542,71 +538,103 @@ rewrite <- Hm' in Hx'. ...@@ -542,71 +538,103 @@ rewrite <- Hm' in Hx'.
apply Hx'. apply Hx'.
now apply Rlt_le. now apply Rlt_le.
exact H2. exact H2.
(* ... m = 0 and exact location *) (* . *)
rewrite H2 in H1.
inversion_clear H1.
rewrite <- Hm', F2R_0 in H.
rewrite H in Hx.
elim Rlt_irrefl with (1 := Hx).
(* .. *)
generalize (Zlt_cases 0 k). generalize (Zlt_cases 0 k).
case (Zlt_bool 0 k) ; intros Hk ; unfold k in Hk. case (Zlt_bool 0 k) ; intros Hk ; unfold k in Hk.
(* ... shift *)
split. split.
now apply inbetween_float_new_location. now apply inbetween_float_new_location.
now left. exact He.
split. split.
exact H1. exact H1.
destruct H2 as [H2|H2].
left.
rewrite <- He. rewrite <- He.
unfold k. unfold k.
omega. omega.
(* ... no shift *) Qed.
Theorem truncate_correct :
forall x m e l,
(0 <= x)%R ->
inbetween_float beta m e x l ->
(e <= fexp (digits beta m + e))%Z \/ l = loc_Exact ->
let '(m', e', l') := truncate (m, e, l) in
inbetween_float beta m' e' x l' /\
(e' = canonic_exponent beta fexp x \/ (l' = loc_Exact /\ format x)).
Proof.
intros x m e l [Hx|Hx] H1 H2.
(* 0 < x *)
destruct (Zle_or_lt e (fexp (digits beta m + e))) as [H3|H3].
(* . enough digits *)
generalize (truncate_correct_partial x m e l Hx H1 H3).
destruct (truncate (m, e, l)) as ((m', e'), l').
intros (H4, H5).
split.
exact H4.
now left.
(* . not enough digits but loc_Exact *)
destruct H2 as [H2|H2].
elim (Zlt_irrefl e).
now apply Zle_lt_trans with (1 := H2).
rewrite H2 in H1 |- *.
unfold truncate.
generalize (Zlt_cases 0 (fexp (digits beta m + e) - e)).
case Zlt_bool.
intros H.
apply False_ind.
omega.
intros _.
split.
exact H1.
right. right.
split. split.
exact H2. apply refl_equal.
rewrite H2 in H1.
inversion_clear H1. inversion_clear H1.
rewrite H. rewrite H.
apply generic_format_canonic_exponent. apply generic_format_canonic_exponent.
rewrite <- H, <- He. unfold canonic_exponent.
unfold k. rewrite ln_beta_F2R_digits.
omega. now apply Zlt_le_weak.
(* . x = 0 *) apply sym_not_eq.
destruct H1 as [H1|l' H1 _]. apply Zlt_not_eq.
(* .. exact location *) rewrite H in Hx.
case (Zlt_bool 0 k). apply F2R_gt_0_reg with (1 := Hx).
(* ... shift *) (* x = 0 *)
assert (Hm': m = Z0). assert (Hm: m = Z0).
apply F2R_eq_0_reg with beta e. cut (m <= 0 < m + 1)%Z. omega.
rewrite <- H1. assert (Hx': (F2R (Float beta m e) <= x < F2R (Float beta (m + 1) e))%R).
now apply sym_eq. apply inbetween_bounds with (2 := H1).
rewrite Hm'. apply F2R_lt_compat.
rewrite Zdiv_0_l, Zmod_0_l. apply Zlt_succ.
replace (new_location p 0 loc_Exact) with loc_Exact. rewrite <- Hx in Hx'.
split. split.
constructor. apply F2R_le_0_reg with (1 := proj1 Hx').
rewrite F2R_0. apply F2R_gt_0_reg with (1 := proj2 Hx').
now apply sym_eq. rewrite Hm, <- Hx in H1 |- *.
right. clear -H1.
repeat split. case H1.
rewrite <- Hx. (* . *)
apply generic_format_0. intros _.
assert (exists e', truncate (Z0, e, loc_Exact) = (Z0, e', loc_Exact)).
unfold truncate.
case Zlt_bool.
rewrite Zdiv_0_l, Zmod_0_l.
eexists.
apply f_equal.
unfold new_location. unfold new_location.
case (Zeven p) ; [ unfold new_location_even | unfold new_location_odd ] ; now case Zeven.
( case Zeq_bool_spec ; [ easy | intros H ; now elim H ] ). now eexists.
(* ... no shift *) destruct H as (e', H).
rewrite H.
split. split.
now constructor. constructor.
apply sym_eq.
apply F2R_0.
right. right.
repeat split. repeat split.
rewrite <- Hx.
apply generic_format_0. apply generic_format_0.
(* .. inexact location *) (* . *)
elim Rlt_not_le with (1 := proj1 H1). intros l' (H, _) _.
rewrite <- Hx. rewrite F2R_0 in H.
now apply F2R_ge_0_compat. elim Rlt_irrefl with (1 := H).
Qed. Qed.
Section round_dir. Section round_dir.
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment