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