Section Binary.
Arguments exist {A} {P}.
(** [prec] is the number of bits of the mantissa including the implicit one; [emax] is the exponent of the infinities. For instance, binary32 is defined by [prec = 24] and [emax = 128]. *)
Variable prec emax : Z.
Context (prec_gt_0_ : Prec_gt_0 prec).
Hypothesis Hmax : (prec < emax)%Z.
Let emin := (3 - emax - prec)%Z.
Let fexp := FLT_exp emin prec.
Instance fexp_correct : Valid_exp fexp := FLT_exp_valid emin prec.
Instance fexp_monotone : Monotone_exp fexp := FLT_exp_monotone emin prec.
Definition canonical_mantissa m e :=
Zeq_bool (fexp (Zpos (digits2_pos m) + e)) e.
Definition bounded m e :=
andb (canonical_mantissa m e) (Zle_bool e (emax - prec)).
Definition nan_pl pl :=
Zlt_bool (Zpos (digits2_pos pl)) prec.
Definition valid_binary x :=
match x with
| F754_finite _ m e => bounded m e
| F754_nan _ pl => nan_pl pl
| _ => true
end.
(** Basic type used for representing binary FP numbers. Note that there is exactly one such object per FP datum. *)
Inductive binary_float :=
| B754_zero (s : bool)
| B754_infinity (s : bool)
| B754_nan (s : bool) (pl : positive) :
nan_pl pl = true -> binary_float
| B754_finite (s : bool) (m : positive) (e : Z) :
bounded m e = true -> binary_float.
Definition FF2B x :=
match x as x return valid_binary x = true -> binary_float with
| F754_finite s m e => B754_finite s m e
| F754_infinity s => fun _ => B754_infinity s
| F754_zero s => fun _ => B754_zero s
| F754_nan b pl => fun H => B754_nan b pl H
end.
Definition B2FF x :=
match x with
| B754_finite s m e _ => F754_finite s m e
| B754_infinity s => F754_infinity s
| B754_zero s => F754_zero s
| B754_nan b pl _ => F754_nan b pl
end.
Definition B2R f :=
match f with
| B754_finite s m e _ => F2R (Float radix2 (cond_Zopp s (Zpos m)) e)
| _ => 0%R
end.
Proof with auto with typeclass_instances.
intros x.
apply FLT_format_generic...
apply generic_format_B2R.
Qed.
Definition is_finite_strict f :=
match f with
| B754_finite _ _ _ _ => true
| _ => false
end.
Definition Bsign x :=
match x with
| B754_nan s _ _ => s
| B754_zero s => s
| B754_infinity s => s
| B754_finite s _ _ _ => s
end.
Definition sign_FF x :=
match x with
| F754_nan s _ => s
| F754_zero s => s
| F754_infinity s => s
| F754_finite s _ _ => s
end.
Definition is_finite f :=
match f with
| B754_finite _ _ _ _ => true
| B754_zero _ => true
| _ => false
end.
Definition is_finite_FF f :=
match f with
| F754_finite _ _ _ => true
| F754_zero _ => true
| _ => false
end.
Definition is_nan f :=
match f with
| B754_nan _ _ _ => true
| _ => false
end.
Definition is_nan_FF f :=
match f with
| F754_nan _ _ => true
| _ => false
end.
Definition get_nan_pl (x : binary_float) : positive :=
match x with B754_nan _ pl _ => pl | _ => xH end.
Definition build_nan (x : { x | is_nan x = true }) : binary_float.
Definition erase (x : binary_float) : binary_float.
(** Opposite *)
Definition Bopp opp_nan x :=
match x with
| B754_nan _ _ _ => build_nan (opp_nan x)
| B754_infinity sx => B754_infinity (negb sx)
| B754_finite sx mx ex Hx => B754_finite (negb sx) mx ex Hx
| B754_zero sx => B754_zero (negb sx)
end.
(** Comparison  [Some c] means ordered as per [c]; [None] means unordered. *)
Definition Bcompare (f1 f2 : binary_float) : option comparison :=
match f1, f2 with
| B754_nan _ _ _,_ | _,B754_nan _ _ _ => None
| B754_infinity s1, B754_infinity s2 =>
Some match s1, s2 with
| true, true => Eq
| false, false => Eq
| true, false => Lt
| false, true => Gt
end
| B754_infinity s, _ => Some (if s then Lt else Gt)
| _, B754_infinity s => Some (if s then Gt else Lt)
| B754_finite s _ _ _, B754_zero _ => Some (if s then Lt else Gt)
| B754_zero _, B754_finite s _ _ _ => Some (if s then Gt else Lt)
| B754_zero _, B754_zero _ => Some Eq
| B754_finite s1 m1 e1 _, B754_finite s2 m2 e2 _ =>
Some match s1, s2 with
| true, false => Lt
| false, true => Gt
| false, false =>
match Z.compare e1 e2 with
| Lt => Lt
| Gt => Gt
| Eq => Pcompare m1 m2 Eq
end
| true, true =>
match Z.compare e1 e2 with
| Lt => Gt
| Gt => Lt
| Eq => CompOpp (Pcompare m1 m2 Eq)
end
end
end.
(** Truncation *)
Record shr_record := { shr_m : Z ; shr_r : bool ; shr_s : bool }.
Definition shr_1 mrs :=
let '(Build_shr_record m r s) := mrs in
let s := orb r s in
match m with
| Z0 => Build_shr_record Z0 false s
| Zpos xH => Build_shr_record Z0 true s
| Zpos (xO p) => Build_shr_record (Zpos p) false s
| Zpos (xI p) => Build_shr_record (Zpos p) true s
| Zneg xH => Build_shr_record Z0 true s
| Zneg (xO p) => Build_shr_record (Zneg p) false s
| Zneg (xI p) => Build_shr_record (Zneg p) true s
end.
Definition loc_of_shr_record mrs :=
match mrs with
| Build_shr_record _ false false => loc_Exact
| Build_shr_record _ false true => loc_Inexact Lt
| Build_shr_record _ true false => loc_Inexact Eq
| Build_shr_record _ true true => loc_Inexact Gt
end.
Definition shr_record_of_loc m l :=
match l with
| loc_Exact => Build_shr_record m false false
| loc_Inexact Lt => Build_shr_record m false true
| loc_Inexact Eq => Build_shr_record m true false
| loc_Inexact Gt => Build_shr_record m true true
end.
Definition shr mrs e n :=
match n with
| Zpos p => (iter_pos shr_1 p mrs, (e + n)%Z)
| _ => (mrs, e)
end.
Definition shr_fexp m e l :=
shr (shr_record_of_loc m l) e (fexp (Zdigits2 m + e) - e).

Theorem shr_truncate :
forall m e l,
(0 <= m)%Z ->
shr_fexp m e l =
let '(m', e', l') := truncate radix2 fexp (m, e, l) in (shr_record_of_loc m' l', e').