(**
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/

Copyright (C) 2010-2013 Sylvie Boldo
#<br />#
Copyright (C) 2010-2013 Guillaume Melquiond

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

(** * Sterbenz conditions for exact subtraction *)

Require Import Fcore_Raux.
Require Import Fcore_defs.
Require Import Fcore_generic_fmt.
Require Import Fcalc_ops.

Section Fprop_Sterbenz.

Variable beta : radix.
Notation bpow e := (bpow beta e).

Variable fexp : Z -> Z.
Context { valid_exp : Valid_exp fexp }.
Context { monotone_exp : Monotone_exp fexp }.
Notation format := (generic_format beta fexp).

Theorem generic_format_plus :
  forall x y,
  format x -> format y ->
  (Rabs (x + y) < bpow (Zmin (ln_beta beta x) (ln_beta beta y)))%R ->
  format (x + y)%R.
Proof.
(* Goal: forall (x y : R) (_ : generic_format beta fexp x) (_ : generic_format beta fexp y) (_ : Rle (Rabs (Rplus x y)) (Rmin (Rabs x) (Rabs y))), generic_format beta fexp (Rplus x y) *)
intros x y Fx Fy Hxy.
(* Goal: generic_format beta fexp (Rplus x y) *)
destruct (Req_dec (x + y) 0) as [Zxy|Zxy].
(* Goal: generic_format beta fexp (Rplus x y) *)
(* Goal: generic_format beta fexp (Rplus x y) *)
rewrite Zxy.
(* Goal: generic_format beta fexp (IZR Z0) *)
(* Goal: generic_format beta fexp (Rplus x y) *)
apply generic_format_0.
(* Goal: generic_format beta fexp (Rplus x y) *)
destruct (Req_dec x R0) as [Zx|Zx].
(* Goal: generic_format beta fexp (Rplus x y) *)
(* Goal: generic_format beta fexp (Rplus x y) *)
now rewrite Zx, Rplus_0_l.
(* Goal: generic_format beta fexp (Rplus x y) *)
destruct (Req_dec y R0) as [Zy|Zy].
(* Goal: generic_format beta fexp (Rplus x y) *)
(* Goal: generic_format beta fexp (Rplus x y) *)
now rewrite Zy, Rplus_0_r.
(* Goal: generic_format beta fexp (Rplus x y) *)
revert Hxy.
(* Goal: forall _ : Rlt (Rabs (Rplus x y)) (Fcore_Raux.bpow beta (Z.min (ln_beta_val beta x (ln_beta beta x)) (ln_beta_val beta y (ln_beta beta y)))), generic_format beta fexp (Rplus x y) *)
destruct (ln_beta beta x) as (ex, Ex). simpl.
(* Goal: forall _ : Rlt (Rabs (Rplus x y)) (Fcore_Raux.bpow beta (Z.min ex (ln_beta_val beta y (ln_beta beta y)))), generic_format beta fexp (Rplus x y) *)
specialize (Ex Zx).
(* Goal: @eq Z (fexp (Z.min ex ey)) (Z.min (@Fexp beta fx) (@Fexp beta fy)) *)
destruct (ln_beta beta y) as (ey, Ey). simpl.
(* Goal: forall _ : Rlt (Rabs (Rplus x y)) (Fcore_Raux.bpow beta (Z.min ex ey)), generic_format beta fexp (Rplus x y) *)
specialize (Ey Zy).
(* Goal: forall _ : Rlt (Rabs (Rplus x y)) (Fcore_Raux.bpow beta (Z.min ex ey)), generic_format beta fexp (Rplus x y) *)
intros Hxy.
(* Goal: generic_format beta fexp (Rplus x y) *)
set (fx := Float beta (Ztrunc (scaled_mantissa beta fexp x)) (fexp ex)).
(* Goal: generic_format beta fexp (Rplus x y) *)
assert (Hx: x = F2R fx).
(* Goal: @eq R x (@F2R beta fx) *)
(* Goal: generic_format beta fexp (Rplus x y) *)
rewrite Fx at 1.
(* Goal: Z.le (canonic_exp beta fexp (Rplus x y)) exy *)
unfold canonic_exp.
(* Goal: @eq R (@F2R beta (Float beta (Ztrunc (scaled_mantissa beta fexp x)) (fexp (ln_beta_val beta x (ln_beta beta x))))) (@F2R beta fx) *)
(* Goal: generic_format beta fexp (Rplus x y) *)
now rewrite ln_beta_unique with (1 := Ex).
(* Goal: generic_format beta fexp (Rplus x y) *)
set (fy := Float beta (Ztrunc (scaled_mantissa beta fexp y)) (fexp ey)).
(* Goal: generic_format beta fexp (Rplus x y) *)
assert (Hy: y = F2R fy).
(* Goal: @eq R y (@F2R beta fy) *)
(* Goal: generic_format beta fexp (Rplus x y) *)
rewrite Fy at 1.
(* Goal: Z.le (canonic_exp beta fexp (Rplus x y)) exy *)
unfold canonic_exp.
(* Goal: @eq R (@F2R beta (Float beta (Ztrunc (scaled_mantissa beta fexp y)) (fexp (ln_beta_val beta y (ln_beta beta y))))) (@F2R beta fy) *)
(* Goal: generic_format beta fexp (Rplus x y) *)
now rewrite ln_beta_unique with (1 := Ey).
(* Goal: generic_format beta fexp (Rplus x y) *)
rewrite Hx, Hy.
(* Goal: generic_format beta fexp (Rplus (@F2R beta fx) (@F2R beta fy)) *)
rewrite <- F2R_plus.
(* Goal: generic_format beta fexp (@F2R beta (Fplus beta fx fy)) *)
apply generic_format_F2R.
(* Goal: forall _ : not (@eq Z (let (Fnum, _) := Fplus beta fx fy in Fnum) Z0), Z.le (canonic_exp beta fexp (@F2R beta (Float beta (let (Fnum, _) := Fplus beta fx fy in Fnum) (let (_, Fexp) := Fplus beta fx fy in Fexp)))) (let (_, Fexp) := Fplus beta fx fy in Fexp) *)
intros _.
(* Goal: Z.le (canonic_exp beta fexp (@F2R beta (Float beta (let (Fnum, _) := Fplus beta fx fy in Fnum) (let (_, Fexp) := Fplus beta fx fy in Fexp)))) (let (_, Fexp) := Fplus beta fx fy in Fexp) *)
case_eq (Fplus beta fx fy).
(* Goal: forall (Fnum Fexp : Z) (_ : @eq (float beta) (Fplus beta fx fy) (Float beta Fnum Fexp)), Z.le (canonic_exp beta fexp (@F2R beta (Float beta Fnum Fexp))) Fexp *)
intros mxy exy Pxy.
(* Goal: Z.le (canonic_exp beta fexp (@F2R beta (Float beta mxy exy))) exy *)
rewrite <- Pxy, F2R_plus, <- Hx, <- Hy.
(* Goal: Z.le (canonic_exp beta fexp (Rplus x y)) exy *)
unfold canonic_exp.
(* Goal: Z.le (fexp (ln_beta_val beta (Rplus x y) (ln_beta beta (Rplus x y)))) exy *)
replace exy with (fexp (Zmin ex ey)).
(* Goal: Z.le (fexp ey) (fexp ex) *)
apply monotone_exp.
(* Goal: Z.le (ln_beta_val beta (Rplus x y) (ln_beta beta (Rplus x y))) (Z.min ex ey) *)
(* Goal: @eq Z (fexp (Z.min ex ey)) exy *)
now apply ln_beta_le_bpow.
(* Goal: @eq Z (fexp (Z.min ex ey)) exy *)
replace exy with (Fexp (Fplus beta fx fy)) by exact (f_equal Fexp Pxy).
(* Goal: @eq Z (fexp (Z.min ex ey)) (@Fexp beta (Fplus beta fx fy)) *)
rewrite Fexp_Fplus.
(* Goal: @eq Z (fexp (Z.min ex ey)) (Z.min (@Fexp beta fx) (@Fexp beta fy)) *)
simpl. clear -monotone_exp.
(* Goal: @eq Z (fexp (Z.min ex ey)) (Z.min (fexp ex) (fexp ey)) *)
apply sym_eq.
(* Goal: @eq Z (Z.min (fexp ex) (fexp ey)) (fexp (Z.min ex ey)) *)
destruct (Zmin_spec ex ey) as [(H1,H2)|(H1,H2)] ; rewrite H2.
(* Goal: @eq Z (Z.min (fexp ex) (fexp ey)) (fexp ex) *)
(* Goal: @eq Z (Z.min (fexp ex) (fexp ey)) (fexp ey) *)
apply Zmin_l.
(* Goal: Z.le (fexp ey) (fexp ex) *)
now apply monotone_exp.
(* Goal: @eq Z (Z.min (fexp ex) (fexp ey)) (fexp ey) *)
apply Zmin_r.
(* Goal: Z.le (fexp ey) (fexp ex) *)
apply monotone_exp.
(* Goal: Z.le ey ex *)
apply Zlt_le_weak.
(* Goal: Z.lt ey ex *)
now apply Zgt_lt.
Qed.

Theorem generic_format_plus_weak :
  forall x y,
  format x -> format y ->
  (Rabs (x + y) <= Rmin (Rabs x) (Rabs y))%R ->
  format (x + y)%R.
Proof.
(* Goal: forall (x y : R) (_ : generic_format beta fexp x) (_ : generic_format beta fexp y) (_ : Rle (Rabs (Rplus x y)) (Rmin (Rabs x) (Rabs y))), generic_format beta fexp (Rplus x y) *)
intros x y Fx Fy Hxy.
(* Goal: generic_format beta fexp (Rplus x y) *)
destruct (Req_dec x R0) as [Zx|Zx].
(* Goal: generic_format beta fexp (Rplus x y) *)
(* Goal: generic_format beta fexp (Rplus x y) *)
now rewrite Zx, Rplus_0_l.
(* Goal: generic_format beta fexp (Rplus x y) *)
destruct (Req_dec y R0) as [Zy|Zy].
(* Goal: generic_format beta fexp (Rplus x y) *)
(* Goal: generic_format beta fexp (Rplus x y) *)
now rewrite Zy, Rplus_0_r.
(* Goal: generic_format beta fexp (Rplus x y) *)
apply generic_format_plus ; try assumption.
(* Goal: Rlt (Rabs (Rplus x y)) (Fcore_Raux.bpow beta (Z.min (ln_beta_val beta x (ln_beta beta x)) (ln_beta_val beta y (ln_beta beta y)))) *)
apply Rle_lt_trans with (1 := Hxy).
(* Goal: Rle (Rplus x (Ropp y)) (Rmin y x) *)
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (Rplus x (Ropp y)) *)
unfold Rmin.
(* Goal: Rlt (if Rle_dec (Rabs x) (Rabs y) then Rabs x else Rabs y) (Fcore_Raux.bpow beta (Z.min (ln_beta_val beta x (ln_beta beta x)) (ln_beta_val beta y (ln_beta beta y)))) *)
destruct (Rle_dec (Rabs x) (Rabs y)) as [Hxy'|Hxy'].
(* Goal: Rlt (Rabs x) (Fcore_Raux.bpow beta (Z.min (ln_beta_val beta x (ln_beta beta x)) (ln_beta_val beta y (ln_beta beta y)))) *)
(* Goal: Rlt (Rabs y) (Fcore_Raux.bpow beta (Z.min (ln_beta_val beta x (ln_beta beta x)) (ln_beta_val beta y (ln_beta beta y)))) *)
rewrite Zmin_l.
(* Goal: Rlt (Rabs x) (Fcore_Raux.bpow beta (ln_beta_val beta x (ln_beta beta x))) *)
(* Goal: Z.le (ln_beta_val beta x (ln_beta beta x)) (ln_beta_val beta y (ln_beta beta y)) *)
(* Goal: Rlt (Rabs y) (Fcore_Raux.bpow beta (Z.min (ln_beta_val beta x (ln_beta beta x)) (ln_beta_val beta y (ln_beta beta y)))) *)
destruct (ln_beta beta x) as (ex, Hx).
(* Goal: Rlt (Rabs x) (Fcore_Raux.bpow beta (ln_beta_val beta x (Build_ln_beta_prop beta x ex Hx))) *)
(* Goal: Z.le (ln_beta_val beta x (ln_beta beta x)) (ln_beta_val beta y (ln_beta beta y)) *)
(* Goal: Rlt (Rabs y) (Fcore_Raux.bpow beta (Z.min (ln_beta_val beta x (ln_beta beta x)) (ln_beta_val beta y (ln_beta beta y)))) *)
now apply Hx.
(* Goal: Z.le (ln_beta_val beta x (ln_beta beta x)) (ln_beta_val beta y (ln_beta beta y)) *)
(* Goal: Rlt (Rabs y) (Fcore_Raux.bpow beta (Z.min (ln_beta_val beta x (ln_beta beta x)) (ln_beta_val beta y (ln_beta beta y)))) *)
now apply ln_beta_le_abs.
(* Goal: Rlt (Rabs y) (Fcore_Raux.bpow beta (Z.min (ln_beta_val beta x (ln_beta beta x)) (ln_beta_val beta y (ln_beta beta y)))) *)
rewrite Zmin_r.
(* Goal: Rlt (Rabs y) (Fcore_Raux.bpow beta (ln_beta_val beta y (ln_beta beta y))) *)
(* Goal: Z.le (ln_beta_val beta y (ln_beta beta y)) (ln_beta_val beta x (ln_beta beta x)) *)
destruct (ln_beta beta y) as (ex, Hy).
(* Goal: Rlt (Rabs y) (Fcore_Raux.bpow beta (ln_beta_val beta y (Build_ln_beta_prop beta y ex Hy))) *)
(* Goal: Z.le (ln_beta_val beta y (ln_beta beta y)) (ln_beta_val beta x (ln_beta beta x)) *)
now apply Hy.
(* Goal: Z.le (ln_beta_val beta y (ln_beta beta y)) (ln_beta_val beta x (ln_beta beta x)) *)
apply ln_beta_le_abs.
(* Goal: not (@eq R y (IZR Z0)) *)
(* Goal: Rle (Rabs y) (Rabs x) *)
exact Zy.
(* Goal: Rle (Rabs y) (Rabs x) *)
apply Rlt_le.
(* Goal: Rlt (Rabs y) (Rabs x) *)
now apply Rnot_le_lt.
Qed.

Lemma sterbenz_aux :
  forall x y, format x -> format y ->
  (y <= x <= 2 * y)%R ->
  format (x - y)%R.
Proof.
(* Goal: forall (x y : R) (_ : generic_format beta fexp x) (_ : generic_format beta fexp y) (_ : and (Rle (Rdiv y (IZR (Zpos (xO xH)))) x) (Rle x (Rmult (IZR (Zpos (xO xH))) y))), generic_format beta fexp (Rminus x y) *)
intros x y Hx Hy (Hxy1, Hxy2).
(* Goal: generic_format beta fexp (Rminus x y) *)
unfold Rminus.
(* Goal: generic_format beta fexp (Rplus x (Ropp y)) *)
apply generic_format_plus_weak.
(* Goal: generic_format beta fexp x *)
(* Goal: generic_format beta fexp (Ropp y) *)
(* Goal: Rle (Rabs (Rplus x (Ropp y))) (Rmin (Rabs x) (Rabs (Ropp y))) *)
exact Hx.
(* Goal: generic_format beta fexp (Ropp y) *)
(* Goal: Rle (Rabs (Rplus x (Ropp y))) (Rmin (Rabs x) (Rabs (Ropp y))) *)
now apply generic_format_opp.
(* Goal: Rle (Rplus x (Ropp y)) (Rmin y (Rabs x)) *)
(* Goal: Rle (IZR Z0) (Rplus x (Ropp y)) *)
rewrite Rabs_pos_eq.
(* Goal: Rle (Rplus x (Ropp y)) (Rmin (Rabs x) (Rabs (Ropp y))) *)
(* Goal: Rle (IZR Z0) (Rplus x (Ropp y)) *)
rewrite Rabs_Ropp.
(* Goal: Rle (Rplus x (Ropp y)) (Rmin (Rabs x) (Rabs y)) *)
(* Goal: Rle (IZR Z0) (Rplus x (Ropp y)) *)
rewrite Rmin_comm.
(* Goal: Rle (Rplus x (Ropp y)) (Rmin (Rabs y) (Rabs x)) *)
(* Goal: Rle (IZR Z0) (Rplus x (Ropp y)) *)
assert (Hy0: (0 <= y)%R).
(* Goal: Rle (Rplus x (Ropp y)) y *)
(* Goal: Rle (Rplus x (Ropp y)) x *)
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (Rplus x (Ropp y)) *)
apply Rplus_le_reg_r with y.
(* Goal: Rle (Rplus (IZR Z0) y) (Rplus y y) *)
(* Goal: Rle (Rplus x (Ropp y)) (Rmin (Rabs y) (Rabs x)) *)
(* Goal: Rle (IZR Z0) (Rplus x (Ropp y)) *)
apply Rle_trans with x.
(* Goal: Rle (Rplus (IZR Z0) y) x *)
(* Goal: Rle x (Rplus y y) *)
(* Goal: Rle (Rplus x (Ropp y)) (Rmin (Rabs y) (Rabs x)) *)
(* Goal: Rle (IZR Z0) (Rplus x (Ropp y)) *)
now rewrite Rplus_0_l.
(* Goal: Rle x (Rplus y y) *)
(* Goal: Rle (Rplus x (Ropp y)) (Rmin (Rabs y) (Rabs x)) *)
(* Goal: Rle (IZR Z0) (Rplus x (Ropp y)) *)
now replace (y + y)%R with (2 * y)%R by ring.
(* Goal: Rle (Rplus x (Ropp y)) (Rmin (Rabs y) (Rabs x)) *)
(* Goal: Rle (IZR Z0) (Rplus x (Ropp y)) *)
rewrite Rabs_pos_eq with (1 := Hy0).
(* Goal: Rle (Rplus x (Ropp y)) (Rmin y (Rabs x)) *)
(* Goal: Rle (IZR Z0) (Rplus x (Ropp y)) *)
rewrite Rabs_pos_eq.
(* Goal: Rle (Rplus x (Ropp y)) (Rmin y x) *)
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (Rplus x (Ropp y)) *)
unfold Rmin.
(* Goal: Rle (Rplus x (Ropp y)) (if Rle_dec y x then y else x) *)
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (Rplus x (Ropp y)) *)
destruct (Rle_dec y x) as [Hyx|Hyx].
(* Goal: Rle (Rplus x (Ropp y)) y *)
(* Goal: Rle (Rplus x (Ropp y)) x *)
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (Rplus x (Ropp y)) *)
apply Rplus_le_reg_r with y.
(* Goal: Rle (Rplus (Rplus x (Ropp y)) y) (Rplus y y) *)
(* Goal: Rle (Rplus x (Ropp y)) x *)
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (Rplus x (Ropp y)) *)
now ring_simplify.
(* Goal: Rle (Rplus x (Ropp y)) x *)
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (Rplus x (Ropp y)) *)
now elim Hyx.
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (Rplus x (Ropp y)) *)
now apply Rle_trans with y.
(* Goal: Rle (IZR Z0) (Rplus x (Ropp y)) *)
now apply Rle_0_minus.
Qed.

Theorem sterbenz :
  forall x y, format x -> format y ->
  (y / 2 <= x <= 2 * y)%R ->
  format (x - y)%R.
Proof.
(* Goal: forall (x y : R) (_ : generic_format beta fexp x) (_ : generic_format beta fexp y) (_ : and (Rle (Rdiv y (IZR (Zpos (xO xH)))) x) (Rle x (Rmult (IZR (Zpos (xO xH))) y))), generic_format beta fexp (Rminus x y) *)
intros x y Hx Hy (Hxy1, Hxy2).
(* Goal: generic_format beta fexp (Rminus x y) *)
destruct (Rle_or_lt x y) as [Hxy|Hxy].
(* Goal: generic_format beta fexp (Rminus x y) *)
(* Goal: generic_format beta fexp (Rminus x y) *)
rewrite <- Ropp_minus_distr.
(* Goal: generic_format beta fexp (Ropp (Rminus y x)) *)
(* Goal: generic_format beta fexp (Rminus x y) *)
apply generic_format_opp.
(* Goal: generic_format beta fexp (Rminus x y) *)
apply sterbenz_aux ; try easy.
(* Goal: and (Rle y x) (Rle x (Rmult (IZR (Zpos (xO xH))) y)) *)
split.
(* Goal: Rle x y *)
(* Goal: Rle y (Rmult (IZR (Zpos (xO xH))) x) *)
(* Goal: generic_format beta fexp (Rminus x y) *)
exact Hxy.
(* Goal: Rle y (Rmult (IZR (Zpos (xO xH))) x) *)
(* Goal: generic_format beta fexp (Rminus x y) *)
apply Rcompare_not_Lt_inv.
(* Goal: not (@eq comparison (Rcompare (Rmult (IZR (Zpos (xO xH))) x) y) Lt) *)
(* Goal: generic_format beta fexp (Rminus x y) *)
rewrite <- Rcompare_half_r.
(* Goal: not (@eq comparison (Rcompare x (Rdiv y (IZR (Zpos (xO xH))))) Lt) *)
(* Goal: generic_format beta fexp (Rminus x y) *)
now apply Rcompare_not_Lt.
(* Goal: generic_format beta fexp (Rminus x y) *)
apply sterbenz_aux ; try easy.
(* Goal: and (Rle y x) (Rle x (Rmult (IZR (Zpos (xO xH))) y)) *)
split.
(* Goal: Rle (Rabs y) (Rabs x) *)
now apply Rlt_le.
(* Goal: Rle x (Rmult (IZR (Zpos (xO xH))) y) *)
exact Hxy2.
Qed.

End Fprop_Sterbenz.
