-
Notifications
You must be signed in to change notification settings - Fork 2
/
bigint.ml
500 lines (415 loc) · 14.2 KB
/
bigint.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
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
open Core
module Z = Zarith.Z
type t = Z.t [@@deriving typerep ~abstract]
let module_name = "Bigint"
let invariant (_ : t) = ()
module Stringable_t = struct
type nonrec t = t
let to_string = Z.to_string
let of_string_base str ~name ~of_string =
try of_string str with
| _ -> failwithf "%s.%s: invalid argument %S" name module_name str ()
;;
let of_string str = of_string_base str ~name:"of_string" ~of_string:Z.of_string
end
module Stable = struct
module V1 = struct
module Bin_rep = struct
open Stable_witness.Export
type t =
| Zero
| Pos of string
| Neg of string
[@@deriving bin_io, stable_witness]
end
module Bin_rep_conversion = struct
type nonrec t = t
let to_binable t =
let s = Z.sign t in
if s > 0
then Bin_rep.Pos (Z.to_bits t)
else if s < 0
then Bin_rep.Neg (Z.to_bits t)
else Bin_rep.Zero
;;
let of_binable = function
| Bin_rep.Zero -> Z.zero
| Bin_rep.Pos bits -> Z.of_bits bits
| Bin_rep.Neg bits -> Z.of_bits bits |> Z.neg
;;
end
type nonrec t = t
let compare = Z.compare
include Sexpable.Stable.Of_stringable.V1 (Stringable_t)
include Binable.Stable.Of_binable.V1 [@alert "-legacy"] (Bin_rep) (Bin_rep_conversion)
let stable_witness : t Stable_witness.t =
let (_bin_io : t Stable_witness.t) =
(* Binable.Stable.of_binable.V1 *)
Stable_witness.of_serializable
Bin_rep.stable_witness
Bin_rep_conversion.of_binable
Bin_rep_conversion.to_binable
in
let (_sexp : t Stable_witness.t) = Stable_witness.assert_stable in
Stable_witness.assert_stable
;;
end
module V2 = struct
type nonrec t = t
let compare = Z.compare
include Sexpable.Stable.Of_stringable.V1 (Stringable_t)
let compute_size_in_bytes x =
let numbits = Z.numbits x in
Int.round_up ~to_multiple_of:8 numbits / 8
;;
let compute_tag ~size_in_bytes ~negative =
let open Int63 in
let sign_bit = if negative then one else zero in
(* Can't overflow:
size <= String.length bits < 2 * max_string_length < max_int63
*)
shift_left (of_int size_in_bytes) 1 + sign_bit
;;
let bin_size_t : t Bin_prot.Size.sizer =
fun x ->
let size_in_bytes = compute_size_in_bytes x in
if size_in_bytes = 0
then Int63.bin_size_t Int63.zero
else (
let negative = Z.sign x = -1 in
let tag = compute_tag ~size_in_bytes ~negative in
Int63.bin_size_t tag + size_in_bytes)
;;
let bin_write_t : t Bin_prot.Write.writer =
fun buf ~pos x ->
let size_in_bytes = compute_size_in_bytes x in
if size_in_bytes = 0
then Int63.bin_write_t buf ~pos Int63.zero
else (
let bits = Z.to_bits x in
let negative = Z.sign x = -1 in
let tag = compute_tag ~size_in_bytes ~negative in
let pos = Int63.bin_write_t buf ~pos tag in
Bin_prot.Common.blit_string_buf bits ~dst_pos:pos buf ~len:size_in_bytes;
pos + size_in_bytes)
;;
let bin_read_t : t Bin_prot.Read.reader =
fun buf ~pos_ref ->
let tag = Core.Int63.bin_read_t buf ~pos_ref in
if Int63.equal tag Int63.zero
then Z.zero
else (
let negative = Int63.(tag land one = one) in
let size_in_bytes = Int63.(to_int_exn (shift_right tag 1)) in
(* Even though we could cache a buffer for small sizes, the extra logic leads to
a decrease in performance *)
let bytes = Bytes.create size_in_bytes in
Bin_prot.Common.blit_buf_bytes ~src_pos:!pos_ref buf bytes ~len:size_in_bytes;
let abs =
Z.of_bits (Bytes.unsafe_to_string ~no_mutation_while_string_reachable:bytes)
in
pos_ref := !pos_ref + size_in_bytes;
if negative then Z.neg abs else abs)
;;
let module_name = "Bigint.Stable.V2.t"
let bin_writer_t : t Bin_prot.Type_class.writer =
{ size = bin_size_t; write = bin_write_t }
;;
let __bin_read_t__ _buf ~pos_ref _vint =
Bin_prot.Common.raise_variant_wrong_type module_name !pos_ref
;;
let bin_reader_t : t Bin_prot.Type_class.reader =
{ read = bin_read_t; vtag_read = __bin_read_t__ }
;;
let bin_shape_t : Bin_prot.Shape.t =
Bin_prot.Shape.basetype
(Bin_prot.Shape.Uuid.of_string "7a8cceb2-f3a2-11e9-b7cb-aae95a547ff6")
[]
;;
let bin_t : t Bin_prot.Type_class.t =
{ shape = bin_shape_t; writer = bin_writer_t; reader = bin_reader_t }
;;
let stable_witness : t Stable_witness.t =
let (_bin_io : t Stable_witness.t) =
(* implemented directly above *)
Stable_witness.assert_stable
in
let (_sexp : t Stable_witness.t) = Stable_witness.assert_stable in
Stable_witness.assert_stable
;;
end
end
module Unstable = struct
include Stable.V1
include Stringable_t
let of_string_opt t =
try Some (of_string t) with
| _ -> None
;;
let (t_sexp_grammar : t Sexplib.Sexp_grammar.t) = { untyped = Integer }
let of_zarith_bigint t = t
let to_zarith_bigint t = t
let ( /% ) x y =
if Z.sign y >= 0
then Z.ediv x y
else
failwithf
"%s.(%s /%% %s) : divisor must be positive"
module_name
(to_string x)
(to_string y)
()
;;
let ( % ) x y =
if Z.sign y >= 0
then Z.erem x y
else
failwithf
"%s.(%s %% %s) : divisor must be positive"
module_name
(to_string x)
(to_string y)
()
;;
let hash_fold_t state t = Int.hash_fold_t state (Z.hash t)
let hash = Z.hash
let compare = Z.compare
external compare__local : t -> t -> int = "ml_z_compare"
let ( - ) = Z.( - )
let ( + ) = Z.( + )
let ( * ) = Z.( * )
let ( / ) = Z.( / )
let rem = Z.rem
let ( ~- ) = Z.( ~- )
let neg = Z.neg
let abs = Z.abs
let succ = Z.succ
let pred = Z.pred
let equal = Z.equal
external equal__local : t -> t -> bool = "ml_z_equal"
let ( = ) = Z.equal
let ( < ) = Z.lt
let ( > ) = Z.gt
let ( <= ) = Z.leq
let ( >= ) = Z.geq
let max = Z.max
let min = Z.min
let ascending = compare
let shift_right = Z.shift_right
let shift_left = Z.shift_left
let bit_not = Z.lognot
let bit_xor = Z.logxor
let bit_or = Z.logor
let bit_and = Z.logand
let ( land ) = bit_and
let ( lor ) = bit_or
let ( lxor ) = bit_xor
let lnot = bit_not
let ( lsl ) = shift_left
let ( asr ) = shift_right
let of_int = Z.of_int
let of_int32 = Z.of_int32
let of_int64 = Z.of_int64
let of_nativeint = Z.of_nativeint
let of_float_unchecked = Z.of_float
let of_float = Z.of_float
let of_int_exn = of_int
let of_int32_exn = of_int32
let of_int64_exn = of_int64
let of_nativeint_exn = of_nativeint
let to_int_exn = Z.to_int
let to_int32_exn = Z.to_int32
let to_int64_exn = Z.to_int64
let to_nativeint_exn = Z.to_nativeint
let to_float = Z.to_float
let zero = Z.zero
let one = Z.one
let minus_one = Z.minus_one
let to_int t = if Z.fits_int t then Some (Z.to_int t) else None
let to_int32 t = if Z.fits_int32 t then Some (Z.to_int32 t) else None
let to_int64 t = if Z.fits_int64 t then Some (Z.to_int64 t) else None
let to_nativeint t = if Z.fits_nativeint t then Some (Z.to_nativeint t) else None
let ( <> ) x y = not (equal x y)
let incr cell = cell := succ !cell
let decr cell = cell := pred !cell
let pow x y = Z.pow x (to_int_exn y)
let ( ** ) x y = pow x y
let popcount x = Z.popcount x
end
module T_math = Int_math.Make (Unstable)
module T_conversions = Int_conversions.Make (Unstable)
module T_comparable_with_zero = Comparable.With_zero (Unstable)
module T_identifiable = Identifiable.Make (struct
let module_name = module_name
include Unstable
end)
(* Including in opposite order to shadow functorized bindings with direct bindings. *)
module O = struct
include T_identifiable
include T_comparable_with_zero
include T_conversions
include T_math
include Unstable
end
include (O : module type of O with type t := t)
module Make_random (State : sig
type t
val bits : t -> int
val int : t -> int -> int
end) : sig
val random : state:State.t -> t -> t
end = struct
(* Uniform random generation of Bigint values.
[random ~state range] chooses a [depth] and generates random values using
[Random.State.bits state], called [1 lsl depth] times and concatenated. The
preliminary result [n] therefore satisfies [0 <= n < 1 lsl (30 lsl depth)].
In order for the random choice to be uniform between [0] and [range-1], there must
exist [k > 0] such that [n < k * range <= 1 lsl (30 lsl depth)]. If so, [n % range]
is returned. Otherwise the random choice process is repeated from scratch.
The [depth] value is chosen so that repeating is uncommon (1 in 1,000 or less). *)
let bits_at_depth ~depth = Int.shift_left 30 depth
let range_at_depth ~depth = shift_left one (bits_at_depth ~depth)
let rec choose_bit_depth_for_range_from ~range ~depth =
if range_at_depth ~depth >= range
then depth
else choose_bit_depth_for_range_from ~range ~depth:(Int.succ depth)
;;
let choose_bit_depth_for_range ~range = choose_bit_depth_for_range_from ~range ~depth:0
let rec random_bigint_at_depth ~state ~depth =
if Int.equal depth 0
then of_int (State.bits state)
else (
let prev_depth = Int.pred depth in
let prefix = random_bigint_at_depth ~state ~depth:prev_depth in
let suffix = random_bigint_at_depth ~state ~depth:prev_depth in
bit_or (shift_left prefix (bits_at_depth ~depth:prev_depth)) suffix)
;;
let random_value_is_uniform_in_range ~range ~depth n =
let k = range_at_depth ~depth / range in
n < k * range
;;
let rec large_random_at_depth ~state ~range ~depth =
let result = random_bigint_at_depth ~state ~depth in
if random_value_is_uniform_in_range ~range ~depth result
then result % range
else large_random_at_depth ~state ~range ~depth
;;
let large_random ~state ~range =
let tolerance_factor = of_int 1_000 in
let depth = choose_bit_depth_for_range ~range:(range * tolerance_factor) in
large_random_at_depth ~state ~range ~depth
;;
let random ~state range =
if range <= zero
then
failwithf "Bigint.random: argument %s <= 0" (to_string_hum range) ()
(* Note that it's not safe to do [1 lsl 30] on a 32-bit machine (with 31-bit signed
integers) *)
else if range < shift_left one 30
then of_int (State.int state (to_int_exn range))
else large_random ~state ~range
;;
end
module Random_internal = Make_random (Random.State)
let random ?(state = Random.State.default) range = Random_internal.random ~state range
module For_quickcheck : sig
include Quickcheckable.S_int with type t := t
val gen_negative : t Quickcheck.Generator.t
val gen_positive : t Quickcheck.Generator.t
end = struct
module Generator = Quickcheck.Generator
open Generator.Let_syntax
module Uniform = Make_random (struct
type t = Splittable_random.t
let int t range = Splittable_random.int t ~lo:0 ~hi:(Int.pred range)
let bits t = int t (Int.shift_left 1 30)
end)
let random_uniform ~state lo hi = lo + Uniform.random ~state (succ (hi - lo))
let gen_uniform_incl lower_bound upper_bound =
if lower_bound > upper_bound
then
raise_s
[%message
"Bigint.gen_uniform_incl: bounds are crossed"
(lower_bound : t)
(upper_bound : t)];
Generator.create (fun ~size:_ ~random:state ->
random_uniform ~state lower_bound upper_bound)
;;
let gen_incl lower_bound upper_bound =
Generator.weighted_union
[ 0.05, Generator.return lower_bound
; 0.05, Generator.return upper_bound
; 0.9, gen_uniform_incl lower_bound upper_bound
]
;;
let min_represented_by_n_bits n =
if Int.equal n 0 then zero else shift_left one (Int.pred n)
;;
let max_represented_by_n_bits n = pred (shift_left one n)
let gen_log_uniform_incl lower_bound upper_bound =
if lower_bound < zero || lower_bound > upper_bound
then
raise_s
[%message
"Bigint.gen_log_incl: invalid bounds" (lower_bound : t) (upper_bound : t)];
let min_bits = Z.numbits lower_bound in
let max_bits = Z.numbits upper_bound in
let%bind bits = Int.gen_uniform_incl min_bits max_bits in
gen_uniform_incl
(max lower_bound (min_represented_by_n_bits bits))
(min upper_bound (max_represented_by_n_bits bits))
;;
let gen_log_incl lower_bound upper_bound =
Generator.weighted_union
[ 0.05, Generator.return lower_bound
; 0.05, Generator.return upper_bound
; 0.9, gen_log_uniform_incl lower_bound upper_bound
]
;;
let gen_positive =
let%bind extra_bytes = Generator.size in
let num_bytes = Int.succ extra_bytes in
let num_bits = Int.( * ) num_bytes 8 in
gen_log_uniform_incl one (pred (shift_left one num_bits))
;;
let gen_negative = Generator.map gen_positive ~f:neg
let quickcheck_generator =
Generator.weighted_union
[ 0.45, gen_positive; 0.1, Generator.return zero; 0.45, gen_negative ]
;;
let quickcheck_observer =
Quickcheck.Observer.create (fun t ~size:_ ~hash -> hash_fold_t hash t)
;;
let quickcheck_shrinker = Quickcheck.Shrinker.empty ()
end
include For_quickcheck
module Hex = struct
type nonrec t = t [@@deriving bin_io, typerep]
module M = Base.Int_conversions.Make_hex (struct
type nonrec t = t [@@deriving hash, compare ~localize]
let to_string i = Z.format "%x" i
let of_hex_string str = Z.of_string_base 16 str
let of_string str = of_string_base str ~name:"Hex.of_string" ~of_string:of_hex_string
let ( < ) = ( < )
let neg = neg
let zero = zero
let module_name = module_name ^ ".Hex"
end)
include (
M.Hex :
module type of struct
include M.Hex
end
with type t := t)
end
module Binary = struct
type nonrec t = t [@@deriving bin_io, compare ~localize, hash, typerep]
let to_string t = Z.format "%#b" t
let chars_per_delimiter = 4
let to_string_hum ?(delimiter = '_') t =
let input = Z.format "%b" t in
"0b" ^ Int_conversions.insert_delimiter_every input ~delimiter ~chars_per_delimiter
;;
let sexp_of_t t : Sexp.t = Atom (to_string t)
end