Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
Menu
Open sidebar
Flocq
flocq
Commits
1d5a4239
Commit
1d5a4239
authored
Jun 30, 2015
by
BOLDO Sylvie
Browse files
New definitions for ulp, pred, succ. And all the corresponding modifications.
parent
713ce4fa
Changes
15
Expand all
Hide whitespace changes
Inline
Side-by-side
examples/Average.v
View file @
1d5a4239
This diff is collapsed.
Click to expand it.
examples/Double_round_beta_odd.v
View file @
1d5a4239
...
...
@@ -111,7 +111,7 @@ induction n.
*
change
0
with
(
Z2R
0
);
apply
Z2R_le
;
omega
.
*
now
apply
bpow_ge_0
.
+
rewrite
<-
Hlx
'
.
apply
(
ln_beta_
succ
beta
(
fun
e
=>
(
e
-
(
ln_beta
x
'
-
ex2
'
))
%
Z
));
apply
(
ln_beta_
plus_eps
beta
(
fun
e
=>
(
e
-
(
ln_beta
x
'
-
ex2
'
))
%
Z
));
[
|
|
split
].
*
exact
Px
'
.
*
unfold
generic_format
,
F2R
,
scaled_mantissa
,
canonic_exp
;
simpl
.
...
...
@@ -120,7 +120,8 @@ induction n.
now
apply
Rmult_le_pos
;
[
apply
Rlt_le
|
apply
bpow_ge_0
].
*
apply
Rmult_le_pos
;
[
|
now
apply
bpow_ge_0
].
change
0
with
(
Z2R
0
);
apply
Z2R_le
;
omega
.
*
unfold
u
,
ulp
,
ex2
'
,
canonic_exp
;
bpow_simplify
.
*
rewrite
ulp_neq_0
;[
idtac
|
now
apply
Rgt_not_eq
].
unfold
u
,
ex2
'
,
canonic_exp
;
bpow_simplify
.
rewrite
Zplus_comm
;
rewrite
bpow_plus
.
apply
Rmult_lt_compat_r
;
[
now
apply
bpow_gt_0
|
].
rewrite
bpow_1
.
...
...
@@ -203,6 +204,8 @@ Lemma neq_midpoint_beta_odd_aux1 :
double_round_eq
beta
fexp1
fexp2
choice1
choice2
x
.
Proof
.
intros
fexp1
fexp2
Vfexp1
Vfexp2
choice1
choice2
x
Px
Hf2f1
Hx
.
unfold
midp
in
Hx
.
rewrite
2
!
ulp_neq_0
in
Hx
;
try
now
apply
Rgt_not_eq
.
unfold
double_round_eq
.
set
(
ex1
:=
fexp1
(
ln_beta
x
)).
set
(
ex2
:=
fexp2
(
ln_beta
x
)).
...
...
@@ -246,8 +249,7 @@ assert (Hrx2' : rx1 <= rx2 < rx1 + / 2 * bpow ex1).
apply
Rplus_le_compat_l
.
apply
Rmult_le_compat_l
;
[
lra
|
].
now
apply
bpow_le
.
-
change
(
_
+
_
)
with
(
midp
beta
fexp1
x
).
apply
(
Rle_lt_trans
_
_
_
(
proj1
Hx
'
)
(
proj2
Hx
)).
}
-
apply
(
Rle_lt_trans
_
_
_
(
proj1
Hx
'
)
(
proj2
Hx
)).
}
assert
(
Hrx2r
:
rx2
=
round
beta
fexp2
Zfloor
x
).
{
unfold
round
,
F2R
,
scaled_mantissa
,
canonic_exp
;
simpl
.
fold
ex2
;
rewrite
Hrx2
.
...
...
@@ -317,6 +319,8 @@ Lemma neq_midpoint_beta_odd_aux2 :
double_round_eq
beta
fexp1
fexp2
choice1
choice2
x
.
Proof
.
intros
fexp1
fexp2
Vfexp1
Vfexp2
choice1
choice2
x
Px
Hf2f1
Hx
.
unfold
midp
in
Hx
.
rewrite
2
!
ulp_neq_0
in
Hx
;
try
now
apply
Rgt_not_eq
.
unfold
double_round_eq
.
set
(
ex1
:=
fexp1
(
ln_beta
x
)).
set
(
ex2
:=
fexp2
(
ln_beta
x
)).
...
...
@@ -341,11 +345,12 @@ assert (NF1x : ~ generic_format beta fexp1 x).
{
now
intro
H
;
apply
NF2x
,
(
generic_inclusion_ln_beta
_
fexp1
).
}
assert
(
Hrx1c
:
rx1c
=
rx1
+
ulp
beta
fexp1
x
).
{
now
apply
ulp_DN_UP
.
}
rewrite
ulp_neq_0
in
Hrx1c
;
try
now
apply
Rgt_not_eq
.
destruct
(
midpoint_beta_odd_remains
rx1
Nnrx1
ex1
ex2
Hf2f1
'
Hrx1
)
as
(
rx2
,(
Nnrx2
,
(
Hrx2
,
Hrx12
))).
set
(
rx2c
:=
rx2
+
ulp
beta
fexp2
x
).
set
(
rx2c
:=
rx2
+
bpow
(
fexp2
(
ln_beta
x
))
).
assert
(
Hx
'
:
rx2c
-
/
2
*
bpow
ex2
<
x
<=
rx2c
).
{
unfold
rx2c
,
ulp
,
canonic_exp
;
fold
ex1
;
fold
ex2
;
split
.
{
unfold
rx2c
,
canonic_exp
;
fold
ex1
;
fold
ex2
;
split
.
-
replace
(
_
-
_
)
with
(
rx2
+
/
2
*
bpow
ex2
)
by
field
.
rewrite
<-
Hrx12
;
apply
Hx
.
-
replace
(
_
+
_
)
with
(
rx2
+
/
2
*
bpow
ex2
+
/
2
*
bpow
ex2
)
by
field
.
...
...
@@ -379,7 +384,6 @@ assert (Hrx2' : rx1c - / 2 * bpow ex1 < rx2c <= rx1c).
{
split
.
-
rewrite
Hrx1c
;
unfold
ulp
,
canonic_exp
;
fold
ex1
.
replace
(
_
-
_
)
with
(
rx1
+
/
2
*
bpow
ex1
)
by
field
.
change
(
_
+
_
)
with
(
midp
beta
fexp1
x
).
apply
(
Rlt_le_trans
_
_
_
(
proj1
Hx
)
(
proj2
Hx
'
)).
-
apply
(
Rplus_le_reg_r
(
-
/
2
*
bpow
ex2
)).
unfold
rx2c
,
ulp
,
canonic_exp
;
fold
ex2
.
...
...
@@ -471,7 +475,6 @@ assert (Hl2 : ln_beta rx2c = ln_beta x :> Z).
replace
(
_
+
_
)
with
(
rx2
+
bpow
ex2
)
by
field
].
split
.
-
rewrite
<-
Rplus_assoc
.
change
(
_
+
_
)
with
(
midp
beta
fexp1
x
+
/
2
*
ulp
beta
fexp2
x
).
apply
Rle_trans
with
x
;
[
|
now
apply
Hx
].
apply
Rge_le
;
rewrite
<-
(
Rabs_right
x
)
at
1
;
[
|
now
apply
Rle_ge
,
Rlt_le
];
apply
Rle_ge
;
destruct
(
ln_beta
x
)
as
(
ex
,
Hex
);
simpl
;
apply
Hex
.
...
...
@@ -481,7 +484,9 @@ assert (Hl2 : ln_beta rx2c = ln_beta x :> Z).
rewrite
<-
(
Rmult_1_l
(
bpow
ex1
))
at
2.
replace
(
1
*
bpow
ex1
)
with
(
/
2
*
bpow
ex1
+
/
2
*
bpow
ex1
)
by
field
.
now
apply
Rplus_lt_compat_l
,
Rmult_lt_compat_l
;
[
lra
|
apply
bpow_lt
].
+
unfold
ex1
;
rewrite
<-
Hl1
;
apply
succ_le_bpow
;
[
exact
Prx1
|
|
].
+
unfold
ex1
;
rewrite
<-
Hl1
.
fold
(
canonic_exp
beta
fexp1
rx1
);
rewrite
<-
ulp_neq_0
;
try
now
apply
Rgt_not_eq
.
apply
succ_le_bpow
;
[
exact
Prx1
|
|
].
*
now
apply
generic_format_round
;
[
|
apply
valid_rnd_DN
].
*
destruct
(
ln_beta
rx1
)
as
(
erx1
,
Herx1
);
simpl
.
rewrite
<-
(
Rabs_right
rx1
)
at
1
;
[
|
now
apply
Rle_ge
,
Rlt_le
].
...
...
@@ -505,7 +510,7 @@ apply Rabs_lt; split.
-
apply
(
Rmult_lt_reg_r
(
bpow
ex1
));
[
now
apply
bpow_gt_0
|
].
rewrite
Rmult_minus_distr_r
;
bpow_simplify
.
rewrite
Z2R_plus
,
Rmult_plus_distr_r
;
simpl
;
rewrite
Rmult_1_l
.
change
(
Z2R
_
*
_
+
_
)
with
(
rx1
+
ul
p
beta
fexp1
x
).
change
(
Z2R
_
*
_
+
_
)
with
(
rx1
+
bpow
(
canonic_ex
p
beta
fexp1
x
)
)
.
rewrite
<-
Hrx1c
;
lra
.
Qed
.
...
...
@@ -592,6 +597,7 @@ destruct (Zle_or_lt (fexp1 ex) (fexp2 ex)) as [H2|H2].
(
*
r2
<>
0
*
)
assert
(
B1
:
Rabs
(
r2
-
x
)
<=
/
2
*
ulp
beta
fexp2
x
);
[
now
apply
ulp_half_error
|
].
rewrite
ulp_neq_0
in
B1
;
try
now
apply
Rgt_not_eq
.
unfold
round
,
F2R
,
scaled_mantissa
,
canonic_exp
;
simpl
.
apply
(
Rmult_eq_reg_r
(
bpow
(
-
fexp1
(
ln_beta
r2
))));
[
|
now
apply
Rgt_not_eq
,
bpow_gt_0
].
...
...
@@ -603,7 +609,7 @@ destruct (Zle_or_lt (fexp1 ex) (fexp2 ex)) as [H2|H2].
bpow_simplify
.
replace
r2
with
(
r2
-
x
+
x
)
by
ring
.
apply
(
Rle_lt_trans
_
_
_
(
Rabs_triang
_
_
)).
apply
Rlt_le_trans
with
(
/
2
*
ul
p
beta
fexp2
x
+
bpow
ex
);
apply
Rlt_le_trans
with
(
/
2
*
bpow
(
canonic_ex
p
beta
fexp2
x
)
+
bpow
ex
);
[
now
apply
Rplus_le_lt_compat
;
[
|
rewrite
Rabs_right
;
[
|
apply
Rle_ge
,
Rlt_le
]]
|
].
replace
(
_
-
_
+
_
)
with
r2
by
ring
.
...
...
@@ -617,14 +623,14 @@ destruct (Zle_or_lt (fexp1 ex) (fexp2 ex)) as [H2|H2].
{
apply
(
ln_beta_le_bpow
_
_
_
Nzr2
).
replace
r2
with
(
r2
-
x
+
x
)
by
ring
.
apply
(
Rle_lt_trans
_
_
_
(
Rabs_triang
_
_
)).
apply
Rlt_le_trans
with
(
/
2
*
ul
p
beta
fexp2
x
+
bpow
ex
);
apply
Rlt_le_trans
with
(
/
2
*
bpow
(
canonic_ex
p
beta
fexp2
x
)
+
bpow
ex
);
[
now
apply
Rplus_le_lt_compat
;
[
|
rewrite
Rabs_right
;
[
|
apply
Rle_ge
,
Rlt_le
]]
|
].
apply
Rle_trans
with
(
2
*
bpow
(
fexp1
ex
-
1
)).
-
rewrite
Rmult_plus_distr_r
,
Rmult_1_l
.
apply
Rplus_le_compat
;
[
|
now
apply
bpow_le
;
omega
].
apply
Rle_trans
with
(
bpow
(
fexp2
ex
));
[
|
now
apply
bpow_le
;
omega
].
rewrite
<-
(
Rmult_1_l
(
bpow
_
));
unfold
ulp
,
canonic_exp
.
rewrite
<-
(
Rmult_1_l
(
bpow
(
fexp2
_
)
));
unfold
canonic_exp
.
rewrite
Hex
'
;
apply
Rmult_le_compat_r
;
[
apply
bpow_ge_0
|
lra
].
-
rewrite
<-
(
Rmult_1_l
(
bpow
(
fexp1
_
))).
unfold
Zminus
;
rewrite
Zplus_comm
,
bpow_plus
,
<-
Rmult_assoc
.
...
...
@@ -657,14 +663,16 @@ destruct (Zle_or_lt (fexp1 ex) (fexp2 ex)) as [H2|H2].
now
rewrite
Hbeta
'
.
Qed
.
(
*
argh
:
was
0
<=
Z2R
mx
.
This
becomes
incorrect
in
FLX
with
the
new
ulp
.
*
)
Lemma
float_neq_midpoint_beta_odd
:
forall
(
mx
ex
:
Z
),
forall
(
fexp
:
Z
->
Z
),
0
<
=
Z2R
mx
->
0
<
Z2R
mx
->
Z2R
mx
*
bpow
ex
<>
midp
beta
fexp
(
Z2R
mx
*
bpow
ex
).
Proof
.
intros
mx
ex
fexp
Hmx
.
unfold
midp
,
round
,
ulp
,
F2R
,
scaled_mantissa
,
canonic_exp
;
simpl
.
unfold
midp
;
rewrite
ulp_neq_0
.
unfold
round
,
F2R
,
scaled_mantissa
,
canonic_exp
;
simpl
.
set
(
exf
:=
fexp
(
ln_beta
(
Z2R
mx
*
bpow
ex
))).
set
(
mxf
:=
Zfloor
(
Z2R
mx
*
bpow
ex
*
bpow
(
-
exf
))).
destruct
(
Zle_or_lt
exf
ex
)
as
[
Hm
|
Hm
].
...
...
@@ -695,7 +703,7 @@ destruct (Zle_or_lt exf ex) as [Hm|Hm].
change
0
with
(
Z2R
0
);
apply
Z2R_le
;
unfold
mxf
.
apply
Zfloor_lub
;
simpl
.
apply
Rmult_le_pos
;
[
|
now
apply
bpow_ge_0
].
now
apply
Rmult_le_pos
;
[
|
apply
bpow_ge_0
].
}
now
apply
Rmult_le_pos
;
[
now
left
|
apply
bpow_ge_0
].
}
destruct
(
midpoint_beta_odd_remains
_
Nnmxy
_
_
Hm
'
)
as
(
x
'
,(
_
,(
Hx
'
,
Hxx
'
))).
{
now
bpow_simplify
;
rewrite
Zfloor_Z2R
.
}
...
...
@@ -718,6 +726,9 @@ destruct (Zle_or_lt exf ex) as [Hm|Hm].
apply
(
Zodd_not_Zeven
1
);
[
now
simpl
|
].
rewrite
<-
H
.
now
apply
Zeven_mult_Zeven_l
.
-
apply
Rmult_integral_contrapositive_currified
.
now
apply
Rgt_not_eq
,
Rlt_gt
.
apply
Rgt_not_eq
,
bpow_gt_0
.
Qed
.
Section
Double_round_mult_beta_odd
.
...
...
@@ -750,14 +761,14 @@ apply neq_midpoint_beta_odd; try assumption.
with
(
Z2R
mx
*
Z2R
my
*
bpow
(
fexp1
ex
)
*
bpow
(
fexp1
ey
))
by
ring
.
rewrite
<-
Z2R_mult
,
Rmult_assoc
,
<-
bpow_plus
.
apply
float_neq_midpoint_beta_odd
.
apply
(
Rmult_l
e
_reg_r
(
bpow
(
fexp1
ex
)));
[
now
apply
bpow_gt_0
|
].
apply
(
Rmult_l
e
_reg_r
(
bpow
(
fexp1
ey
)));
[
now
apply
bpow_gt_0
|
].
apply
(
Rmult_l
t
_reg_r
(
bpow
(
fexp1
ex
)));
[
now
apply
bpow_gt_0
|
].
apply
(
Rmult_l
t
_reg_r
(
bpow
(
fexp1
ey
)));
[
now
apply
bpow_gt_0
|
].
do
2
rewrite
Rmult_0_l
.
rewrite
Z2R_mult
;
replace
(
_
*
_
)
with
(
Z2R
mx
*
bpow
(
fexp1
ex
)
*
(
Z2R
my
*
bpow
(
fexp1
ey
)))
by
ring
.
rewrite
<-
Fx
,
<-
Fy
.
now
apply
Rmult_l
e_pos
;
apply
Rlt_le
.
now
apply
Rmult_l
t_0_compat
.
Qed
.
Lemma
double_round_mult_beta_odd_aux2
:
...
...
@@ -951,21 +962,21 @@ apply neq_midpoint_beta_odd; try assumption.
rewrite
<-
Z2R_Zpower
;
[
|
now
apply
Zle_minus_le_0
].
rewrite
<-
Z2R_mult
,
<-
Z2R_plus
.
apply
float_neq_midpoint_beta_odd
.
apply
(
Rmult_l
e
_reg_r
(
bpow
(
fexp1
ex
)));
[
now
apply
bpow_gt_0
|
].
apply
(
Rmult_l
t
_reg_r
(
bpow
(
fexp1
ex
)));
[
now
apply
bpow_gt_0
|
].
rewrite
Z2R_plus
,
Z2R_mult
,
Z2R_Zpower
;
[
|
now
apply
Zle_minus_le_0
].
rewrite
Rmult_0_l
,
Rmult_plus_distr_r
;
bpow_simplify
.
rewrite
<-
Fx
,
<-
Fy
.
now
apply
Rplus_l
e_le
_0_compat
;
apply
Rlt_le
.
now
apply
Rplus_l
t
_0_compat
.
+
replace
(
fexp1
ex
)
with
(
fexp1
ex
-
fexp1
ey
+
fexp1
ey
)
%
Z
by
ring
.
rewrite
bpow_plus
,
<-
Rmult_assoc
,
<-
Rmult_plus_distr_r
.
rewrite
<-
Z2R_Zpower
;
[
|
omega
].
rewrite
<-
Z2R_mult
,
<-
Z2R_plus
.
apply
float_neq_midpoint_beta_odd
.
apply
(
Rmult_l
e
_reg_r
(
bpow
(
fexp1
ey
)));
[
now
apply
bpow_gt_0
|
].
apply
(
Rmult_l
t
_reg_r
(
bpow
(
fexp1
ey
)));
[
now
apply
bpow_gt_0
|
].
rewrite
Z2R_plus
,
Z2R_mult
,
Z2R_Zpower
;
[
|
omega
].
rewrite
Rmult_0_l
,
Rmult_plus_distr_r
;
bpow_simplify
.
rewrite
<-
Fx
,
<-
Fy
.
now
apply
Rplus_l
e_le
_0_compat
;
apply
Rlt_le
.
now
apply
Rplus_l
t
_0_compat
.
Qed
.
Lemma
double_round_plus_beta_odd_aux2
:
...
...
@@ -989,18 +1000,22 @@ destruct (Req_dec x 0) as [Zx|Nzx]; destruct (Req_dec y 0) as [Zy|Nzy].
apply
(
neq_midpoint_beta_odd
_
_
Vfexp1
Vfexp2
_
_
_
Py
(
Hfexp
_
)).
rewrite
Fy
;
unfold
F2R
,
scaled_mantissa
;
simpl
.
apply
float_neq_midpoint_beta_odd
.
change
0
with
(
Z2R
0
);
apply
Z2R_le
.
rewrite
<-
(
Ztrunc_Z2R
0
);
apply
Ztrunc_le
;
simpl
.
now
apply
Rmult_le_pos
;
[
apply
Rlt_le
|
apply
bpow_ge_0
].
apply
Rmult_lt_reg_r
with
(
bpow
(
canonic_exp
beta
fexp1
y
)).
apply
bpow_gt_0
.
rewrite
Rmult_0_l
.
apply
Rlt_le_trans
with
(
1
:=
Py
).
right
;
rewrite
Fy
at
1
;
unfold
F2R
,
scaled_mantissa
;
now
simpl
.
-
(
*
0
<
x
,
y
=
0
*
)
assert
(
Px
:
0
<
x
);
[
lra
|
].
rewrite
Zy
,
Rplus_0_r
.
apply
(
neq_midpoint_beta_odd
_
_
Vfexp1
Vfexp2
_
_
_
Px
(
Hfexp
_
)).
rewrite
Fx
;
unfold
F2R
,
scaled_mantissa
;
simpl
.
apply
float_neq_midpoint_beta_odd
.
change
0
with
(
Z2R
0
);
apply
Z2R_le
.
rewrite
<-
(
Ztrunc_Z2R
0
);
apply
Ztrunc_le
;
simpl
.
now
apply
Rmult_le_pos
;
[
apply
Rlt_le
|
apply
bpow_ge_0
].
apply
Rmult_lt_reg_r
with
(
bpow
(
canonic_exp
beta
fexp1
x
)).
apply
bpow_gt_0
.
rewrite
Rmult_0_l
.
apply
Rlt_le_trans
with
(
1
:=
Px
).
right
;
rewrite
Fx
at
1
;
unfold
F2R
,
scaled_mantissa
;
now
simpl
.
-
(
*
0
<
x
,
0
<
y
*
)
assert
(
Px
:
0
<
x
);
[
lra
|
].
assert
(
Py
:
0
<
y
);
[
lra
|
].
...
...
@@ -1037,21 +1052,21 @@ apply neq_midpoint_beta_odd; try assumption.
rewrite
<-
Z2R_Zpower
;
[
|
now
apply
Zle_minus_le_0
].
rewrite
<-
Z2R_mult
,
<-
Z2R_minus
.
apply
float_neq_midpoint_beta_odd
.
apply
(
Rmult_l
e
_reg_r
(
bpow
(
fexp1
ex
)));
[
now
apply
bpow_gt_0
|
].
apply
(
Rmult_l
t
_reg_r
(
bpow
(
fexp1
ex
)));
[
now
apply
bpow_gt_0
|
].
rewrite
Z2R_minus
,
Z2R_mult
,
Z2R_Zpower
;
[
|
now
apply
Zle_minus_le_0
].
rewrite
Rmult_0_l
,
Rmult_minus_distr_r
;
bpow_simplify
.
rewrite
<-
Fx
,
<-
Fy
.
now
apply
Rl
e_0_
minus
,
Rlt_le
.
now
apply
Rl
t_R
minus
.
+
replace
(
fexp1
ex
)
with
(
fexp1
ex
-
fexp1
ey
+
fexp1
ey
)
%
Z
by
ring
.
rewrite
bpow_plus
,
<-
Rmult_assoc
,
<-
Rmult_minus_distr_r
.
rewrite
<-
Z2R_Zpower
;
[
|
omega
].
rewrite
<-
Z2R_mult
,
<-
Z2R_minus
.
apply
float_neq_midpoint_beta_odd
.
apply
(
Rmult_l
e
_reg_r
(
bpow
(
fexp1
ey
)));
[
now
apply
bpow_gt_0
|
].
apply
(
Rmult_l
t
_reg_r
(
bpow
(
fexp1
ey
)));
[
now
apply
bpow_gt_0
|
].
rewrite
Z2R_minus
,
Z2R_mult
,
Z2R_Zpower
;
[
|
omega
].
rewrite
Rmult_0_l
,
Rmult_minus_distr_r
;
bpow_simplify
.
rewrite
<-
Fx
,
<-
Fy
.
now
apply
Rl
e_0_
minus
,
Rlt_le
.
now
apply
Rl
t_R
minus
.
Qed
.
Lemma
double_round_minus_beta_odd_aux2
:
...
...
@@ -1077,18 +1092,20 @@ destruct (Req_dec x 0) as [Zx|Nzx]; destruct (Req_dec y 0) as [Zy|Nzy].
apply
(
neq_midpoint_beta_odd
_
_
Vfexp1
Vfexp2
_
_
_
Py
(
Hfexp
_
)).
rewrite
Fy
;
unfold
F2R
,
scaled_mantissa
;
simpl
.
apply
float_neq_midpoint_beta_odd
.
change
0
with
(
Z2R
0
);
apply
Z2R_le
.
rewrite
<-
(
Ztrunc_Z2R
0
);
apply
Ztrunc_le
;
simpl
.
now
apply
Rmult_le_pos
;
[
apply
Rlt_le
|
apply
bpow_ge_0
].
apply
Rmult_lt_reg_r
with
(
bpow
(
canonic_exp
beta
fexp1
y
)).
apply
bpow_gt_0
.
rewrite
Rmult_0_l
;
apply
Rlt_le_trans
with
(
1
:=
Py
).
right
;
rewrite
Fy
at
1
;
unfold
F2R
,
scaled_mantissa
;
now
simpl
.
-
(
*
0
<
x
,
y
=
0
*
)
assert
(
Px
:
0
<
x
);
[
lra
|
].
unfold
Rminus
;
rewrite
Zy
,
Ropp_0
,
Rplus_0_r
.
apply
(
neq_midpoint_beta_odd
_
_
Vfexp1
Vfexp2
_
_
_
Px
(
Hfexp
_
)).
rewrite
Fx
;
unfold
F2R
,
scaled_mantissa
;
simpl
.
apply
float_neq_midpoint_beta_odd
.
change
0
with
(
Z2R
0
);
apply
Z2R_le
.
rewrite
<-
(
Ztrunc_Z2R
0
);
apply
Ztrunc_le
;
simpl
.
now
apply
Rmult_le_pos
;
[
apply
Rlt_le
|
apply
bpow_ge_0
].
apply
Rmult_lt_reg_r
with
(
bpow
(
canonic_exp
beta
fexp1
x
)).
apply
bpow_gt_0
.
rewrite
Rmult_0_l
;
apply
Rlt_le_trans
with
(
1
:=
Px
).
right
;
rewrite
Fx
at
1
;
unfold
F2R
,
scaled_mantissa
;
now
simpl
.
-
(
*
0
<
x
,
0
<
y
*
)
assert
(
Px
:
0
<
x
);
[
lra
|
].
assert
(
Py
:
0
<
y
);
[
lra
|
].
...
...
@@ -1305,14 +1322,15 @@ End Double_round_plus_beta_odd.
Section
Double_round_sqrt_beta_odd
.
(
*
argh
:
was
forall
x
,
but
0
may
be
a
midpoint
now
*
)
Lemma
sqrt_neq_midpoint
:
forall
fexp
:
Z
->
Z
,
Valid_exp
fexp
->
forall
x
,
forall
x
,
0
<
x
->
generic_format
beta
fexp
x
->
sqrt
x
<>
midp
beta
fexp
(
sqrt
x
).
Proof
.
intros
fexp
Vfexp
x
Fx
.
destruct
(
Rle_or_lt
x
0
)
as
[
Npx
|
Px
].
intros
fexp
Vfexp
x
Px
Fx
.
(
*
destruct
(
Rle_or_lt
x
0
)
as
[
Npx
|
Px
].
{
(
*
x
<=
0
*
)
rewrite
(
sqrt_neg
_
Npx
).
unfold
midp
;
rewrite
round_0
;
[
|
apply
valid_rnd_DN
];
rewrite
Rplus_0_l
.
...
...
@@ -1320,12 +1338,14 @@ destruct (Rle_or_lt x 0) as [Npx|Px].
apply
(
Rmult_eq_compat_l
2
)
in
H
;
field_simplify
in
H
.
unfold
Rdiv
in
H
;
rewrite
Rinv_1
in
H
;
do
2
rewrite
Rmult_1_r
in
H
.
apply
eq_sym
in
H
.
revert
H
;
apply
Rgt_not_eq
;
apply
bpow_gt_0
.
}
revert
H
;
apply
Rgt_not_eq
;
apply
bpow_gt_0
.
}
*
)
(
*
0
<
x
*
)
unfold
midp
.
set
(
r
:=
round
beta
fexp
Zfloor
(
sqrt
x
)).
revert
Fx
.
unfold
generic_format
,
round
,
ulp
,
F2R
,
scaled_mantissa
,
canonic_exp
;
simpl
.
rewrite
ulp_neq_0
.
2
:
now
apply
Rgt_not_eq
,
sqrt_lt_R0
.
unfold
generic_format
,
round
,
F2R
,
scaled_mantissa
,
canonic_exp
;
simpl
.
set
(
m
:=
Ztrunc
(
x
*
bpow
(
-
fexp
(
ln_beta
x
)))).
intro
Fx
.
assert
(
Nnr
:
0
<=
r
).
...
...
@@ -1633,8 +1653,9 @@ Lemma double_round_eq_mid_beta_odd_rna_aux1 :
Proof
.
intros
fexp1
fexp2
Vfexp1
Vfexp2
x
Px
Hf2
Hf1
.
unfold
midp
.
rewrite
ulp_neq_0
;
try
now
apply
Rgt_not_eq
.
set
(
rd
:=
round
beta
fexp1
Zfloor
x
).
set
(
u
:=
ulp
beta
fexp1
x
).
set
(
u
:=
bpow
(
fexp1
(
ln_beta
x
))
).
intro
Xmid
.
apply
(
Rplus_eq_compat_l
(
-
rd
))
in
Xmid
;
ring_simplify
in
Xmid
.
rewrite
Rplus_comm
in
Xmid
;
fold
(
x
-
rd
)
in
Xmid
.
...
...
@@ -1711,13 +1732,14 @@ destruct (Req_dec rd 0) as [Zrd|Nzrd].
omega
.
}
assert
(
Hl2
:
ln_beta
(
x2
+
/
2
*
bpow
(
fexp2
(
ln_beta
x
)))
=
ln_beta
x2
:>
Z
).
{
apply
(
ln_beta_
succ
beta
fexp2
);
[
|
|
split
].
{
apply
(
ln_beta_
plus_eps
beta
fexp2
);
[
|
|
split
].
-
exact
Hx2_0
.
-
unfold
generic_format
,
F2R
,
scaled_mantissa
,
canonic_exp
;
simpl
.
rewrite
Hx2_1
,
Hlx
''
,
Ztrunc_floor
;
[
exact
Hx2_2
|
].
now
apply
Rmult_le_pos
;
[
apply
Rlt_le
|
apply
bpow_ge_0
].
-
apply
Rmult_le_pos
;
[
lra
|
apply
bpow_ge_0
].
-
unfold
ulp
,
canonic_exp
;
rewrite
Hx2_1
;
rewrite
Hlx
''
.
-
rewrite
ulp_neq_0
;
try
now
apply
Rgt_not_eq
.
unfold
canonic_exp
;
rewrite
Hx2_1
;
rewrite
Hlx
''
.
rewrite
<-
Rmult_1_l
;
apply
Rmult_lt_compat_r
;
[
|
lra
].
apply
bpow_gt_0
.
}
unfold
round
at
2
,
F2R
,
scaled_mantissa
,
canonic_exp
;
simpl
.
...
...
@@ -1943,14 +1965,15 @@ destruct (Req_dec rd 0) as [Zrd|Nzrd].
{
rewrite
Hx2b2
.
rewrite
Hlr
;
rewrite
Xmid
'
.
rewrite
Rplus_assoc
.
apply
(
ln_beta_
succ
beta
fexp1
rd
Prd
);
[
|
split
].
apply
(
ln_beta_
plus_eps
beta
fexp1
rd
Prd
);
[
|
split
].
-
apply
generic_format_round
;
[
exact
Vfexp1
|
apply
valid_rnd_DN
].
-
apply
Rplus_le_le_0_compat
;
(
apply
Rmult_le_pos
;
[
lra
|
apply
bpow_ge_0
]).
-
rewrite
<-
Rmult_plus_distr_l
.
apply
(
Rmult_lt_reg_l
2
);
[
lra
|
].
rewrite
<-
Rmult_assoc
;
replace
(
2
*
/
2
)
with
1
by
field
;
rewrite
Rmult_1_l
.
unfold
ulp
,
canonic_exp
;
rewrite
<-
Hlr
;
change
(
bpow
(
fexp1
_
))
with
u
.
rewrite
ulp_neq_0
;
trivial
.
unfold
canonic_exp
;
rewrite
<-
Hlr
;
change
(
bpow
(
fexp1
_
))
with
u
.
rewrite
Rmult_plus_distr_r
;
rewrite
Rmult_1_l
.
apply
Rplus_lt_compat_l
;
unfold
u
,
ulp
,
canonic_exp
,
f2
;
apply
bpow_lt
.
omega
.
}
...
...
@@ -2130,7 +2153,9 @@ destruct (Zle_or_lt (fexp1 ex) (fexp2 ex)) as [H2|H2].
-
rewrite
Rmult_plus_distr_r
,
Rmult_1_l
.
apply
Rplus_le_compat
;
[
|
now
apply
bpow_le
;
omega
].
apply
Rle_trans
with
(
bpow
(
fexp2
ex
));
[
|
now
apply
bpow_le
;
omega
].
rewrite
<-
(
Rmult_1_l
(
bpow
_
));
unfold
ulp
,
canonic_exp
.
rewrite
<-
(
Rmult_1_l
(
bpow
_
)).
rewrite
ulp_neq_0
;
try
now
apply
Rgt_not_eq
.
unfold
canonic_exp
.
rewrite
Hex
'
;
apply
Rmult_le_compat_r
;
[
apply
bpow_ge_0
|
lra
].
-
rewrite
<-
(
Rmult_1_l
(
bpow
(
fexp1
_
))).
unfold
Zminus
;
rewrite
Zplus_comm
,
bpow_plus
,
<-
Rmult_assoc
.
...
...
@@ -2146,7 +2171,8 @@ destruct (Zle_or_lt (fexp1 ex) (fexp2 ex)) as [H2|H2].
rewrite
<-
Rmult_plus_distr_l
;
apply
Rmult_le_compat_l
;
[
lra
|
].
apply
Rle_trans
with
(
3
*
bpow
(
fexp1
ex
-
1
)).
+
rewrite
(
Rmult_plus_distr_r
_
2
);
rewrite
Rmult_1_l
;
apply
Rplus_le_compat
.
*
apply
bpow_le
;
unfold
canonic_exp
;
rewrite
Hex
'
;
omega
.
*
rewrite
ulp_neq_0
;
try
now
apply
Rgt_not_eq
.
apply
bpow_le
;
unfold
canonic_exp
;
rewrite
Hex
'
;
omega
.
*
apply
Rmult_le_compat_l
;
[
lra
|
];
apply
bpow_le
;
omega
.
+
rewrite
<-
(
Rmult_1_l
(
bpow
(
fexp1
_
))).
unfold
Zminus
;
rewrite
Zplus_comm
,
bpow_plus
,
<-
Rmult_assoc
.
...
...
examples/Sqrt_sqr.v
View file @
1d5a4239
...
...
@@ -30,143 +30,6 @@ Hypothesis Fx: format x.
Let
y
:=
round_flx1
(
x
*
x
).
Let
z
:=
round_flx2
(
sqrt
y
).
Theorem
round_le_half_an_ulp
:
forall
choice
,
forall
u
v
,
format
u
->
0
<
u
->
v
<
u
+
(
ulp_flx
u
)
/
2
->
round
beta
(
FLX_exp
prec
)
(
Znearest
choice
)
v
<=
u
.
Proof
with
auto
with
typeclass_instances
.
intros
choice
u
v
Fu
Hu
H
.
(
*
.
*
)
assert
(
0
<
ulp_flx
u
/
2
).
unfold
Rdiv
;
apply
Rmult_lt_0_compat
.
unfold
ulp
;
apply
bpow_gt_0
.
auto
with
real
.
(
*
.
*
)
assert
(
ulp_flx
u
/
2
<
ulp_flx
u
).
apply
Rlt_le_trans
with
(
ulp_flx
u
*
1
);[
idtac
|
right
;
ring
].
unfold
Rdiv
;
apply
Rmult_lt_compat_l
.
apply
bpow_gt_0
.
apply
Rmult_lt_reg_l
with
2.
auto
with
real
.
apply
Rle_lt_trans
with
1
%
R
.
right
;
field
.
rewrite
Rmult_1_r
;
auto
with
real
.
(
*
*
)
apply
Rnd_N_pt_monotone
with
format
v
(
u
+
ulp_flx
u
/
2
)...
apply
round_N_pt
...
apply
Rnd_DN_pt_N
with
(
u
+
ulp_flx
u
).
pattern
u
at
3
;
replace
u
with
(
round
beta
(
FLX_exp
prec
)
Zfloor
(
u
+
ulp_flx
u
/
2
)).
apply
round_DN_pt
...
apply
round_DN_succ
;
try
assumption
.
split
;
try
left
;
assumption
.
replace
(
u
+
ulp_flx
u
)
with
(
round
beta
(
FLX_exp
prec
)
Zceil
(
u
+
ulp_flx
u
/
2
)).
apply
round_UP_pt
...
apply
round_UP_succ
;
try
assumption
...
split
;
try
left
;
assumption
.
right
;
field
.
Qed
.
Theorem
round_ge_half_an_ulp
:
forall
choice
,
forall
u
v
,
format
u
->
0
<
u
->
u
<>
bpow
(
ln_beta
beta
u
-
1
)
->
u
-
(
ulp_flx
u
)
/
2
<
v
->
u
<=
round
beta
(
FLX_exp
prec
)
(
Znearest
choice
)
v
.
Proof
with
auto
with
typeclass_instances
.
intros
choice
u
v
Fu
Hupos
Hu
H
.
(
*
*
)
assert
(
Hu2
:
(
ulp_flx
(
pred_flx
u
)
=
ulp_flx
u
)).
unfold
pred
;
case
Req_bool_spec
.
intros
V
;
contradict
Hu
;
auto
.
unfold
ulp
,
canonic_exp
,
FLX_exp
.
destruct
ln_beta
as
(
e
,
He
);
simpl
.
intros
Hu2
.
apply
f_equal
;
apply
f_equal2
;
auto
.
apply
ln_beta_unique
.
rewrite
Rabs_right
.
split
.
(
*
.
*
)
assert
(
bpow
(
e
-
prec
)
=
ulp_flx
u
).
unfold
ulp
,
canonic_exp
,
FLX_exp
.
apply
f_equal
,
f_equal2
;
auto
.
apply
sym_eq
,
ln_beta_unique
,
He
;
auto
with
real
.
rewrite
H0
.
apply
pred_ge_bpow
.
assumption
.
apply
Rgt_not_eq
,
Rlt_gt
.
rewrite
<-
H0
.
apply
Rlt_le_trans
with
(
bpow
(
e
-
1
)).
apply
bpow_lt
;
auto
with
zarith
.
rewrite
<-
(
Rabs_right
u
).
apply
He
;
auto
with
real
.
apply
Rle_ge
;
auto
with
real
.
assert
(
bpow
(
e
-
1
)
<=
u
).
rewrite
<-
(
Rabs_right
u
).
apply
He
;
auto
with
real
.
apply
Rle_ge
;
auto
with
real
.
case
H1
;
auto
.
intros
V
;
contradict
Hu2
;
auto
with
real
.
(
*
.
*
)
apply
Rle_lt_trans
with
u
.
apply
Rplus_le_reg_l
with
(
-
u
).
ring_simplify
.
apply
Rle_trans
with
(
-
0
);[
apply
Ropp_le_contravar
|
right
;
ring
].
apply
bpow_ge_0
.
rewrite
<-
(
Rabs_right
u
).
apply
He
;
auto
with
real
.
apply
Rle_ge
;
auto
with
real
.
(
*
.
*
)
apply
Rle_ge
;
apply
Rplus_le_reg_l
with
(
bpow
(
e
-
prec
));
ring_simplify
.
apply
Rle_trans
with
(
bpow
(
e
-
1
)).
apply
bpow_le
;
auto
with
zarith
.
rewrite
<-
(
Rabs_right
u
).
apply
He
;
auto
with
real
.
apply
Rle_ge
;
auto
with
real
.
(
*
*
)
apply
Rnd_N_pt_monotone
with
format
(
u
-
ulp_flx
(
pred_flx
u
)
/
2
)
v
...
2
:
apply
round_N_pt
...
2
:
rewrite
Hu2
;
assumption
.
(
*
.
*
)
assert
(
0
<
pred_flx
u
).
unfold
pred
;
case
Req_bool_spec
.
intros
V
;
contradict
Hu
;
auto
.
intros
_
;
unfold
ulp
,
canonic_exp
,
FLX_exp
.
destruct
ln_beta
as
(
e
,
He
);
simpl
.
apply
Rplus_lt_reg_r
with
(
bpow
(
e
-
prec
));
ring_simplify
.
apply
Rlt_le_trans
with
(
bpow
(
e
-
1
)).
apply
bpow_lt
;
auto
with
zarith
.
rewrite
<-
(
Rabs_right
u
).
apply
He
;
auto
with
real
.
apply
Rle_ge
;
auto
with
real
.
(
*
.
*
)
assert
(
0
<
ulp_flx
(
pred_flx
u
)
/
2
).
unfold
Rdiv
;
apply
Rmult_lt_0_compat
.
unfold
ulp
;
apply
bpow_gt_0
.
auto
with
real
.
(
*
.
*
)
assert
(
ulp_flx
(
pred_flx
u
)
/
2
<=
ulp_flx
(
pred_flx
u
)).
apply
Rle_trans
with
(
ulp_flx
(
pred_flx
u
)
*
1
);[
idtac
|
right
;
ring
].
unfold
Rdiv
;
apply
Rmult_le_compat_l
.
apply
bpow_ge_0
.
apply
Rmult_le_reg_l
with
2.
auto
with
real
.
apply
Rle_trans
with
1
%
R
.
right
;
field
.
rewrite
Rmult_1_r
;
auto
with
real
.
(
*
*
)
apply
Rnd_UP_pt_N
with
(
pred_flx
u
).
(
*
.
*
)
pattern
(
pred_flx
u
)
at
2
;
replace
(
pred_flx
u
)
with
(
round
beta
(
FLX_exp
prec
)
Zfloor
(
u
-
ulp_flx
(
pred_flx
u
)
/
2
)).
apply
round_DN_pt
...
apply
round_DN_pred
;
try
assumption
...
pattern
u
at
3
;
replace
u
with
(
round
beta
(
FLX_exp
prec
)
Zceil
(
u
-
ulp_flx
(
pred_flx
u
)
/
2
)).
apply
round_UP_pt
...
replace
((
u
-
ulp_flx
(
pred_flx
u
)
/
2
))
with
(
pred_flx
u
+
ulp_flx
(
pred_flx
u
)
/
2
).
apply
round_UP_pred
;
try
assumption
...
pattern
u
at
3
;
rewrite
<-
pred_plus_ulp
with
beta
(
FLX_exp
prec
)
u
...
field
.
auto
with
real
.
pattern
u
at
4
;
rewrite
<-
pred_plus_ulp
with
beta
(
FLX_exp
prec
)
u
...
rewrite
Hu2
.
right
;
field
.
auto
with
real
.
Qed
.
Theorem
round_flx_sqr_sqrt_middle
:
x
=
sqrt
(
Z2R
beta
)
*
bpow
(
ln_beta
beta
x
-
1
)
->
z
=
x
.
Proof
with
auto
with
typeclass_instances
.
...
...
@@ -209,18 +72,19 @@ assert (0 <= 1 + ulp_flx (x * x) / 2 / (x * x)).
rewrite
<-
(
Rplus_0_l
0
).
apply
Rplus_le_compat
;
auto
with
real
.
unfold
Rdiv
;
apply
Rmult_le_pos
.
apply
Rmult_le_pos
;
auto
with
real
;
apply
bpow_ge_0
.
apply
Rmult_le_pos
;
auto
with
real
;
apply
ulp_pos
.
left
;
auto
with
real
.
assert
(
0
<=
1
+
ulp_flx
x
/
2
/
x
).
rewrite
<-
(
Rplus_0_l
0
).
apply
Rplus_le_compat
;
auto
with
real
.
unfold
Rdiv
;
apply
Rmult_le_pos
.
apply
Rmult_le_pos
;
auto
with
real
;
apply
bpow_ge_0
.
apply
Rmult_le_pos
;
auto
with
real
;
apply
ulp_pos
.
left
;
auto
with
real
.
(
*
*
)
apply
r
ou
nd_le_half
_an_ulp
;
try
assumption
.
apply
rnd
_N
_le_half
;
try
assumption
.
..
apply
Rlt_le_trans
with
(
x
*
(
1
+
ulp_flx
x
/
2
/
x
)).
2
:
right
;
field
;
auto
with
real
.
2
:
right
;
rewrite
succ_pos_eq
;
try
now
left
.
2
:
field
;
auto
with
real
.
apply
Rle_lt_trans
with
(
sqrt
((
x
*
x
)
*
(
1
+
ulp_flx
(
x
*
x
)
/
2
/
(
x
*
x
)))).
apply
sqrt_le_1_alt
.
apply
Rplus_le_reg_l
with
(
-
x
*
x
).
...
...
@@ -248,9 +112,12 @@ apply Rplus_le_compat_l.
apply
Rplus_le_reg_r
with
(
ulp_flx
x
*
ulp_flx
x
/
2
).
apply
Rle_trans
with
0
;[
right
;
ring
|
idtac
].
apply
Rle_trans
with
(
ulp_flx
x
*
ulp_flx
x
).
apply
Rmult_le_pos
;
apply
bpow_ge_0
.
apply
Rmult_le_pos
;
apply
ulp_pos
.
right
;
field
.
unfold
ulp
,
canonic_exp
,
FLX_exp
.
rewrite
2
!
ulp_neq_0
.
2
:
now
apply
Rgt_not_eq
.
2
:
now
apply
Rgt_not_eq
.
unfold
canonic_exp
,
FLX_exp
.
destruct
(
ln_beta
beta
x
)
as
(
e
,
He
).
simpl
.
assert
(
bpow
(
e
-
1
)
<=
x
<
bpow
e
).
...
...
@@ -361,7 +228,11 @@ apply Rmult_le_compat_l.
auto
with
real
.
apply
Rle_trans
with
(
2
*
bpow
(
e
-
1
)
+
ulp_flx
(
2
*
bpow
(
e
-
1
))).
apply
Rplus_le_compat_l
.
unfold
ulp
,
canonic_exp
,
FLX_exp
.