anil.recoil.org
My working unpac repository
1(**************************************************************************)
2(* *)
3(* OCaml *)
4(* *)
5(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
6(* *)
7(* Copyright 1996 Institut National de Recherche en Informatique et *)
8(* en Automatique. *)
9(* *)
10(* All rights reserved. This file is distributed under the terms of *)
11(* the GNU Lesser General Public License version 2.1, with the *)
12(* special exception on linking described in the file LICENSE. *)
13(* *)
14(**************************************************************************)
15
16(* An alias for the type of arrays. *)
17type 'a t = 'a array
18
19(* Array operations *)
20
21external length : 'a array -> int = "%array_length"
22external get: 'a array -> int -> 'a = "%array_safe_get"
23external set: 'a array -> int -> 'a -> unit = "%array_safe_set"
24external unsafe_get: 'a array -> int -> 'a = "%array_unsafe_get"
25external unsafe_set: 'a array -> int -> 'a -> unit = "%array_unsafe_set"
26external make: int -> 'a -> 'a array = "caml_array_make"
27external create: int -> 'a -> 'a array = "caml_array_make"
28external unsafe_sub : 'a array -> int -> int -> 'a array = "caml_array_sub"
29external append_prim : 'a array -> 'a array -> 'a array = "caml_array_append"
30external concat : 'a array list -> 'a array = "caml_array_concat"
31external unsafe_blit :
32 'a array -> int -> 'a array -> int -> int -> unit = "caml_array_blit"
33external unsafe_fill :
34 'a array -> int -> int -> 'a -> unit = "caml_array_fill"
35external create_float: int -> float array = "caml_array_create_float"
36
37module Floatarray = struct
38 external create : int -> floatarray = "caml_floatarray_create"
39 external length : floatarray -> int = "%floatarray_length"
40 external get : floatarray -> int -> float = "%floatarray_safe_get"
41 external set : floatarray -> int -> float -> unit = "%floatarray_safe_set"
42 external unsafe_get : floatarray -> int -> float = "%floatarray_unsafe_get"
43 external unsafe_set : floatarray -> int -> float -> unit
44 = "%floatarray_unsafe_set"
45end
46
47let init l f =
48 if l = 0 then [||] else
49 if l < 0 then invalid_arg "Array.init"
50 (* See #6575. We must not evaluate [f 0] when [l <= 0].
51 We could also check for maximum array size, but this depends
52 on whether we create a float array or a regular one... *)
53 else
54 let res = create l (f 0) in
55 for i = 1 to pred l do
56 unsafe_set res i (f i)
57 done;
58 res
59
60let make_matrix sx sy init =
61 (* We raise even if [sx = 0 && sy < 0]: *)
62 if sy < 0 then invalid_arg "Array.make_matrix";
63 let res = create sx [||] in
64 if sy > 0 then begin
65 for x = 0 to pred sx do
66 unsafe_set res x (create sy init)
67 done;
68 end;
69 res
70
71let init_matrix sx sy f =
72 (* We raise even if [sx = 0 && sy < 0]: *)
73 if sy < 0 then invalid_arg "Array.init_matrix";
74 let res = create sx [||] in
75 (* We must not evaluate [f x 0] when [sy <= 0]: *)
76 if sy > 0 then begin
77 for x = 0 to pred sx do
78 let row = create sy (f x 0) in
79 for y = 1 to pred sy do
80 unsafe_set row y (f x y)
81 done;
82 unsafe_set res x row
83 done;
84 end;
85 res
86
87let copy a =
88 let l = length a in if l = 0 then [||] else unsafe_sub a 0 l
89
90let append a1 a2 =
91 let l1 = length a1 in
92 if l1 = 0 then copy a2
93 else if length a2 = 0 then unsafe_sub a1 0 l1
94 else append_prim a1 a2
95
96let sub a ofs len =
97 if ofs < 0 || len < 0 || ofs > length a - len
98 then invalid_arg "Array.sub"
99 else unsafe_sub a ofs len
100
101let fill a ofs len v =
102 if ofs < 0 || len < 0 || ofs > length a - len
103 then invalid_arg "Array.fill"
104 else unsafe_fill a ofs len v
105
106let blit a1 ofs1 a2 ofs2 len =
107 if len < 0 || ofs1 < 0 || ofs1 > length a1 - len
108 || ofs2 < 0 || ofs2 > length a2 - len
109 then invalid_arg "Array.blit"
110 else unsafe_blit a1 ofs1 a2 ofs2 len
111
112let iter f a =
113 for i = 0 to length a - 1 do f(unsafe_get a i) done
114
115let iter2 f a b =
116 if length a <> length b then
117 invalid_arg "Array.iter2: arrays must have the same length"
118 else
119 for i = 0 to length a - 1 do f (unsafe_get a i) (unsafe_get b i) done
120
121let map f a =
122 let l = length a in
123 if l = 0 then [||] else begin
124 let r = create l (f(unsafe_get a 0)) in
125 for i = 1 to l - 1 do
126 unsafe_set r i (f(unsafe_get a i))
127 done;
128 r
129 end
130
131let map_inplace f a =
132 for i = 0 to length a - 1 do
133 unsafe_set a i (f (unsafe_get a i))
134 done
135
136let mapi_inplace f a =
137 for i = 0 to length a - 1 do
138 unsafe_set a i (f i (unsafe_get a i))
139 done
140
141let map2 f a b =
142 let la = length a in
143 let lb = length b in
144 if la <> lb then
145 invalid_arg "Array.map2: arrays must have the same length"
146 else begin
147 if la = 0 then [||] else begin
148 let r = create la (f (unsafe_get a 0) (unsafe_get b 0)) in
149 for i = 1 to la - 1 do
150 unsafe_set r i (f (unsafe_get a i) (unsafe_get b i))
151 done;
152 r
153 end
154 end
155
156let iteri f a =
157 for i = 0 to length a - 1 do f i (unsafe_get a i) done
158
159let mapi f a =
160 let l = length a in
161 if l = 0 then [||] else begin
162 let r = create l (f 0 (unsafe_get a 0)) in
163 for i = 1 to l - 1 do
164 unsafe_set r i (f i (unsafe_get a i))
165 done;
166 r
167 end
168
169let to_list a =
170 let rec tolist i res =
171 if i < 0 then res else tolist (i - 1) (unsafe_get a i :: res) in
172 tolist (length a - 1) []
173
174(* Cannot use List.length here because the List module depends on Array. *)
175let rec list_length accu = function
176 | [] -> accu
177 | _::t -> list_length (succ accu) t
178
179let of_list = function
180 [] -> [||]
181 | hd::tl as l ->
182 let a = create (list_length 0 l) hd in
183 let rec fill i = function
184 [] -> a
185 | hd::tl -> unsafe_set a i hd; fill (i+1) tl in
186 fill 1 tl
187
188let equal eq a b =
189 if length a <> length b then false else
190 let i = ref 0 in
191 let len = length a in
192 while !i < len && eq (unsafe_get a !i) (unsafe_get b !i) do incr i done;
193 !i = len
194
195let stdlib_compare = compare
196let compare cmp a b =
197 let len_a = length a and len_b = length b in
198 let diff = len_a - len_b in
199 if diff <> 0 then (if diff < 0 then -1 else 1) else
200 let i = ref 0 and c = ref 0 in
201 while !i < len_a && !c = 0
202 do c := cmp (unsafe_get a !i) (unsafe_get b !i); incr i done;
203 !c
204
205let fold_left f x a =
206 let r = ref x in
207 for i = 0 to length a - 1 do
208 r := f !r (unsafe_get a i)
209 done;
210 !r
211
212let fold_left_map f acc input_array =
213 let len = length input_array in
214 if len = 0 then (acc, [||]) else begin
215 let acc, elt = f acc (unsafe_get input_array 0) in
216 let output_array = create len elt in
217 let acc = ref acc in
218 for i = 1 to len - 1 do
219 let acc', elt = f !acc (unsafe_get input_array i) in
220 acc := acc';
221 unsafe_set output_array i elt;
222 done;
223 !acc, output_array
224 end
225
226let fold_right f a x =
227 let r = ref x in
228 for i = length a - 1 downto 0 do
229 r := f (unsafe_get a i) !r
230 done;
231 !r
232
233let exists p a =
234 let n = length a in
235 let rec loop i =
236 if i = n then false
237 else if p (unsafe_get a i) then true
238 else loop (succ i) in
239 loop 0
240
241let for_all p a =
242 let n = length a in
243 let rec loop i =
244 if i = n then true
245 else if p (unsafe_get a i) then loop (succ i)
246 else false in
247 loop 0
248
249let for_all2 p l1 l2 =
250 let n1 = length l1
251 and n2 = length l2 in
252 if n1 <> n2 then invalid_arg "Array.for_all2"
253 else let rec loop i =
254 if i = n1 then true
255 else if p (unsafe_get l1 i) (unsafe_get l2 i) then loop (succ i)
256 else false in
257 loop 0
258
259let exists2 p l1 l2 =
260 let n1 = length l1
261 and n2 = length l2 in
262 if n1 <> n2 then invalid_arg "Array.exists2"
263 else let rec loop i =
264 if i = n1 then false
265 else if p (unsafe_get l1 i) (unsafe_get l2 i) then true
266 else loop (succ i) in
267 loop 0
268
269let mem x a =
270 let n = length a in
271 let rec loop i =
272 if i = n then false
273 else if stdlib_compare (unsafe_get a i) x = 0 then true
274 else loop (succ i) in
275 loop 0
276
277let memq x a =
278 let n = length a in
279 let rec loop i =
280 if i = n then false
281 else if x == (unsafe_get a i) then true
282 else loop (succ i) in
283 loop 0
284
285let find_opt p a =
286 let n = length a in
287 let rec loop i =
288 if i = n then None
289 else
290 let x = unsafe_get a i in
291 if p x then Some x
292 else loop (succ i)
293 in
294 loop 0
295
296let find_index p a =
297 let n = length a in
298 let rec loop i =
299 if i = n then None
300 else if p (unsafe_get a i) then Some i
301 else loop (succ i) in
302 loop 0
303
304let find_map f a =
305 let n = length a in
306 let rec loop i =
307 if i = n then None
308 else
309 match f (unsafe_get a i) with
310 | None -> loop (succ i)
311 | Some _ as r -> r
312 in
313 loop 0
314
315let find_mapi f a =
316 let n = length a in
317 let rec loop i =
318 if i = n then None
319 else
320 match f i (unsafe_get a i) with
321 | None -> loop (succ i)
322 | Some _ as r -> r
323 in
324 loop 0
325
326let split x =
327 if x = [||] then [||], [||]
328 else begin
329 let a0, b0 = unsafe_get x 0 in
330 let n = length x in
331 let a = create n a0 in
332 let b = create n b0 in
333 for i = 1 to n - 1 do
334 let ai, bi = unsafe_get x i in
335 unsafe_set a i ai;
336 unsafe_set b i bi
337 done;
338 a, b
339 end
340
341let combine a b =
342 let na = length a in
343 let nb = length b in
344 if na <> nb then invalid_arg "Array.combine";
345 if na = 0 then [||]
346 else begin
347 let x = create na (unsafe_get a 0, unsafe_get b 0) in
348 for i = 1 to na - 1 do
349 unsafe_set x i (unsafe_get a i, unsafe_get b i)
350 done;
351 x
352 end
353
354exception Bottom of int
355let sort cmp a =
356 let maxson l i =
357 let i31 = i+i+i+1 in
358 let x = ref i31 in
359 if i31+2 < l then begin
360 if cmp (get a i31) (get a (i31+1)) < 0 then x := i31+1;
361 if cmp (get a !x) (get a (i31+2)) < 0 then x := i31+2;
362 !x
363 end else
364 if i31+1 < l && cmp (get a i31) (get a (i31+1)) < 0
365 then i31+1
366 else if i31 < l then i31 else raise (Bottom i)
367 in
368 let rec trickledown l i e =
369 let j = maxson l i in
370 if cmp (get a j) e > 0 then begin
371 set a i (get a j);
372 trickledown l j e;
373 end else begin
374 set a i e;
375 end;
376 in
377 let trickle l i e = try trickledown l i e with Bottom i -> set a i e in
378 let rec bubbledown l i =
379 let j = maxson l i in
380 set a i (get a j);
381 bubbledown l j
382 in
383 let bubble l i = try bubbledown l i with Bottom i -> i in
384 let rec trickleup i e =
385 let father = (i - 1) / 3 in
386 assert (i <> father);
387 if cmp (get a father) e < 0 then begin
388 set a i (get a father);
389 if father > 0 then trickleup father e else set a 0 e;
390 end else begin
391 set a i e;
392 end;
393 in
394 let l = length a in
395 for i = (l + 1) / 3 - 1 downto 0 do trickle l i (get a i); done;
396 for i = l - 1 downto 2 do
397 let e = (get a i) in
398 set a i (get a 0);
399 trickleup (bubble i 0) e;
400 done;
401 if l > 1 then (let e = (get a 1) in set a 1 (get a 0); set a 0 e)
402
403
404let cutoff = 5
405let stable_sort cmp a =
406 let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
407 let src1r = src1ofs + src1len and src2r = src2ofs + src2len in
408 let rec loop i1 s1 i2 s2 d =
409 if cmp s1 s2 <= 0 then begin
410 set dst d s1;
411 let i1 = i1 + 1 in
412 if i1 < src1r then
413 loop i1 (get a i1) i2 s2 (d + 1)
414 else
415 blit src2 i2 dst (d + 1) (src2r - i2)
416 end else begin
417 set dst d s2;
418 let i2 = i2 + 1 in
419 if i2 < src2r then
420 loop i1 s1 i2 (get src2 i2) (d + 1)
421 else
422 blit a i1 dst (d + 1) (src1r - i1)
423 end
424 in loop src1ofs (get a src1ofs) src2ofs (get src2 src2ofs) dstofs;
425 in
426 let isortto srcofs dst dstofs len =
427 for i = 0 to len - 1 do
428 let e = (get a (srcofs + i)) in
429 let j = ref (dstofs + i - 1) in
430 while (!j >= dstofs && cmp (get dst !j) e > 0) do
431 set dst (!j + 1) (get dst !j);
432 decr j;
433 done;
434 set dst (!j + 1) e;
435 done;
436 in
437 let rec sortto srcofs dst dstofs len =
438 if len <= cutoff then isortto srcofs dst dstofs len else begin
439 let l1 = len / 2 in
440 let l2 = len - l1 in
441 sortto (srcofs + l1) dst (dstofs + l1) l2;
442 sortto srcofs a (srcofs + l2) l1;
443 merge (srcofs + l2) l1 dst (dstofs + l1) l2 dst dstofs;
444 end;
445 in
446 let l = length a in
447 if l <= cutoff then isortto 0 a 0 l else begin
448 let l1 = l / 2 in
449 let l2 = l - l1 in
450 let t = make l2 (get a 0) in
451 sortto l1 t 0 l2;
452 sortto 0 a l2 l1;
453 merge l2 l1 t 0 l2 a 0;
454 end
455
456
457let fast_sort = stable_sort
458
459let shuffle_contract_violation i j =
460 let int = string_of_int in
461 invalid_arg
462 ("Array.shuffle: 'rand " ^ int (i + 1) ^
463 "' returned " ^ int j ^
464 ", out of expected range [0; " ^ int i ^ "]")
465
466let shuffle ~rand a = (* Fisher-Yates *)
467 for i = length a - 1 downto 1 do
468 let j = rand (i + 1) in
469 if not (0 <= j && j <= i) then shuffle_contract_violation i j;
470 let v = unsafe_get a i in
471 unsafe_set a i (unsafe_get a j);
472 unsafe_set a j v
473 done
474
475(** {1 Iterators} *)
476
477let to_seq a =
478 let rec aux i () =
479 if i < length a
480 then
481 let x = unsafe_get a i in
482 Seq.Cons (x, aux (i+1))
483 else Seq.Nil
484 in
485 aux 0
486
487let to_seqi a =
488 let rec aux i () =
489 if i < length a
490 then
491 let x = unsafe_get a i in
492 Seq.Cons ((i,x), aux (i+1))
493 else Seq.Nil
494 in
495 aux 0
496
497let of_rev_list = function
498 [] -> [||]
499 | hd::tl as l ->
500 let len = list_length 0 l in
501 let a = create len hd in
502 let rec fill i = function
503 [] -> a
504 | hd::tl -> unsafe_set a i hd; fill (i-1) tl
505 in
506 fill (len-2) tl
507
508let of_seq i =
509 let l = Seq.fold_left (fun acc x -> x::acc) [] i in
510 of_rev_list l