Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
F
flocq
Project overview
Project overview
Details
Activity
Releases
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Issues
1
Issues
1
List
Boards
Labels
Service Desk
Milestones
Merge Requests
1
Merge Requests
1
CI / CD
CI / CD
Pipelines
Jobs
Schedules
Operations
Operations
Incidents
Environments
Packages & Registries
Packages & Registries
Container Registry
Analytics
Analytics
CI / CD
Repository
Value Stream
Wiki
Wiki
Snippets
Snippets
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Create a new issue
Jobs
Commits
Issue Boards
Open sidebar
Flocq
flocq
Commits
a1b583ad
Commit
a1b583ad
authored
Mar 27, 2009
by
Guillaume Melquiond
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Simplified generic format.
parent
218d843c
Changes
2
Hide whitespace changes
Inline
Side-by-side
Showing
2 changed files
with
66 additions
and
87 deletions
+66
-87
src/Flocq_rnd_FIX.v
src/Flocq_rnd_FIX.v
+2
-11
src/Flocq_rnd_generic.v
src/Flocq_rnd_generic.v
+64
-76
No files found.
src/Flocq_rnd_FIX.v
View file @
a1b583ad
...
...
@@ -41,8 +41,7 @@ exists (Float beta 0 emin).
repeat
split
.
unfold
F2R
.
simpl
.
now
rewrite
Rmult_0_l
.
destruct
Hx2
as
[
Hx2
|
Hx2
].
now
elim
Hx3
.
specialize
(
Hx2
Hx3
).
exists
(
Float
beta
xm
emin
).
repeat
split
.
rewrite
Hx1
.
...
...
@@ -50,20 +49,12 @@ apply (f_equal (fun e => F2R (Float beta xm e))).
simpl
in
Hx2
.
unfold
fexp
in
Hx2
.
apply
Hx2
.
now
apply
Rabs_pos_lt
.
intros
((
xm
,
xe
),
(
Hx1
,
Hx2
)).
destruct
(
Req_dec
x
0
)
as
[
Hx3
|
Hx3
].
exists
(
Float
beta
0
0
).
split
.
unfold
F2R
.
simpl
.
now
rewrite
Rmult_0_l
.
now
left
.
exists
(
Float
beta
xm
(
fexp
xe
)).
split
.
unfold
fexp
.
now
rewrite
<-
Hx2
.
right
.
split
.
now
intros
Hx3
.
(
*
.
*
)
refine
(
Satisfies_any
_
_
_
rnd
_
).
now
apply
->
Heq
.
...
...
src/Flocq_rnd_generic.v
View file @
a1b583ad
...
...
@@ -19,8 +19,8 @@ Variable valid_fexp :
Definition
generic_format
(
x
:
R
)
:=
exists
f
:
float
beta
,
x
=
F2R
f
/
\
(
x
=
R0
\
/
forall
H
:
(
0
<
Rabs
x
)
%
R
,
Fexp
f
=
fexp
(
projT1
(
ln_beta
beta
_
H
))).
x
=
F2R
f
/
\
forall
(
H
:
x
<>
R0
),
Fexp
f
=
fexp
(
projT1
(
ln_beta
beta
_
(
Rabs_pos_lt
_
H
))).
Theorem
generic_format_satisfies_any
:
satisfies_any
generic_format
.
...
...
@@ -29,25 +29,28 @@ refine ((fun D => Satisfies_any _ _ _ (projT1 D) (projT2 D)) _).
(
*
symmetric
set
*
)
exists
(
Float
beta
0
0
).
split
.
unfold
F2R
.
unfold
F2R
.
simpl
.
now
rewrite
Rmult_0_l
.
now
left
.
intros
H
.
now
elim
H
.
intros
x
((
m
,
e
),(
H1
,
H2
)).
exists
(
Float
beta
(
-
m
)
e
).
split
.
rewrite
H1
.
unfold
F2R
.
simpl
.
unfold
F2R
.
simpl
.
now
rewrite
opp_Z2R
,
Ropp_mult_distr_l_reverse
.
destruct
H2
.
left
.
rewrite
H
.
now
rewrite
Ropp_0
.
right
.
rewrite
Rabs_Ropp
.
intros
H0
.
specialize
(
H
H0
).
now
rewrite
<-
H
.
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
.
...
...
@@ -113,7 +116,7 @@ apply False_ind.
omega
.
split
.
(
*
-
.
rounded
*
)
eexists
;
split
;
[
reflexivity
|
right
].
eexists
;
split
;
[
reflexivity
|
idtac
].
intros
He9
.
simpl
.
apply
f_equal
.
...
...
@@ -126,8 +129,7 @@ exact Hbl.
(
*
-
.
.
bounded
right
*
)
clear
Hbl
.
apply
Rle_lt_trans
with
(
2
:=
Hx2
).
unfold
F2R
.
simpl
.
unfold
F2R
.
simpl
.
pattern
x
at
2
;
replace
x
with
((
x
*
bpow
(
-
fexp
ex
)
%
Z
)
*
bpow
(
fexp
ex
))
%
R
.
generalize
(
x
*
bpow
(
-
fexp
ex
)
%
Z
)
%
R
.
clear
.
...
...
@@ -151,8 +153,7 @@ apply Rle_trans with (2 := Hbl).
apply
epow_ge_0
.
split
.
(
*
-
.
smaller
*
)
unfold
F2R
.
simpl
.
unfold
F2R
.
simpl
.
generalize
(
fexp
ex
).
clear
.
intros
e
.
...
...
@@ -176,11 +177,7 @@ 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
.
destruct
Hg2
as
[
Hg2
|
Hg2
].
rewrite
Hg2
in
Hg3
.
elim
(
Rlt_irrefl
_
Hg3
).
rewrite
(
Rabs_pos_eq
_
(
Rlt_le
_
_
Hg3
))
in
Hg2
.
specialize
(
Hg2
Hg3
).
specialize
(
Hg2
(
Rgt_not_eq
_
_
Hg3
)).
apply
Rnot_lt_le
.
intros
Hrg
.
assert
(
bpow
(
ex
-
1
)
%
Z
<=
g
<
bpow
ex
)
%
R
.
...
...
@@ -188,6 +185,7 @@ split.
apply
Rle_trans
with
(
1
:=
Hbl
).
now
apply
Rlt_le
.
now
apply
Rle_lt_trans
with
(
1
:=
Hgx
).
rewrite
<-
(
Rabs_pos_eq
g
(
Rlt_le
_
_
Hg3
))
in
H
.
rewrite
ln_beta_unique
with
(
1
:=
H
)
in
Hg2
.
simpl
in
Hg2
.
apply
Rlt_not_le
with
(
1
:=
Hrg
).
...
...
@@ -221,29 +219,28 @@ exists (Float beta Z0 (fexp ex)).
split
.
unfold
F2R
.
simpl
.
now
rewrite
Rmult_0_l
.
now
left
.
intros
H
.
now
elim
H
.
split
.
now
apply
Rlt_le
.
(
*
-
.
biggest
*
)
intros
g
((
gm
,
ge
),
(
Hg1
,
Hg2
))
Hgx
.
apply
Rnot_lt_le
.
intros
Hg3
.
destruct
Hg2
as
[
Hg2
|
Hg2
].
rewrite
Hg2
in
Hg3
.
elim
(
Rlt_irrefl
_
Hg3
).
rewrite
(
Rabs_pos_eq
_
(
Rlt_le
_
_
Hg3
))
in
Hg2
.
specialize
(
Hg2
Hg3
).
specialize
(
Hg2
(
Rgt_not_eq
_
_
Hg3
)).
destruct
(
ln_beta
beta
g
Hg3
)
as
(
ge
'
,
Hg4
).
simpl
in
Hg2
.
generalize
Hg4
.
intros
Hg5
.
rewrite
<-
(
Rabs_pos_eq
g
(
Rlt_le
_
_
Hg3
))
in
Hg5
.
rewrite
ln_beta_unique
with
(
1
:=
Hg5
)
in
Hg2
.
apply
(
Rlt_not_le
_
_
(
Rle_lt_trans
_
_
_
Hgx
Hx2
)).
apply
Rle_trans
with
(
bpow
ge
).
apply
->
epow_le
.
simpl
in
Hg2
.
rewrite
Hg2
.
rewrite
(
proj2
(
proj2
(
valid_fexp
ex
)
He1
)
ge
'
).
exact
He1
.
apply
Zle_trans
with
(
2
:=
He1
).
cut
(
ge
'
-
1
<
ex
)
%
Z
.
omega
.
cut
(
ge
'
-
1
<
ex
)
%
Z
.
omega
.
apply
<-
epow_lt
.
apply
Rle_lt_trans
with
(
2
:=
Hx2
).
apply
Rle_trans
with
(
2
:=
Hgx
).
...
...
@@ -282,7 +279,8 @@ exists (Float beta 0 0).
split
.
unfold
F2R
.
now
rewrite
Rmult_0_l
.
now
left
.
intros
H
.
now
elim
H
.
rewrite
<-
Hx
.
split
.
apply
Rle_refl
.
...
...
@@ -354,21 +352,20 @@ split.
destruct
(
Rle_lt_or_eq_dec
_
_
Hbl
)
as
[
Hbl2
|
Hbl2
].
(
*
-
.
.
not
a
radix
power
*
)
eexists
;
split
;
[
reflexivity
|
idtac
].
right
.
rewrite
Rabs_left
.
intros
Hr
.
simpl
.
apply
f_equal
.
apply
sym_eq
.
apply
ln_beta_unique
.
rewrite
Rabs_left
.
split
.
rewrite
<-
(
Ropp_involutive
(
bpow
(
ex
-
1
)
%
Z
))
.
apply
Ropp_le_contravar
.
apply
Ropp_le_cancel
.
rewrite
Ropp_involutive
.
apply
Rle_trans
with
(
1
:=
Hbr
).
rewrite
<-
(
Ropp_involutive
x
)
.
now
apply
Ropp_le_contravar
.
rewrite
<-
(
Ropp_involutive
(
bpow
ex
))
.
now
apply
Ropp_lt_contravar
.
apply
Ropp_le_cancel
.
now
rewrite
Ropp_involutive
.
apply
Ropp_lt_cancel
.
now
rewrite
Ropp_involutive
.
apply
Rle_lt_trans
with
(
1
:=
Hbr
).
exact
Hx
.
(
*
-
.
.
a
radix
power
*
)
...
...
@@ -389,13 +386,12 @@ cut (0 <= ex - fexp (ex + 1))%Z. 2: omega.
case
(
ex
-
fexp
(
ex
+
1
))
%
Z
;
trivial
.
intros
ep
H
.
now
elim
H
.
right
.
rewrite
Rabs_Ropp
.
rewrite
Rabs_right
.
intros
H9
.
intros
H
.
apply
f_equal
.
apply
sym_eq
.
apply
ln_beta_unique
.
rewrite
Rabs_Ropp
.
rewrite
Rabs_right
.
split
.
apply
->
epow_le
.
omega
.
...
...
@@ -411,14 +407,8 @@ apply Rnot_lt_le.
intros
Hg3
.
assert
(
Hg4
:
(
g
<
0
)
%
R
).
now
apply
Rle_lt_trans
with
(
1
:=
Hgx
).
destruct
Hg2
as
[
Hg2
|
Hg2
].
rewrite
Hg2
in
Hg4
.
elim
(
Rlt_irrefl
_
Hg4
).
rewrite
(
Rabs_left
_
Hg4
)
in
Hg2
.
assert
(
Hg5
:=
Ropp_0_gt_lt_contravar
_
Hg4
).
specialize
(
Hg2
Hg5
).
simpl
in
Hg2
.
destruct
(
ln_beta
beta
(
-
g
)
Hg5
)
as
(
ge
'
,
Hge
).
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
).
simpl
in
Hg2
.
apply
Rlt_not_le
with
(
1
:=
Hg3
).
rewrite
Hg1
.
...
...
@@ -428,16 +418,17 @@ assert (Hge' : ge' = ex).
apply
epow_unique
with
(
1
:=
Hge
).
split
.
apply
Rle_trans
with
(
1
:=
Hx1
).
rewrite
Rabs_left
with
(
1
:=
Hg4
).
now
apply
Ropp_le_contravar
.
apply
Ropp_lt_cancel
.
apply
Rle_lt_trans
with
(
1
:=
Hbl
).
now
rewrite
Ropp_involutive
.
rewrite
Rabs_left
with
(
1
:=
Hg4
).
rewrite
Ropp_involutive
.
now
apply
Rle_lt_trans
with
(
1
:=
Hbl
).
rewrite
Hge
'
.
apply
Rmult_le_compat_r
.
apply
epow_ge_0
.
apply
Z2R_le
.
cut
(
gm
<
up
(
x
*
bpow
(
-
fexp
ex
)
%
Z
))
%
Z
.
omega
.
cut
(
gm
<
up
(
x
*
bpow
(
-
fexp
ex
)
%
Z
))
%
Z
.
omega
.
apply
lt_IZR
.
apply
Rle_lt_trans
with
(
2
:=
proj1
(
archimed
_
)).
rewrite
<-
Z2R_IZR
.
...
...
@@ -472,24 +463,24 @@ clear.
case
(
fexp
ex
-
fexp
(
fexp
ex
+
1
))
%
Z
;
trivial
.
intros
ep
Hp
.
now
elim
Hp
.
right
.
rewrite
Rabs_Ropp
.
rewrite
Rabs_right
.
intros
H9
.
intros
H
.
apply
f_equal
.
apply
sym_eq
.
apply
ln_beta_unique
.
rewrite
Rabs_left
.
rewrite
Ropp_involutive
.
split
.
replace
(
fexp
ex
+
1
-
1
)
%
Z
with
(
fexp
ex
)
by
ring
.
apply
Rle_refl
.
apply
->
epow_lt
.
apply
Zlt_succ
.
apply
Rle_ge
.
apply
epow_ge_0
.
rewrite
<-
Ropp_0
.
apply
Ropp_lt_contravar
.
apply
epow_gt_0
.
split
.
(
*
-
.
smaller
*
)
rewrite
<-
(
Ropp_involutive
x
)
.
apply
Ropp_le_contravar
.
apply
Ropp_le_cancel
.
rewrite
Ropp_involutive
.
apply
Rlt_le
.
apply
Rlt_le_trans
with
(
1
:=
Hx2
).
now
apply
->
epow_le
.
...
...
@@ -499,15 +490,10 @@ apply Rnot_lt_le.
intros
Hg3
.
assert
(
Hg4
:
(
g
<
0
)
%
R
).
now
apply
Rle_lt_trans
with
(
1
:=
Hgx
).
destruct
Hg2
as
[
Hg2
|
Hg2
].
rewrite
Hg2
in
Hg4
.
elim
(
Rlt_irrefl
_
Hg4
).
rewrite
(
Rabs_left
_
Hg4
)
in
Hg2
.
assert
(
Hg5
:=
Ropp_0_gt_lt_contravar
_
Hg4
).
specialize
(
Hg2
Hg5
).
simpl
in
Hg2
.
destruct
(
ln_beta
beta
(
-
g
)
Hg5
)
as
(
ge
'
,
Hge
).
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
).
simpl
in
Hg2
.
rewrite
(
Rabs_left
_
Hg4
)
in
Hge
.
assert
(
Hge
'
:
(
ge
'
<=
fexp
ex
)
%
Z
).
cut
(
ge
'
-
1
<
fexp
ex
)
%
Z
.
omega
.
apply
<-
epow_lt
.
...
...
@@ -536,7 +522,9 @@ rewrite Rmult_0_l.
rewrite
opp_Z2R
.
rewrite
Ropp_mult_distr_l_reverse
.
unfold
F2R
in
Hg1
.
simpl
in
Hg1
.
now
rewrite
<-
Hg1
.
rewrite
<-
Hg1
.
rewrite
<-
Ropp_0
.
now
apply
Ropp_lt_contravar
.
apply
Rle_trans
with
(
1
*
bpow
(
ge
-
ge
'
)
%
Z
)
%
R
.
rewrite
Rmult_1_l
.
cut
(
0
<=
ge
-
ge
'
)
%
Z
.
2
:
omega
.
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment