forked from ocaml/ocaml
-
Notifications
You must be signed in to change notification settings - Fork 0
/
array.ml
495 lines (445 loc) · 13.2 KB
/
array.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
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 1996 Institut National de Recherche en Informatique et *)
(* en Automatique. *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
(* An alias for the type of arrays. *)
type 'a t = 'a array
(* Array operations *)
external length : 'a array -> int = "%array_length"
external get: 'a array -> int -> 'a = "%array_safe_get"
external set: 'a array -> int -> 'a -> unit = "%array_safe_set"
external unsafe_get: 'a array -> int -> 'a = "%array_unsafe_get"
external unsafe_set: 'a array -> int -> 'a -> unit = "%array_unsafe_set"
external make: int -> 'a -> 'a array = "caml_array_make"
external create: int -> 'a -> 'a array = "caml_array_make"
external unsafe_sub : 'a array -> int -> int -> 'a array = "caml_array_sub"
external append_prim : 'a array -> 'a array -> 'a array = "caml_array_append"
external concat : 'a array list -> 'a array = "caml_array_concat"
external unsafe_blit :
'a array -> int -> 'a array -> int -> int -> unit = "caml_array_blit"
external unsafe_fill :
'a array -> int -> int -> 'a -> unit = "caml_array_fill"
external create_float: int -> float array = "caml_array_create_float"
module Floatarray = struct
external create : int -> floatarray = "caml_floatarray_create"
external length : floatarray -> int = "%floatarray_length"
external get : floatarray -> int -> float = "%floatarray_safe_get"
external set : floatarray -> int -> float -> unit = "%floatarray_safe_set"
external unsafe_get : floatarray -> int -> float = "%floatarray_unsafe_get"
external unsafe_set : floatarray -> int -> float -> unit
= "%floatarray_unsafe_set"
end
let init l f =
if l = 0 then [||] else
if l < 0 then invalid_arg "Array.init"
(* See #6575. We must not evaluate [f 0] when [l <= 0].
We could also check for maximum array size, but this depends
on whether we create a float array or a regular one... *)
else
let res = create l (f 0) in
for i = 1 to pred l do
unsafe_set res i (f i)
done;
res
let make_matrix sx sy init =
(* We raise even if [sx = 0 && sy < 0]: *)
if sy < 0 then invalid_arg "Array.make_matrix";
let res = create sx [||] in
if sy > 0 then begin
for x = 0 to pred sx do
unsafe_set res x (create sy init)
done;
end;
res
let init_matrix sx sy f =
(* We raise even if [sx = 0 && sy < 0]: *)
if sy < 0 then invalid_arg "Array.init_matrix";
let res = create sx [||] in
(* We must not evaluate [f x 0] when [sy <= 0]: *)
if sy > 0 then begin
for x = 0 to pred sx do
let row = create sy (f x 0) in
for y = 1 to pred sy do
unsafe_set row y (f x y)
done;
unsafe_set res x row
done;
end;
res
let copy a =
let l = length a in if l = 0 then [||] else unsafe_sub a 0 l
let append a1 a2 =
let l1 = length a1 in
if l1 = 0 then copy a2
else if length a2 = 0 then unsafe_sub a1 0 l1
else append_prim a1 a2
let sub a ofs len =
if ofs < 0 || len < 0 || ofs > length a - len
then invalid_arg "Array.sub"
else unsafe_sub a ofs len
let fill a ofs len v =
if ofs < 0 || len < 0 || ofs > length a - len
then invalid_arg "Array.fill"
else unsafe_fill a ofs len v
let blit a1 ofs1 a2 ofs2 len =
if len < 0 || ofs1 < 0 || ofs1 > length a1 - len
|| ofs2 < 0 || ofs2 > length a2 - len
then invalid_arg "Array.blit"
else unsafe_blit a1 ofs1 a2 ofs2 len
let iter f a =
for i = 0 to length a - 1 do f(unsafe_get a i) done
let iter2 f a b =
if length a <> length b then
invalid_arg "Array.iter2: arrays must have the same length"
else
for i = 0 to length a - 1 do f (unsafe_get a i) (unsafe_get b i) done
let map f a =
let l = length a in
if l = 0 then [||] else begin
let r = create l (f(unsafe_get a 0)) in
for i = 1 to l - 1 do
unsafe_set r i (f(unsafe_get a i))
done;
r
end
let map_inplace f a =
for i = 0 to length a - 1 do
unsafe_set a i (f (unsafe_get a i))
done
let mapi_inplace f a =
for i = 0 to length a - 1 do
unsafe_set a i (f i (unsafe_get a i))
done
let map2 f a b =
let la = length a in
let lb = length b in
if la <> lb then
invalid_arg "Array.map2: arrays must have the same length"
else begin
if la = 0 then [||] else begin
let r = create la (f (unsafe_get a 0) (unsafe_get b 0)) in
for i = 1 to la - 1 do
unsafe_set r i (f (unsafe_get a i) (unsafe_get b i))
done;
r
end
end
let iteri f a =
for i = 0 to length a - 1 do f i (unsafe_get a i) done
let mapi f a =
let l = length a in
if l = 0 then [||] else begin
let r = create l (f 0 (unsafe_get a 0)) in
for i = 1 to l - 1 do
unsafe_set r i (f i (unsafe_get a i))
done;
r
end
let to_list a =
let rec tolist i res =
if i < 0 then res else tolist (i - 1) (unsafe_get a i :: res) in
tolist (length a - 1) []
(* Cannot use List.length here because the List module depends on Array. *)
let rec list_length accu = function
| [] -> accu
| _::t -> list_length (succ accu) t
let of_list = function
[] -> [||]
| hd::tl as l ->
let a = create (list_length 0 l) hd in
let rec fill i = function
[] -> a
| hd::tl -> unsafe_set a i hd; fill (i+1) tl in
fill 1 tl
let fold_left f x a =
let r = ref x in
for i = 0 to length a - 1 do
r := f !r (unsafe_get a i)
done;
!r
let fold_left_map f acc input_array =
let len = length input_array in
if len = 0 then (acc, [||]) else begin
let acc, elt = f acc (unsafe_get input_array 0) in
let output_array = create len elt in
let acc = ref acc in
for i = 1 to len - 1 do
let acc', elt = f !acc (unsafe_get input_array i) in
acc := acc';
unsafe_set output_array i elt;
done;
!acc, output_array
end
let fold_right f a x =
let r = ref x in
for i = length a - 1 downto 0 do
r := f (unsafe_get a i) !r
done;
!r
let exists p a =
let n = length a in
let rec loop i =
if i = n then false
else if p (unsafe_get a i) then true
else loop (succ i) in
loop 0
let for_all p a =
let n = length a in
let rec loop i =
if i = n then true
else if p (unsafe_get a i) then loop (succ i)
else false in
loop 0
let for_all2 p l1 l2 =
let n1 = length l1
and n2 = length l2 in
if n1 <> n2 then invalid_arg "Array.for_all2"
else let rec loop i =
if i = n1 then true
else if p (unsafe_get l1 i) (unsafe_get l2 i) then loop (succ i)
else false in
loop 0
let exists2 p l1 l2 =
let n1 = length l1
and n2 = length l2 in
if n1 <> n2 then invalid_arg "Array.exists2"
else let rec loop i =
if i = n1 then false
else if p (unsafe_get l1 i) (unsafe_get l2 i) then true
else loop (succ i) in
loop 0
let mem x a =
let n = length a in
let rec loop i =
if i = n then false
else if compare (unsafe_get a i) x = 0 then true
else loop (succ i) in
loop 0
let memq x a =
let n = length a in
let rec loop i =
if i = n then false
else if x == (unsafe_get a i) then true
else loop (succ i) in
loop 0
let find_opt p a =
let n = length a in
let rec loop i =
if i = n then None
else
let x = unsafe_get a i in
if p x then Some x
else loop (succ i)
in
loop 0
let find_index p a =
let n = length a in
let rec loop i =
if i = n then None
else if p (unsafe_get a i) then Some i
else loop (succ i) in
loop 0
let find_map f a =
let n = length a in
let rec loop i =
if i = n then None
else
match f (unsafe_get a i) with
| None -> loop (succ i)
| Some _ as r -> r
in
loop 0
let find_mapi f a =
let n = length a in
let rec loop i =
if i = n then None
else
match f i (unsafe_get a i) with
| None -> loop (succ i)
| Some _ as r -> r
in
loop 0
let split x =
if x = [||] then [||], [||]
else begin
let a0, b0 = unsafe_get x 0 in
let n = length x in
let a = create n a0 in
let b = create n b0 in
for i = 1 to n - 1 do
let ai, bi = unsafe_get x i in
unsafe_set a i ai;
unsafe_set b i bi
done;
a, b
end
let combine a b =
let na = length a in
let nb = length b in
if na <> nb then invalid_arg "Array.combine";
if na = 0 then [||]
else begin
let x = create na (unsafe_get a 0, unsafe_get b 0) in
for i = 1 to na - 1 do
unsafe_set x i (unsafe_get a i, unsafe_get b i)
done;
x
end
exception Bottom of int
let sort cmp a =
let maxson l i =
let i31 = i+i+i+1 in
let x = ref i31 in
if i31+2 < l then begin
if cmp (get a i31) (get a (i31+1)) < 0 then x := i31+1;
if cmp (get a !x) (get a (i31+2)) < 0 then x := i31+2;
!x
end else
if i31+1 < l && cmp (get a i31) (get a (i31+1)) < 0
then i31+1
else if i31 < l then i31 else raise (Bottom i)
in
let rec trickledown l i e =
let j = maxson l i in
if cmp (get a j) e > 0 then begin
set a i (get a j);
trickledown l j e;
end else begin
set a i e;
end;
in
let trickle l i e = try trickledown l i e with Bottom i -> set a i e in
let rec bubbledown l i =
let j = maxson l i in
set a i (get a j);
bubbledown l j
in
let bubble l i = try bubbledown l i with Bottom i -> i in
let rec trickleup i e =
let father = (i - 1) / 3 in
assert (i <> father);
if cmp (get a father) e < 0 then begin
set a i (get a father);
if father > 0 then trickleup father e else set a 0 e;
end else begin
set a i e;
end;
in
let l = length a in
for i = (l + 1) / 3 - 1 downto 0 do trickle l i (get a i); done;
for i = l - 1 downto 2 do
let e = (get a i) in
set a i (get a 0);
trickleup (bubble i 0) e;
done;
if l > 1 then (let e = (get a 1) in set a 1 (get a 0); set a 0 e)
let cutoff = 5
let stable_sort cmp a =
let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
let src1r = src1ofs + src1len and src2r = src2ofs + src2len in
let rec loop i1 s1 i2 s2 d =
if cmp s1 s2 <= 0 then begin
set dst d s1;
let i1 = i1 + 1 in
if i1 < src1r then
loop i1 (get a i1) i2 s2 (d + 1)
else
blit src2 i2 dst (d + 1) (src2r - i2)
end else begin
set dst d s2;
let i2 = i2 + 1 in
if i2 < src2r then
loop i1 s1 i2 (get src2 i2) (d + 1)
else
blit a i1 dst (d + 1) (src1r - i1)
end
in loop src1ofs (get a src1ofs) src2ofs (get src2 src2ofs) dstofs;
in
let isortto srcofs dst dstofs len =
for i = 0 to len - 1 do
let e = (get a (srcofs + i)) in
let j = ref (dstofs + i - 1) in
while (!j >= dstofs && cmp (get dst !j) e > 0) do
set dst (!j + 1) (get dst !j);
decr j;
done;
set dst (!j + 1) e;
done;
in
let rec sortto srcofs dst dstofs len =
if len <= cutoff then isortto srcofs dst dstofs len else begin
let l1 = len / 2 in
let l2 = len - l1 in
sortto (srcofs + l1) dst (dstofs + l1) l2;
sortto srcofs a (srcofs + l2) l1;
merge (srcofs + l2) l1 dst (dstofs + l1) l2 dst dstofs;
end;
in
let l = length a in
if l <= cutoff then isortto 0 a 0 l else begin
let l1 = l / 2 in
let l2 = l - l1 in
let t = make l2 (get a 0) in
sortto l1 t 0 l2;
sortto 0 a l2 l1;
merge l2 l1 t 0 l2 a 0;
end
let fast_sort = stable_sort
let shuffle_contract_violation i j =
let int = string_of_int in
String.concat "" [
"Array.shuffle: 'rand "; int (i + 1);
"' returned "; int j;
", out of expected range [0; "; int i; "]"
]
|> invalid_arg
let shuffle ~rand a = (* Fisher-Yates *)
for i = length a - 1 downto 1 do
let j = rand (i + 1) in
if not (0 <= j && j <= i) then shuffle_contract_violation i j;
let v = unsafe_get a i in
unsafe_set a i (unsafe_get a j);
unsafe_set a j v
done
(** {1 Iterators} *)
let to_seq a =
let rec aux i () =
if i < length a
then
let x = unsafe_get a i in
Seq.Cons (x, aux (i+1))
else Seq.Nil
in
aux 0
let to_seqi a =
let rec aux i () =
if i < length a
then
let x = unsafe_get a i in
Seq.Cons ((i,x), aux (i+1))
else Seq.Nil
in
aux 0
let of_rev_list = function
[] -> [||]
| hd::tl as l ->
let len = list_length 0 l in
let a = create len hd in
let rec fill i = function
[] -> a
| hd::tl -> unsafe_set a i hd; fill (i-1) tl
in
fill (len-2) tl
let of_seq i =
let l = Seq.fold_left (fun acc x -> x::acc) [] i in
of_rev_list l