(*
* 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