Source

ocaml-lib / cis-array.ml

(**
   Compact integer sets.
   Attention: integers must be strictly positive !
 *)

type t = int array
      (** integers in decreasing order, and negative value to mark beginning of interval. *)

let step : t * int -> nil:'a -> single:(int -> t * int -> 'a) -> interv:(int * int -> t * int -> 'a) -> 'a =
  fun (ar,i) ~nil ~single ~interv ->
    if i >= Array.length ar
    then nil
    else
      let x = ar.(i) in
      if x < 0
      then interv (-x,ar.(i+1)) (ar,i+2)
      else single x (ar,i+1)

type e = Single of int | Interv of int * int | Ar of (t * int)

type l = e list
      (* in a list, there is at most one Ar element, and it must be the last. *)


let rec cons : e -> l -> l =
  fun e -> function
    | [] -> [e]
    | e'::l' as l ->
	match e with
	| Single x -> 
	    ( match e' with
	    | Single x' -> if x=x'+1 then Interv (x,x')::l' else e::l
	    | Interv (xmax',xmin') -> if x=xmax'+1 then Interv (x,xmin')::l' else e::l
	    | Ar (ari) ->
		step ari
		  ~nil:[e]
		  ~single:(fun x' ari' -> if x=x'+1 then Interv (x,x')::Ar ari'::l' else e::l)
		  ~interv:(fun (xmax',xmin') ari' -> if x=xmax'+1 then Interv (x,xmin')::Ar ari'::l' else e::l))
	| Interv (xmax,xmin) ->
	    if xmin > xmax then l
	    else if xmin=xmax then cons (Single xmin) l
	    else
	      ( match e' with
	      | Single x' -> if xmin=x'+1 then Interv (xmax,x')::l' else e::l
	      | Interv (xmax',xmin') -> if xmin=xmax'+1 then Interv (xmax,xmin')::l' else e::l
	      | Ar ari ->
		  step ari
		    ~nil:[e]
		    ~single:(fun x' ari' -> if xmin=x'+1 then Interv (xmax,x')::Ar ari'::l' else e::l)
		    ~interv:(fun (xmax',xmin') ari' -> if xmin=xmax'+1 then Interv (xmax,xmin')::Ar ari'::l' else e::l))
	| Ar _ ->
	    raise (Invalid_argument "Cis.cons: sub-arrays must be at the end of lists")

let empty : t = Array.make 0 0

let rec t_of_l : l -> t =
  fun l ->
    let size =
      List.fold_left (fun res -> function Single _ -> res+1 | Interv _ -> res+2 | Ar (ar,i) -> res + (Array.length ar - i)) 0 l in
    let ar = Array.make size 0 in
    ignore (List.fold_left
      (fun i -> function
	| Single x -> (ar.(i) <- x); i+1
	| Interv (xmax,xmin) -> (ar.(i) <- -xmax); (ar.(i+1) <- xmin); i+2
	| Ar (ar',i') ->
	    let nb_elt = Array.length ar' - i' in
	    Array.blit ar' i' ar i nb_elt;
	    i+nb_elt)
      0
      l);
    ar

let rec add : int -> t -> t =
  fun x ar ->
    if x <= 0 then raise (Invalid_argument "Cis.add: non-positive integer");
    t_of_l (add_l x (ar,0))
and add_l x ari =
  step ari
    ~nil:[Single x]
    ~single:(fun x' ari' ->
      if x > x' then cons (Single x) [Ar ari]
      else if x = x' then [Ar ari]
      else cons (Single x') (add_l x ari'))
    ~interv:(fun (xmax',xmin') ari' ->
      if x > xmax' then cons (Single x) [Ar ari]
      else if xmax' >= x & x >= xmin' then [Ar ari]
      else cons (Interv (xmax',xmin')) (add_l x ari'))


let rec remove : int -> t -> t =
  fun x ar ->
    if x <= 0 then raise (Invalid_argument "Cis.remove: non-positive integer");
    t_of_l (remove_l x (ar,0))
and remove_l x ari =
  step ari
    ~nil:[]
    ~single:(fun x' ari' ->
      if x > x' then [Ar ari]
      else if x = x' then [Ar ari']
      else (* x' > x *) cons (Single x') (remove_l x ari'))
    ~interv:(fun (xmax',xmin') ari' ->
      if x > xmax' then [Ar ari]
      else if xmax' >= x & x >= xmin' then cons (Interv (xmax',x+1)) (cons (Interv (x-1,xmin')) [Ar ari'])
      else cons (Interv (xmax',xmin')) (remove_l x ari'))

let from_list : int list -> t =
  fun l ->
    List.fold_right add l empty;;

(*
let rec inter : t -> t -> t =
  fun ar1 ar2 ->
    t_of_l (inter_l (ar1,0) (ar2,0))
and inter_l ari1 ari2 =
  step ari1
    ~nil:[]
    ~single:(fun x1 ari1_tail ->
      step ari2
	~nil:[]
	~single:(fun x2 ari2_tail ->
	  if x1 > x2 then inter_l ari1_tail ari2
	  else if x2 > x1 then inter_l ari1 ari2_tail
	  else (* x1=x2 *) cons (Single x1) (inter_l ari1_tail ari2_tail))
	~interv:(fun (xmax2,xmin2) ari2' ->
	  if x1 > xmax2 then inter_l ari1_tail ari2
	  else if xmin2 > x1 then inter_l ari1 ari2_tail
	  else (* xmax2 >= x & x >= xmin2 *) cons (Single x1) (inter_l ari1_tail ari2)))
    ~interv:(fun (xmax1,xmin1) ari1' ->
      step ari2
	~nil:[]
	~single:(fun x2 ari2_tail ->
	  if x2 > xmax1 then inter_l ari1 ari2_tail
	  else if xmin2 > x1 then inter_l ari1 ari2_tail
	  else (* xmax2 >= x & x >= xmin2 *) cons (Single x1) (inter_l ari1_tail ari2))
	~interv:(fun (xmax2,xmin2) ari2_tail ->
	  if xmin2 > xmax1 then inter_l ari1 ari2_tail
	  else if xmin1 > xmax2 then inter_l ari1_tail ari2
	  else
	    cons
	      (Interv (min xmax1 xmax2,max xmin1 xmin2))
	      (if xmin1 >= xmin2 then inter_l ari1_tail ari2 else inter_l ari1 ari2_tail)))

*)


let rec to_lset : t -> int LSet.t =
  fun ar -> to_lset2 (ar,0)
and to_lset2 (ari : t * int) : int LSet.t =
  step ari
    ~nil:(LSet.empty ())
    ~single:(fun x ari' -> LSet.add x (to_lset2 ari'))
    ~interv:(fun (xmax,xmin) ari' ->
      Common.fold_for_down LSet.add xmax xmin (to_lset2 ari'));;


(* test section *)

#load "nums.cma"
#load "str.cma"
#load "unix.cma"
#load "common.cmo"
(*#load "lSet.cmo"*)

let print_lset l =
  List.iter (fun x -> print_int x; print_string " ") l;
  print_newline ()

let print_prof s =
  try
    let n, t, m = Hashtbl.find Common.tbl_prof s in
    print_int n; print_string "\t";
    print_float t; print_string "\t";
    print_float m; print_string "\n"
  with _ -> print_endline (s ^ " cannot be found in profiling")

let rec random_list range =
  function
    | 0 -> []
    | len ->
	let x = 1 + Random.int range in
	x::random_list range (len-1)

let rec test range len1 len2 =
  function
    | 0 ->
	print_prof "lset";
	print_prof "cis"
    | n ->
	let l1 = random_list range len1 in

(*	let ls1 = LSet.of_list l1 in
	let ds1 = IntSet.from_list l1 in
	let l2 = random_list range len2 in
	let ls2 = LSet.of_list l2 in
	let ds2 = IntSet.from_list l2 in
*)
	let ls = Common.prof "lset" (fun () -> LSet.of_list l1) in
	let ds = Common.prof "cis" (fun () -> from_list l1) in
	if to_lset ds <> ls
	then begin
(*
	  print_lset ls1;
	  print_lset ls2;
*)
	  print_lset ls;
	  print_lset (to_lset ds) end
	else test range len1 len2 (n-1)
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.