l4/pkg/ocaml/ocaml/contrib/stdlib/array.ml

   1 (***********************************************************************)
   2 (*                                                                     *)
   3 (*                           Objective Caml                            *)
   4 (*                                                                     *)
   5 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
   6 (*                                                                     *)
   7 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
   8 (*  en Automatique.  All rights reserved.  This file is distributed    *)
   9 (*  under the terms of the GNU Library General Public License, with    *)
  10 (*  the special exception on linking described in file ../LICENSE.     *)
  11 (*                                                                     *)
  12 (***********************************************************************)
  13
  14 (* $Id: array.ml 6834 2005-04-11 16:44:26Z doligez $ *)
  15
  16 (* Array operations *)
  17
  18 external length : 'a array -> int = "%array_length"
  19 external get: 'a array -> int -> 'a = "%array_safe_get"
  20 external set: 'a array -> int -> 'a -> unit = "%array_safe_set"
  21 external unsafe_get: 'a array -> int -> 'a = "%array_unsafe_get"
  22 external unsafe_set: 'a array -> int -> 'a -> unit = "%array_unsafe_set"
  23 external make: int -> 'a -> 'a array = "caml_make_vect"
  24 external create: int -> 'a -> 'a array = "caml_make_vect"
  25
  26 let init l f =
  27   if l = 0 then [||] else
  28    let res = create l (f 0) in
  29    for i = 1 to pred l do
  30      unsafe_set res i (f i)
  31    done;
  32    res
  33
  34 let make_matrix sx sy init =
  35   let res = create sx [||] in
  36   for x = 0 to pred sx do
  37     unsafe_set res x (create sy init)
  38   done;
  39   res
  40
  41 let create_matrix = make_matrix
  42
  43 let copy a =
  44   let l = length a in
  45   if l = 0 then [||] else begin
  46     let res = create l (unsafe_get a 0) in
  47     for i = 1 to pred l do
  48       unsafe_set res i (unsafe_get a i)
  49     done;
  50     res
  51   end
  52
  53 let append a1 a2 =
  54   let l1 = length a1 and l2 = length a2 in
  55   if l1 = 0 && l2 = 0 then [||] else begin
  56     let r = create (l1 + l2) (unsafe_get (if l1 > 0 then a1 else a2) 0) in
  57     for i = 0 to l1 - 1 do unsafe_set r i (unsafe_get a1 i) done;
  58     for i = 0 to l2 - 1 do unsafe_set r (i + l1) (unsafe_get a2 i) done;
  59     r
  60   end
  61
  62 let concat_aux init al =
  63   let rec size accu = function
  64     | [] -> accu
  65     | h::t -> size (accu + length h) t
  66   in
  67   let res = create (size 0 al) init in
  68   let rec fill pos = function
  69     | [] -> ()
  70     | h::t ->
  71         for i = 0 to length h - 1 do
  72           unsafe_set res (pos + i) (unsafe_get h i);
  73         done;
  74         fill (pos + length h) t;
  75   in
  76   fill 0 al;
  77   res
  78 ;;
  79
  80 let concat al =
  81   let rec find_init = function
  82       [] -> [||]
  83     | a :: rem ->
  84         if length a > 0 then concat_aux (unsafe_get a 0) al else find_init rem
  85   in find_init al
  86
  87 let sub a ofs len =
  88   if ofs < 0 || len < 0 || ofs > length a - len then invalid_arg "Array.sub"
  89   else if len = 0 then [||]
  90   else begin
  91     let r = create len (unsafe_get a ofs) in
  92     for i = 1 to len - 1 do unsafe_set r i (unsafe_get a (ofs + i)) done;
  93     r
  94   end
  95
  96 let fill a ofs len v =
  97   if ofs < 0 || len < 0 || ofs > length a - len
  98   then invalid_arg "Array.fill"
  99   else for i = ofs to ofs + len - 1 do unsafe_set a i v done
 100
 101 let blit a1 ofs1 a2 ofs2 len =
 102   if len < 0 || ofs1 < 0 || ofs1 > length a1 - len
 103              || ofs2 < 0 || ofs2 > length a2 - len
 104   then invalid_arg "Array.blit"
 105   else if ofs1 < ofs2 then
 106     (* Top-down copy *)
 107     for i = len - 1 downto 0 do
 108       unsafe_set a2 (ofs2 + i) (unsafe_get a1 (ofs1 + i))
 109     done
 110   else
 111     (* Bottom-up copy *)
 112     for i = 0 to len - 1 do
 113       unsafe_set a2 (ofs2 + i) (unsafe_get a1 (ofs1 + i))
 114     done
 115
 116 let iter f a =
 117   for i = 0 to length a - 1 do f(unsafe_get a i) done
 118
 119 let map f a =
 120   let l = length a in
 121   if l = 0 then [||] else begin
 122     let r = create l (f(unsafe_get a 0)) in
 123     for i = 1 to l - 1 do
 124       unsafe_set r i (f(unsafe_get a i))
 125     done;
 126     r
 127   end
 128
 129 let iteri f a =
 130   for i = 0 to length a - 1 do f i (unsafe_get a i) done
 131
 132 let mapi f a =
 133   let l = length a in
 134   if l = 0 then [||] else begin
 135     let r = create l (f 0 (unsafe_get a 0)) in
 136     for i = 1 to l - 1 do
 137       unsafe_set r i (f i (unsafe_get a i))
 138     done;
 139     r
 140   end
 141
 142 let to_list a =
 143   let rec tolist i res =
 144     if i < 0 then res else tolist (i - 1) (unsafe_get a i :: res) in
 145   tolist (length a - 1) []
 146
 147 (* Cannot use List.length here because the List module depends on Array. *)
 148 let rec list_length accu = function
 149   | [] -> accu
 150   | h::t -> list_length (succ accu) t
 151 ;;
 152
 153 let of_list = function
 154     [] -> [||]
 155   | hd::tl as l ->
 156       let a = create (list_length 0 l) hd in
 157       let rec fill i = function
 158           [] -> a
 159         | hd::tl -> unsafe_set a i hd; fill (i+1) tl in
 160       fill 1 tl
 161
 162 let fold_left f x a =
 163   let r = ref x in
 164   for i = 0 to length a - 1 do
 165     r := f !r (unsafe_get a i)
 166   done;
 167   !r
 168
 169 let fold_right f a x =
 170   let r = ref x in
 171   for i = length a - 1 downto 0 do
 172     r := f (unsafe_get a i) !r
 173   done;
 174   !r
 175
 176 exception Bottom of int;;
 177 let sort cmp a =
 178   let maxson l i =
 179     let i31 = i+i+i+1 in
 180     let x = ref i31 in
 181     if i31+2 < l then begin
 182       if cmp (get a i31) (get a (i31+1)) < 0 then x := i31+1;
 183       if cmp (get a !x) (get a (i31+2)) < 0 then x := i31+2;
 184       !x
 185     end else
 186       if i31+1 < l && cmp (get a i31) (get a (i31+1)) < 0
 187       then i31+1
 188       else if i31 < l then i31 else raise (Bottom i)
 189   in
 190   let rec trickledown l i e =
 191     let j = maxson l i in
 192     if cmp (get a j) e > 0 then begin
 193       set a i (get a j);
 194       trickledown l j e;
 195     end else begin
 196       set a i e;
 197     end;
 198   in
 199   let rec trickle l i e = try trickledown l i e with Bottom i -> set a i e in
 200   let rec bubbledown l i =
 201     let j = maxson l i in
 202     set a i (get a j);
 203     bubbledown l j
 204   in
 205   let bubble l i = try bubbledown l i with Bottom i -> i in
 206   let rec trickleup i e =
 207     let father = (i - 1) / 3 in
 208     assert (i <> father);
 209     if cmp (get a father) e < 0 then begin
 210       set a i (get a father);
 211       if father > 0 then trickleup father e else set a 0 e;
 212     end else begin
 213       set a i e;
 214     end;
 215   in
 216   let l = length a in
 217   for i = (l + 1) / 3 - 1 downto 0 do trickle l i (get a i); done;
 218   for i = l - 1 downto 2 do
 219     let e = (get a i) in
 220     set a i (get a 0);
 221     trickleup (bubble i 0) e;
 222   done;
 223   if l > 1 then (let e = (get a 1) in set a 1 (get a 0); set a 0 e);
 224 ;;
 225
 226 let cutoff = 5;;
 227 let stable_sort cmp a =
 228   let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
 229     let src1r = src1ofs + src1len and src2r = src2ofs + src2len in
 230     let rec loop i1 s1 i2 s2 d =
 231       if cmp s1 s2 <= 0 then begin
 232         set dst d s1;
 233         let i1 = i1 + 1 in
 234         if i1 < src1r then
 235           loop i1 (get a i1) i2 s2 (d + 1)
 236         else
 237           blit src2 i2 dst (d + 1) (src2r - i2)
 238       end else begin
 239         set dst d s2;
 240         let i2 = i2 + 1 in
 241         if i2 < src2r then
 242           loop i1 s1 i2 (get src2 i2) (d + 1)
 243         else
 244           blit a i1 dst (d + 1) (src1r - i1)
 245       end
 246     in loop src1ofs (get a src1ofs) src2ofs (get src2 src2ofs) dstofs;
 247   in
 248   let isortto srcofs dst dstofs len =
 249     for i = 0 to len - 1 do
 250       let e = (get a (srcofs + i)) in
 251       let j = ref (dstofs + i - 1) in
 252       while (!j >= dstofs && cmp (get dst !j) e > 0) do
 253         set dst (!j + 1) (get dst !j);
 254         decr j;
 255       done;
 256       set dst (!j + 1) e;
 257     done;
 258   in
 259   let rec sortto srcofs dst dstofs len =
 260     if len <= cutoff then isortto srcofs dst dstofs len else begin
 261       let l1 = len / 2 in
 262       let l2 = len - l1 in
 263       sortto (srcofs + l1) dst (dstofs + l1) l2;
 264       sortto srcofs a (srcofs + l2) l1;
 265       merge (srcofs + l2) l1 dst (dstofs + l1) l2 dst dstofs;
 266     end;
 267   in
 268   let l = length a in
 269   if l <= cutoff then isortto 0 a 0 l else begin
 270     let l1 = l / 2 in
 271     let l2 = l - l1 in
 272     let t = make l2 (get a 0) in
 273     sortto l1 t 0 l2;
 274     sortto 0 a l2 l1;
 275     merge l2 l1 t 0 l2 a 0;
 276   end;
 277 ;;
 278
 279 let fast_sort = stable_sort;;