Source file dynArray.ml

(*
 * DynArray - Resizeable Ocaml arrays
 * Copyright (C) 2003 Brian Hurt
 * Copyright (C) 2003 Nicolas Cannasse
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public
 * License as published by the Free Software Foundation; either
 * version 2.1 of the License, or (at your option) any later version,
 * with the special exception on linking described in file LICENSE.
 *
 * This library is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 *)

type resizer_t = currslots:int -> oldlength:int -> newlength:int -> int

type 'a intern

external ilen : 'a intern -> int = "%obj_size"
let idup (x : 'a intern) = if ilen x = 0 then x else (Obj.magic (Obj.dup (Obj.repr x)) : 'a intern)
let imake tag len = (Obj.magic (Obj.new_block tag len) : 'a intern)
external iget : 'a intern -> int -> 'a = "%obj_field"
external iset : 'a intern -> int -> 'a -> unit = "%obj_set_field"

type 'a t = {
  mutable arr : 'a intern;
  mutable len : int;
  mutable resize: resizer_t;
}

exception Invalid_arg of int * string * string

let invalid_arg n f p = raise (Invalid_arg (n,f,p))

let length d = d.len

let exponential_resizer ~currslots ~oldlength ~newlength =
  let rec doubler x = if x >= newlength then x else doubler (x * 2) in
  let rec halfer x = if x / 2 < newlength then x else halfer (x / 2) in
  if newlength = 1 then
    1
  else if currslots = 0 then
    doubler 1
  else if currslots < newlength then
    doubler currslots
  else
    halfer currslots

let step_resizer step =
  if step <= 0 then invalid_arg step "step_resizer" "step";
  (fun ~currslots ~oldlength ~newlength ->
    if currslots < newlength || newlength < (currslots - step)
    then
       (newlength + step - (newlength mod step))
    else
      currslots)

let conservative_exponential_resizer ~currslots ~oldlength ~newlength =
  let rec doubler x = if x >= newlength then x else doubler (x * 2) in
  let rec halfer x = if x / 2 < newlength then x else halfer (x / 2) in
  if currslots < newlength then begin
    if newlength = 1 then
      1
    else if currslots = 0 then
      doubler 1
    else
      doubler currslots
  end else if oldlength < newlength then
    halfer currslots
  else
    currslots

let default_resizer = conservative_exponential_resizer

let changelen (d : 'a t) newlen =
  if newlen > Sys.max_array_length then invalid_arg newlen "changelen" "newlen";

  let oldsize = ilen d.arr in
  let r = d.resize
      ~currslots:oldsize
      ~oldlength:d.len
      ~newlength:newlen
  in
  (* We require the size to be at least large enough to hold the number
   * of elements we know we need!
   * Also be sure not to exceed max_array_length
   *)
  let newsize = if r < newlen then newlen else min Sys.max_array_length r in
  if newsize <> oldsize then begin
    let newarr = imake 0 newsize in
    let cpylen = (if newlen < d.len then newlen else d.len) in
    for i = 0 to cpylen - 1 do
      iset newarr i (iget d.arr i);
    done;
    d.arr <- newarr;
  end;
  d.len <- newlen

let compact d =
  if d.len <> ilen d.arr then begin
    let newarr = imake 0 d.len in
    for i = 0 to d.len - 1 do
      iset newarr i (iget d.arr i)
    done;
    d.arr <- newarr;
  end

let create() =
  {
    resize = default_resizer;
    len = 0;
    arr = imake 0 0;
  }

let make initsize =
  if initsize < 0 then invalid_arg initsize "make" "size";
  {
    resize = default_resizer;
    len = 0;
    arr = imake 0 initsize;
  }

let init initlen f =
  if initlen < 0 then invalid_arg initlen "init" "len";
  let arr = imake 0 initlen in
  for i = 0 to initlen-1 do
    iset arr i (f i)
  done;
  {
    resize = default_resizer;
    len = initlen;
    arr = arr;
  }

let set_resizer d resizer =
  d.resize <- resizer

let get_resizer d =
  d.resize

let empty d =
  d.len = 0

let get d idx =
  if idx < 0 || idx >= d.len then invalid_arg idx "get" "index";
  iget d.arr idx

let last d =
  if d.len = 0 then invalid_arg 0 "last" "<array len is 0>";
  iget d.arr (d.len - 1)

let set d idx v =
  if idx < 0 || idx >= d.len then   invalid_arg idx "set" "index";
  iset d.arr idx v

let insert d idx v =
  if idx < 0 || idx > d.len then invalid_arg idx "insert" "index";
  if d.len = ilen d.arr then changelen d (d.len + 1) else d.len <- d.len + 1;
  if idx < d.len - 1 then begin
    for i = d.len - 2 downto idx do
      iset d.arr (i+1) (iget d.arr i)
    done;
  end;
  iset d.arr idx v

let add d v =
  if d.len = ilen d.arr then changelen d (d.len + 1) else d.len <- d.len + 1;
  iset d.arr (d.len - 1) v

let delete d idx =
  if idx < 0 || idx >= d.len then invalid_arg idx "delete" "index";
  let oldsize = ilen d.arr in
  (* we don't call changelen because we want to blit *)
  let r = d.resize
    ~currslots:oldsize
    ~oldlength:d.len
    ~newlength:(d.len - 1)
  in
  let newsize = (if r < d.len - 1 then d.len - 1 else r) in
  if oldsize <> newsize then begin
    let newarr = imake 0 newsize in
    for i = 0 to idx - 1 do
      iset newarr i (iget d.arr i);
    done;
    for i = idx to d.len - 2 do
      iset newarr i (iget d.arr (i+1));
    done;
    d.arr <- newarr;
  end else begin
    for i = idx to d.len - 2 do
      iset d.arr i (iget d.arr (i+1));
    done;
    iset d.arr (d.len - 1) (Obj.magic 0)
  end;
  d.len <- d.len - 1


let delete_range d idx len =
  if len < 0 then invalid_arg len "delete_range" "length";
  if idx < 0 || idx + len > d.len then invalid_arg idx "delete_range" "index";
  let oldsize = ilen d.arr in
  (* we don't call changelen because we want to blit *)
  let r = d.resize
    ~currslots:oldsize
    ~oldlength:d.len
    ~newlength:(d.len - len)
  in
  let newsize = (if r < d.len - len then d.len - len else r) in
  if oldsize <> newsize then begin
    let newarr = imake 0 newsize in
    for i = 0 to idx - 1 do
      iset newarr i (iget d.arr i);
    done;
    for i = idx to d.len - len - 1 do
      iset newarr i (iget d.arr (i+len));
    done;
    d.arr <- newarr;
  end else begin
    for i = idx to d.len - len - 1 do
      iset d.arr i (iget d.arr (i+len));
    done;
    for i = d.len - len to d.len - 1 do
      iset d.arr i (Obj.magic 0)
    done;
  end;
  d.len <- d.len - len

let clear d =
  d.len <- 0;
  d.arr <- imake 0 0

let delete_last d =
  if d.len <= 0 then invalid_arg 0 "delete_last" "<array len is 0>";
  (* erase for GC, in case changelen don't resize our array *)
  iset d.arr (d.len - 1) (Obj.magic 0);
  changelen d (d.len - 1)

let rec blit src srcidx dst dstidx len =
  if len < 0 then invalid_arg len "blit" "len";
  if srcidx < 0 || srcidx + len > src.len then invalid_arg srcidx "blit" "source index";
  if dstidx < 0 || dstidx > dst.len then invalid_arg dstidx "blit" "dest index";
  let newlen = dstidx + len in
  if newlen > ilen dst.arr then begin
    (* this case could be inlined so we don't blit on just-copied elements *)
    changelen dst newlen
  end else begin
    if newlen > dst.len then dst.len <- newlen;
  end;
  (* same array ! we need to copy in reverse order *)
  if src.arr == dst.arr && dstidx > srcidx then
    for i = len - 1 downto 0 do
      iset dst.arr (dstidx+i) (iget src.arr (srcidx+i));
    done
  else
    for i = 0 to len - 1 do
      iset dst.arr (dstidx+i) (iget src.arr (srcidx+i));
    done

let append src dst =
  blit src 0 dst dst.len src.len

let to_list d =
  let rec loop idx accum =
    if idx < 0 then accum else loop (idx - 1) (iget d.arr idx :: accum)
  in
  loop (d.len - 1) []

let to_array d =
  if d.len = 0 then begin
    (* since the empty array is an atom, we don't care if float or not *)
    [||]
  end else begin
    let arr = Array.make d.len (iget d.arr 0) in
    for i = 1 to d.len - 1 do
      Array.unsafe_set arr i (iget d.arr i)
    done;
    arr;
  end

let of_list lst =
  let size = List.length lst in
  let arr = imake 0 size in
  let rec loop idx =  function
    | h :: t -> iset arr idx h; loop (idx + 1) t
    | [] -> ()
  in
  loop 0 lst;
  {
    resize = default_resizer;
    len = size;
    arr = arr;
  }

let of_array src =
  let size = Array.length src in
  let is_float = Obj.tag (Obj.repr src) = Obj.double_array_tag in
  let arr = (if is_float then begin
      let arr = imake 0 size in
      for i = 0 to size - 1 do
        iset arr i (Array.unsafe_get src i);
      done;
      arr
    end else
      (* copy the fields *)
      idup (Obj.magic src : 'a intern))
  in
  {
    resize = default_resizer;
    len = size;
    arr = arr;
  }

let copy src =
  {
    resize = src.resize;
    len = src.len;
    arr = idup src.arr;
  }

let sub src start len =
  if len < 0 then invalid_arg len "sub" "len";
  if start < 0 || start + len > src.len then invalid_arg start "sub" "start";
  let arr = imake 0 len in
  for i = 0 to len - 1 do
    iset arr i (iget src.arr (i+start));
  done;
  {
    resize = src.resize;
    len = len;
    arr = arr;
  }

let iter f d =
  for i = 0 to d.len - 1 do
    f (iget d.arr i)
  done

let iteri f d =
  for i = 0 to d.len - 1 do
    f i (iget d.arr i)
  done

let filter f d =
  let l = d.len in
  let a = imake 0 l in
  let a2 = d.arr in
  let p = ref 0 in
  for i = 0 to l - 1 do
    let x = iget a2 i in
    if f x then begin
      iset a !p x;
      incr p;
    end;
  done;
  d.len <- !p;
  d.arr <- a

let index_of f d =
  let rec loop i =
    if i >= d.len then
      raise Not_found
    else
      if f (iget d.arr i) then
        i
      else
        loop (i+1)
  in
  loop 0

let map f src =
  let arr = imake 0 src.len in
  for i = 0 to src.len - 1 do
    iset arr i (f (iget src.arr i))
  done;
  {
    resize = src.resize;
    len = src.len;
    arr = arr;
  }

let mapi f src =
  let arr = imake 0 src.len in
  for i = 0 to src.len - 1 do
    iset arr i (f i (iget src.arr i))
  done;
  {
    resize = src.resize;
    len = src.len;
    arr = arr;
  }

let fold_left f x a =
  let rec loop idx x =
    if idx >= a.len then x else loop (idx + 1) (f x (iget a.arr idx))
  in
  loop 0 x

let fold_right f a x =
  let rec loop idx x =
    if idx < 0 then x
    else loop (idx - 1) (f (iget a.arr idx) x)
  in
  loop (a.len - 1) x

let enum d =
  let rec make start =
    let idxref = ref 0 in
    let next () =
      if !idxref >= d.len then
        raise Enum.No_more_elements
      else
        let retval = iget d.arr !idxref in
        incr idxref;
        retval
    and count () =
      if !idxref >= d.len then 0
      else d.len - !idxref
    and clone () =
      make !idxref
    in
    Enum.make ~next:next ~count:count ~clone:clone
  in
  make 0

let of_enum e =
  if Enum.fast_count e then begin
    let c = Enum.count e in
    let arr = imake 0 c in
    Enum.iteri (fun i x -> iset arr i x) e;
    {
      resize = default_resizer;
      len = c;
      arr = arr;
    }
  end else
    let d = make 0 in
    Enum.iter (add d) e;
    d

let unsafe_get a n =
  iget a.arr n

let unsafe_set a n x =
  iset a.arr n x