(*

 * 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