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(* Array operations *)
17
18external length : 'a array -> int = "%array_length"
19external get: 'a array -> int -> 'a = "%array_safe_get"
20external set: 'a array -> int -> 'a -> unit = "%array_safe_set"
21external unsafe_get: 'a array -> int -> 'a = "%array_unsafe_get"
22external unsafe_set: 'a array -> int -> 'a -> unit = "%array_unsafe_set"
23external make: int -> 'a -> 'a array = "caml_make_vect"
24external create: int -> 'a -> 'a array = "caml_make_vect"
25external unsafe_sub : 'a array -> int -> int -> 'a array = "caml_array_sub"
26external append_prim : 'a array -> 'a array -> 'a array = "caml_array_append"
27external concat : 'a array list -> 'a array = "caml_array_concat"
28external unsafe_blit :
29  'a array -> int -> 'a array -> int -> int -> unit = "caml_array_blit"
30external create_float: int -> float array = "caml_make_float_vect"
31let make_float = create_float
32
33let init l f =
34  if l = 0 then [||] else
35  if l < 0 then invalid_arg "Array.init"
36  (* See #6575. We could also check for maximum array size, but this depends
37     on whether we create a float array or a regular one... *)
38  else
39   let res = create l (f 0) in
40   for i = 1 to pred l do
41     unsafe_set res i (f i)
42   done;
43   res
44
45let make_matrix sx sy init =
46  let res = create sx [||] in
47  for x = 0 to pred sx do
48    unsafe_set res x (create sy init)
49  done;
50  res
51
52let create_matrix = make_matrix
53
54let copy a =
55  let l = length a in if l = 0 then [||] else unsafe_sub a 0 l
56
57let append a1 a2 =
58  let l1 = length a1 in
59  if l1 = 0 then copy a2
60  else if length a2 = 0 then unsafe_sub a1 0 l1
61  else append_prim a1 a2
62
63let sub a ofs len =
64  if ofs < 0 || len < 0 || ofs > length a - len
65  then invalid_arg "Array.sub"
66  else unsafe_sub a ofs len
67
68let fill a ofs len v =
69  if ofs < 0 || len < 0 || ofs > length a - len
70  then invalid_arg "Array.fill"
71  else for i = ofs to ofs + len - 1 do unsafe_set a i v done
72
73let blit a1 ofs1 a2 ofs2 len =
74  if len < 0 || ofs1 < 0 || ofs1 > length a1 - len
75             || ofs2 < 0 || ofs2 > length a2 - len
76  then invalid_arg "Array.blit"
77  else unsafe_blit a1 ofs1 a2 ofs2 len
78
79let iter f a =
80  for i = 0 to length a - 1 do f(unsafe_get a i) done
81
82let iter2 f a b =
83  if length a <> length b then
84    invalid_arg "Array.iter2: arrays must have the same length"
85  else
86    for i = 0 to length a - 1 do f (unsafe_get a i) (unsafe_get b i) done
87
88let map f a =
89  let l = length a in
90  if l = 0 then [||] else begin
91    let r = create l (f(unsafe_get a 0)) in
92    for i = 1 to l - 1 do
93      unsafe_set r i (f(unsafe_get a i))
94    done;
95    r
96  end
97
98let map2 f a b =
99  let la = length a in
100  let lb = length b in
101  if la <> lb then
102    invalid_arg "Array.map2: arrays must have the same length"
103  else begin
104    if la = 0 then [||] else begin
105      let r = create la (f (unsafe_get a 0) (unsafe_get b 0)) in
106      for i = 1 to la - 1 do
107        unsafe_set r i (f (unsafe_get a i) (unsafe_get b i))
108      done;
109      r
110    end
111  end
112
113let iteri f a =
114  for i = 0 to length a - 1 do f i (unsafe_get a i) done
115
116let mapi f a =
117  let l = length a in
118  if l = 0 then [||] else begin
119    let r = create l (f 0 (unsafe_get a 0)) in
120    for i = 1 to l - 1 do
121      unsafe_set r i (f i (unsafe_get a i))
122    done;
123    r
124  end
125
126let to_list a =
127  let rec tolist i res =
128    if i < 0 then res else tolist (i - 1) (unsafe_get a i :: res) in
129  tolist (length a - 1) []
130
131(* Cannot use List.length here because the List module depends on Array. *)
132let rec list_length accu = function
133  | [] -> accu
134  | _::t -> list_length (succ accu) t
135
136let of_list = function
137    [] -> [||]
138  | hd::tl as l ->
139      let a = create (list_length 0 l) hd in
140      let rec fill i = function
141          [] -> a
142        | hd::tl -> unsafe_set a i hd; fill (i+1) tl in
143      fill 1 tl
144
145let fold_left f x a =
146  let r = ref x in
147  for i = 0 to length a - 1 do
148    r := f !r (unsafe_get a i)
149  done;
150  !r
151
152let fold_right f a x =
153  let r = ref x in
154  for i = length a - 1 downto 0 do
155    r := f (unsafe_get a i) !r
156  done;
157  !r
158
159let exists p a =
160  let n = length a in
161  let rec loop i =
162    if i = n then false
163    else if p (unsafe_get a i) then true
164    else loop (succ i) in
165  loop 0
166
167let for_all p a =
168  let n = length a in
169  let rec loop i =
170    if i = n then true
171    else if p (unsafe_get a i) then loop (succ i)
172    else false in
173  loop 0
174
175let mem x a =
176  let n = length a in
177  let rec loop i =
178    if i = n then false
179    else if compare (unsafe_get a i) x = 0 then true
180    else loop (succ i) in
181  loop 0
182
183let memq x a =
184  let n = length a in
185  let rec loop i =
186    if i = n then false
187    else if x == (unsafe_get a i) then true
188    else loop (succ i) in
189  loop 0
190
191exception Bottom of int
192let sort cmp a =
193  let maxson l i =
194    let i31 = i+i+i+1 in
195    let x = ref i31 in
196    if i31+2 < l then begin
197      if cmp (get a i31) (get a (i31+1)) < 0 then x := i31+1;
198      if cmp (get a !x) (get a (i31+2)) < 0 then x := i31+2;
199      !x
200    end else
201      if i31+1 < l && cmp (get a i31) (get a (i31+1)) < 0
202      then i31+1
203      else if i31 < l then i31 else raise (Bottom i)
204  in
205  let rec trickledown l i e =
206    let j = maxson l i in
207    if cmp (get a j) e > 0 then begin
208      set a i (get a j);
209      trickledown l j e;
210    end else begin
211      set a i e;
212    end;
213  in
214  let trickle l i e = try trickledown l i e with Bottom i -> set a i e in
215  let rec bubbledown l i =
216    let j = maxson l i in
217    set a i (get a j);
218    bubbledown l j
219  in
220  let bubble l i = try bubbledown l i with Bottom i -> i in
221  let rec trickleup i e =
222    let father = (i - 1) / 3 in
223    assert (i <> father);
224    if cmp (get a father) e < 0 then begin
225      set a i (get a father);
226      if father > 0 then trickleup father e else set a 0 e;
227    end else begin
228      set a i e;
229    end;
230  in
231  let l = length a in
232  for i = (l + 1) / 3 - 1 downto 0 do trickle l i (get a i); done;
233  for i = l - 1 downto 2 do
234    let e = (get a i) in
235    set a i (get a 0);
236    trickleup (bubble i 0) e;
237  done;
238  if l > 1 then (let e = (get a 1) in set a 1 (get a 0); set a 0 e)
239
240
241let cutoff = 5
242let stable_sort cmp a =
243  let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
244    let src1r = src1ofs + src1len and src2r = src2ofs + src2len in
245    let rec loop i1 s1 i2 s2 d =
246      if cmp s1 s2 <= 0 then begin
247        set dst d s1;
248        let i1 = i1 + 1 in
249        if i1 < src1r then
250          loop i1 (get a i1) i2 s2 (d + 1)
251        else
252          blit src2 i2 dst (d + 1) (src2r - i2)
253      end else begin
254        set dst d s2;
255        let i2 = i2 + 1 in
256        if i2 < src2r then
257          loop i1 s1 i2 (get src2 i2) (d + 1)
258        else
259          blit a i1 dst (d + 1) (src1r - i1)
260      end
261    in loop src1ofs (get a src1ofs) src2ofs (get src2 src2ofs) dstofs;
262  in
263  let isortto srcofs dst dstofs len =
264    for i = 0 to len - 1 do
265      let e = (get a (srcofs + i)) in
266      let j = ref (dstofs + i - 1) in
267      while (!j >= dstofs && cmp (get dst !j) e > 0) do
268        set dst (!j + 1) (get dst !j);
269        decr j;
270      done;
271      set dst (!j + 1) e;
272    done;
273  in
274  let rec sortto srcofs dst dstofs len =
275    if len <= cutoff then isortto srcofs dst dstofs len else begin
276      let l1 = len / 2 in
277      let l2 = len - l1 in
278      sortto (srcofs + l1) dst (dstofs + l1) l2;
279      sortto srcofs a (srcofs + l2) l1;
280      merge (srcofs + l2) l1 dst (dstofs + l1) l2 dst dstofs;
281    end;
282  in
283  let l = length a in
284  if l <= cutoff then isortto 0 a 0 l else begin
285    let l1 = l / 2 in
286    let l2 = l - l1 in
287    let t = make l2 (get a 0) in
288    sortto l1 t 0 l2;
289    sortto 0 a l2 l1;
290    merge l2 l1 t 0 l2 a 0;
291  end
292
293
294let fast_sort = stable_sort
295