Source file float.ml

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
external format_float : string -> float -> string = "caml_format_float"

(* Stolen from [pervasives.ml].  Adds a "." at the end if needed.  It is in
   [pervasives.mli], but it also says not to use it directly, so we copy and paste the
   code. It makes the assumption on the string passed in argument that it was returned by
   [format_float] *)
let valid_float_lexem s =
  let l = String.length s in
  let rec loop i =
    if i >= l
    then s ^ "."
    else (
      match s.[i] with
      | '0' .. '9' | '-' -> loop (i + 1)
      | _ -> s)
  in
  loop 0
;;

open! Import

module T = struct
  include Base.Float

  type t = float [@@deriving bin_io, typerep]
end

include T
include Hashable.Make_binable (T)
include Comparable.Map_and_set_binable_using_comparator (T)
include Comparable.Validate_with_zero (T)
module Replace_polymorphic_compare : Comparisons.S with type t := t = T

let validate_ordinary t =
  Validate.of_error_opt
    (let module C = Class in
     match classify t with
     | C.Normal | C.Subnormal | C.Zero -> None
     | C.Infinite -> Some "value is infinite"
     | C.Nan -> Some "value is NaN")
;;

module V = struct
  module ZZ = Comparable.Validate (T)

  let validate_bound ~min ~max t =
    Validate.first_failure (validate_ordinary t) (ZZ.validate_bound t ~min ~max)
  ;;

  let validate_lbound ~min t =
    Validate.first_failure (validate_ordinary t) (ZZ.validate_lbound t ~min)
  ;;

  let validate_ubound ~max t =
    Validate.first_failure (validate_ordinary t) (ZZ.validate_ubound t ~max)
  ;;
end

include V

module Robust_compare = struct
  module type S = sig
    (* intended to be a tolerance on human-entered floats *)

    val robust_comparison_tolerance : float

    include Robustly_comparable.S with type t := float
  end

  module Make (T : sig
      val robust_comparison_tolerance : float
    end) : S = struct
    (* We have test in the tree that rely on these functions not allocating, even without
       X_LIBRARY_INLING. The only way to ensure that these don't create temporary boxed
       floats without X_LIBRARY_INLING is for this code to see the float operations as
       externals, as defined in [Pervasives]. That's why we use [Poly] and float
       arithmetic from [Caml]. *)
    open Poly

    let robust_comparison_tolerance = T.robust_comparison_tolerance
    let ( >=. ) x y = x >= Caml.( -. ) y robust_comparison_tolerance
    let ( <=. ) x y = y >=. x
    let ( =. ) x y = x >=. y && y >=. x
    let ( >. ) x y = x > Caml.( +. ) y robust_comparison_tolerance
    let ( <. ) x y = y >. x
    let ( <>. ) x y = not (x =. y)

    let robustly_compare x y =
      let d = Caml.( -. ) x y in
      if d < Caml.( ~-. ) robust_comparison_tolerance
      then -1
      else if d > robust_comparison_tolerance
      then 1
      else 0
    ;;
  end
end

module Robustly_comparable = Robust_compare.Make (struct
    let robust_comparison_tolerance = 1E-7
  end)

include Robustly_comparable

module O = struct
  include Base.Float.O
  include Robustly_comparable
end

module Terse = struct
  type nonrec t = t [@@deriving bin_io]

  include (
    Base.Float.Terse :
      module type of struct
      include Base.Float.Terse
    end
    with type t := t)
end

let robust_sign t : Sign.t = if t >. 0. then Pos else if t <. 0. then Neg else Zero

(* There are two issues:
   - Float.sign used to use robust comparison, and users of [Core] might have come to
     depend on this.
   - Robustness aside, what we get from Comparable.With_zero would map nan to Neg.
*)
let sign = robust_sign

(* Standard 12 significant digits, exponential notation used as necessary, guaranteed to
   be a valid OCaml float lexem, not to look like an int. *)
let to_string_12 x = valid_float_lexem (format_float "%.12g" x)
let quickcheck_generator = Base_quickcheck.Generator.float
let quickcheck_observer = Base_quickcheck.Observer.float
let quickcheck_shrinker = Base_quickcheck.Shrinker.float
let gen_uniform_excl = Base_quickcheck.Generator.float_uniform_exclusive
let gen_incl = Base_quickcheck.Generator.float_inclusive
let gen_without_nan = Base_quickcheck.Generator.float_without_nan
let gen_finite = Base_quickcheck.Generator.float_finite
let gen_positive = Base_quickcheck.Generator.float_strictly_positive
let gen_negative = Base_quickcheck.Generator.float_strictly_negative
let gen_zero = Base_quickcheck.Generator.float_of_class Zero
let gen_nan = Base_quickcheck.Generator.float_of_class Nan
let gen_subnormal = Base_quickcheck.Generator.float_of_class Subnormal
let gen_normal = Base_quickcheck.Generator.float_of_class Normal
let gen_infinite = Base_quickcheck.Generator.float_of_class Infinite