commons/ocamlextra/dynArray.ml

   1 (*
   2  * DynArray - Resizeable Ocaml arrays
   3  * Copyright (C) 2003 Brian Hurt
   4  * Copyright (C) 2003 Nicolas Cannasse
   5  *
   6  * This library is free software; you can redistribute it and/or
   7  * modify it under the terms of the GNU Lesser General Public
   8  * License as published by the Free Software Foundation; either
   9  * version 2.1 of the License, or (at your option) any later version,
  10  * with the special exception on linking described in file LICENSE.
  11  *
  12  * This library is distributed in the hope that it will be useful,
  13  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  14  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15  * Lesser General Public License for more details.
  16  *
  17  * You should have received a copy of the GNU Lesser General Public
  18  * License along with this library; if not, write to the Free Software
  19  * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  20  *)
  21
  22 type resizer_t = currslots:int -> oldlength:int -> newlength:int -> int
  23
  24 type 'a intern
  25
  26 external ilen : 'a intern -> int = "%obj_size"
  27 let idup (x : 'a intern) = if ilen x = 0 then x else (Obj.magic (Obj.dup (Obj.repr x)) : 'a intern)
  28 let imake tag len = (Obj.magic (Obj.new_block tag len) : 'a intern)
  29 external iget : 'a intern -> int -> 'a = "%obj_field"
  30 external iset : 'a intern -> int -> 'a -> unit = "%obj_set_field"
  31
  32 type 'a t = {
  33         mutable arr : 'a intern;
  34         mutable len : int;
  35         mutable resize: resizer_t;
  36 }
  37
  38 exception Invalid_arg of int * string * string
  39
  40 let invalid_arg n f p = raise (Invalid_arg (n,f,p))
  41
  42 let length d = d.len
  43
  44 let exponential_resizer ~currslots ~oldlength ~newlength =
  45         let rec doubler x = if x >= newlength then x else doubler (x * 2) in
  46         let rec halfer x = if x / 2 < newlength then x else halfer (x / 2) in
  47         if newlength = 1 then
  48                 1
  49         else if currslots = 0 then
  50                 doubler 1
  51         else if currslots < newlength then
  52                 doubler currslots
  53         else
  54                 halfer currslots
  55
  56 let step_resizer step =
  57         if step <= 0 then invalid_arg step "step_resizer" "step";
  58         (fun ~currslots ~oldlength ~newlength ->
  59                 if currslots < newlength || newlength < (currslots - step)
  60                 then
  61                    (newlength + step - (newlength mod step))
  62                 else
  63                         currslots)
  64
  65 let conservative_exponential_resizer ~currslots ~oldlength ~newlength =
  66         let rec doubler x = if x >= newlength then x else doubler (x * 2) in
  67         let rec halfer x = if x / 2 < newlength then x else halfer (x / 2) in
  68         if currslots < newlength then begin
  69                 if newlength = 1 then
  70                         1
  71                 else if currslots = 0 then
  72                         doubler 1
  73                 else
  74                         doubler currslots
  75         end else if oldlength < newlength then
  76                 halfer currslots
  77         else
  78                 currslots
  79
  80 let default_resizer = conservative_exponential_resizer
  81
  82 let changelen (d : 'a t) newlen =
  83         let oldsize = ilen d.arr in
  84         let r = d.resize
  85                         ~currslots:oldsize
  86                         ~oldlength:d.len
  87                         ~newlength:newlen
  88         in
  89         (* We require the size to be at least large enough to hold the number
  90          * of elements we know we need!
  91          *)
  92         let newsize = if r < newlen then newlen else r in
  93         if newsize <> oldsize then begin
  94                 let newarr = imake 0 newsize in
  95                 let cpylen = (if newlen < d.len then newlen else d.len) in
  96                 for i = 0 to cpylen - 1 do
  97                         iset newarr i (iget d.arr i);
  98                 done;
  99                 d.arr <- newarr;
 100         end;
 101         d.len <- newlen
 102
 103 let compact d =
 104         if d.len <> ilen d.arr then begin
 105                 let newarr = imake 0 d.len in
 106                 for i = 0 to d.len - 1 do
 107                         iset newarr i (iget d.arr i)
 108                 done;
 109                 d.arr <- newarr;
 110         end
 111
 112 let create() =
 113         {
 114                 resize = default_resizer;
 115                 len = 0;
 116                 arr = imake 0 0;
 117         }
 118
 119 let make initsize =
 120         if initsize < 0 then invalid_arg initsize "make" "size";
 121         {
 122                 resize = default_resizer;
 123                 len = 0;
 124                 arr = imake 0 initsize;
 125         }
 126
 127 let init initlen f =
 128         if initlen < 0 then invalid_arg initlen "init" "len";
 129         let arr = imake 0 initlen in
 130         for i = 0 to initlen-1 do
 131                 iset arr i (f i)
 132         done;
 133         {
 134                 resize = default_resizer;
 135                 len = initlen;
 136                 arr = arr;
 137         }
 138
 139 let set_resizer d resizer =
 140         d.resize <- resizer
 141
 142 let get_resizer d =
 143         d.resize
 144
 145 let empty d =
 146         d.len = 0
 147
 148 let get d idx =
 149         if idx < 0 || idx >= d.len then invalid_arg idx "get" "index";
 150         iget d.arr idx
 151
 152 let last d =
 153         if d.len = 0 then invalid_arg 0 "last" "<array len is 0>";
 154         iget d.arr (d.len - 1)
 155
 156 let set d idx v =
 157         if idx < 0 || idx >= d.len then         invalid_arg idx "set" "index";
 158         iset d.arr idx v
 159
 160 let insert d idx v =
 161         if idx < 0 || idx > d.len then invalid_arg idx "insert" "index";
 162         if d.len = ilen d.arr then changelen d (d.len + 1) else d.len <- d.len + 1;
 163         if idx < d.len - 1 then begin
 164                 for i = d.len - 1 downto idx do
 165                         iset d.arr (i+1) (iget d.arr i)
 166                 done;
 167         end;
 168         iset d.arr idx v
 169
 170 let add d v =
 171         if d.len = ilen d.arr then changelen d (d.len + 1) else d.len <- d.len + 1;
 172         iset d.arr (d.len - 1) v
 173
 174 let delete d idx =
 175         if idx < 0 || idx >= d.len then invalid_arg idx "delete" "index";
 176         let oldsize = ilen d.arr in
 177         (* we don't call changelen because we want to blit *)
 178         let r = d.resize
 179                 ~currslots:oldsize
 180                 ~oldlength:d.len
 181                 ~newlength:(d.len - 1)
 182         in
 183         let newsize = (if r < d.len - 1 then d.len - 1 else r) in
 184         if oldsize <> newsize then begin
 185                 let newarr = imake 0 newsize in
 186                 for i = 0 to idx - 1 do
 187                         iset newarr i (iget d.arr i);
 188                 done;
 189                 for i = idx to d.len - 2 do
 190                         iset newarr i (iget d.arr (i+1));
 191                 done;
 192                 d.arr <- newarr;
 193         end else begin
 194                 for i = idx to d.len - 2 do
 195                         iset d.arr i (iget d.arr (i+1));
 196                 done;
 197                 iset d.arr (d.len - 1) (Obj.magic 0)
 198         end;
 199         d.len <- d.len - 1
 200
 201
 202 let delete_range d idx len =
 203         if len < 0 then invalid_arg len "delete_range" "length";
 204         if idx < 0 || idx + len > d.len then invalid_arg idx "delete_range" "index";
 205         let oldsize = ilen d.arr in
 206         (* we don't call changelen because we want to blit *)
 207         let r = d.resize
 208                 ~currslots:oldsize
 209                 ~oldlength:d.len
 210                 ~newlength:(d.len - len)
 211         in
 212         let newsize = (if r < d.len - len then d.len - len else r) in
 213         if oldsize <> newsize then begin
 214                 let newarr = imake 0 newsize in
 215                 for i = 0 to idx - 1 do
 216                         iset newarr i (iget d.arr i);
 217                 done;
 218                 for i = idx to d.len - len - 1 do
 219                         iset newarr i (iget d.arr (i+len));
 220                 done;
 221                 d.arr <- newarr;
 222         end else begin
 223                 for i = idx to d.len - len - 1 do
 224                         iset d.arr i (iget d.arr (i+len));
 225                 done;
 226                 for i = d.len - len to d.len - 1 do
 227                         iset d.arr i (Obj.magic 0)
 228                 done;
 229         end;
 230         d.len <- d.len - len
 231
 232 let clear d =
 233         d.len <- 0;
 234         d.arr <- imake 0 0
 235
 236 let delete_last d =
 237         if d.len <= 0 then invalid_arg 0 "delete_last" "<array len is 0>";
 238         (* erase for GC, in case changelen don't resize our array *)
 239         iset d.arr (d.len - 1) (Obj.magic 0);
 240         changelen d (d.len - 1)
 241
 242 let rec blit src srcidx dst dstidx len =
 243         if len < 0 then invalid_arg len "blit" "len";
 244         if srcidx < 0 || srcidx + len > src.len then invalid_arg srcidx "blit" "source index";
 245         if dstidx < 0 || dstidx > dst.len then invalid_arg dstidx "blit" "dest index";
 246         let newlen = dstidx + len in
 247         if newlen > ilen dst.arr then begin
 248                 (* this case could be inlined so we don't blit on just-copied elements *)
 249                 changelen dst newlen
 250         end else begin
 251                 if newlen > dst.len then dst.len <- newlen;
 252         end;
 253         (* same array ! we need to copy in reverse order *)
 254         if src.arr == dst.arr && dstidx > srcidx then
 255                 for i = len - 1 downto 0 do
 256                         iset dst.arr (dstidx+i) (iget src.arr (srcidx+i));
 257                 done
 258         else
 259                 for i = 0 to len - 1 do
 260                         iset dst.arr (dstidx+i) (iget src.arr (srcidx+i));
 261                 done
 262
 263 let append src dst =
 264         blit src 0 dst dst.len src.len
 265
 266 let to_list d =
 267         let rec loop idx accum =
 268                 if idx < 0 then accum else loop (idx - 1) (iget d.arr idx :: accum)
 269         in
 270         loop (d.len - 1) []
 271
 272 let to_array d =
 273         if d.len = 0 then begin
 274                 (* since the empty array is an atom, we don't care if float or not *)
 275                 [||]
 276         end else begin
 277                 let arr = Array.make d.len (iget d.arr 0) in
 278                 for i = 1 to d.len - 1 do
 279                         Array.unsafe_set arr i (iget d.arr i)
 280                 done;
 281                 arr;
 282         end
 283
 284 let of_list lst =
 285         let size = List.length lst in
 286         let arr = imake 0 size in
 287         let rec loop idx =  function
 288                 | h :: t -> iset arr idx h; loop (idx + 1) t
 289                 | [] -> ()
 290         in
 291         loop 0 lst;
 292         {
 293                 resize = default_resizer;
 294                 len = size;
 295                 arr = arr;
 296         }
 297
 298 let of_array src =
 299         let size = Array.length src in
 300         let is_float = Obj.tag (Obj.repr src) = Obj.double_array_tag in
 301         let arr = (if is_float then begin
 302                         let arr = imake 0 size in
 303                         for i = 0 to size - 1 do
 304                                 iset arr i (Array.unsafe_get src i);
 305                         done;
 306                         arr
 307                 end else
 308                         (* copy the fields *)
 309                         idup (Obj.magic src : 'a intern))
 310         in
 311         {
 312                 resize = default_resizer;
 313                 len = size;
 314                 arr = arr;
 315         }
 316
 317 let copy src =
 318         {
 319                 resize = src.resize;
 320                 len = src.len;
 321                 arr = idup src.arr;
 322         }
 323
 324 let sub src start len =
 325         if len < 0 then invalid_arg len "sub" "len";
 326         if start < 0 || start + len > src.len then invalid_arg start "sub" "start";
 327         let arr = imake 0 len in
 328         for i = 0 to len - 1 do
 329                 iset arr i (iget src.arr (i+start));
 330         done;
 331         {
 332                 resize = src.resize;
 333                 len = len;
 334                 arr = arr;
 335         }
 336
 337 let iter f d =
 338         for i = 0 to d.len - 1 do
 339                 f (iget d.arr i)
 340         done
 341
 342 let iteri f d =
 343         for i = 0 to d.len - 1 do
 344                 f i (iget d.arr i)
 345         done
 346
 347 let filter f d =
 348         let l = d.len in
 349         let a = imake 0 l in
 350         let a2 = d.arr in
 351         let p = ref 0 in
 352         for i = 0 to l - 1 do
 353                 let x = iget a2 i in
 354                 if f x then begin
 355                         iset a !p x;
 356                         incr p;
 357                 end;
 358         done;
 359         d.len <- !p;
 360         d.arr <- a
 361
 362 let index_of f d =
 363         let rec loop i =
 364                 if i >= d.len then
 365                         raise Not_found
 366                 else
 367                         if f (iget d.arr i) then
 368                                 i
 369                         else
 370                                 loop (i+1)
 371         in
 372         loop 0
 373
 374 let map f src =
 375         let arr = imake 0 src.len in
 376         for i = 0 to src.len - 1 do
 377                 iset arr i (f (iget src.arr i))
 378         done;
 379         {
 380                 resize = src.resize;
 381                 len = src.len;
 382                 arr = arr;
 383         }
 384
 385 let mapi f src =
 386         let arr = imake 0 src.len in
 387         for i = 0 to src.len - 1 do
 388                 iset arr i (f i (iget src.arr i))
 389         done;
 390         {
 391                 resize = src.resize;
 392                 len = src.len;
 393                 arr = arr;
 394         }
 395
 396 let fold_left f x a =
 397         let rec loop idx x =
 398                 if idx >= a.len then x else loop (idx + 1) (f x (iget a.arr idx))
 399         in
 400         loop 0 x
 401
 402 let fold_right f a x =
 403         let rec loop idx x =
 404                 if idx < 0 then x
 405                 else loop (idx - 1) (f (iget a.arr idx) x)
 406         in
 407         loop (a.len - 1) x
 408
 409 let enum d =
 410         let rec make start =
 411                 let idxref = ref 0 in
 412                 let next () =
 413                         if !idxref >= d.len then
 414                                 raise Enum.No_more_elements
 415                         else
 416                                 let retval = iget d.arr !idxref in
 417                                 incr idxref;
 418                                 retval
 419                 and count () =
 420                         if !idxref >= d.len then 0
 421                         else d.len - !idxref
 422                 and clone () =
 423                         make !idxref
 424                 in
 425                 Enum.make ~next:next ~count:count ~clone:clone
 426         in
 427         make 0
 428
 429 let of_enum e =
 430         if Enum.fast_count e then begin
 431                 let c = Enum.count e in
 432                 let arr = imake 0 c in
 433                 Enum.iteri (fun i x -> iset arr i x) e;
 434                 {
 435                         resize = default_resizer;
 436                         len = c;
 437                         arr = arr;
 438                 }
 439         end else
 440                 let d = make 0 in
 441                 Enum.iter (add d) e;
 442                 d
 443
 444 let unsafe_get a n =
 445         iget a.arr n
 446
 447 let unsafe_set a n x =
 448         iset a.arr n x