Source

ocaml-lib / sparse_array.ml


type 'a t = { mask : int; ar : 'a array}
      (* mask is bitmap of non-empty elements *)
      (* each 1-bit of mask refers to an element *)
      (* the number of 1-bits in 'mask lsr (x/31)' gives the array element containing the element x *)

let card_byte =
  let t = Array.make 256 0 in
  for i = 0 to 255 do
    for j = 0 to 7 do
      if (i lsr j) land 1 <> 0
      then t.(i) <- t.(i) + 1
    done
  done;
  t

let cardinal_word i =
  card_byte.(i land 0xFF)
    + card_byte.((i lsr 8) land 0xFF)
    + card_byte.((i lsr 16) land 0xFF)
    + card_byte.((i lsr 24) land 0xFF)
    
let get_i x e =
  let b = e.mask lsr x in
  assert (b land 1 <> 0);
  cardinal_word b

let get_word x e =
  let b = e.(0) lsr x in
  if b land 1 = 0
  then raise Not_found
  else e.ar.(cardinal_word b)

    let get_index x e = (* returns coordinates of bit x in e *)
      let x1, x2 = x / 31, x mod 31 in
      let b = e.(0) lsr x1 in
      if b land 1 = 0
      then (cardinal_word b + 1, x1, x2, false)
      else (cardinal_word b, x1, x2, true)
      
    let test i x2 =
      (i lsr x2) land 1 <> 0

    let set i x2 =
      i lor (1 lsl x2)

    let reset i x2 =
      i land ((-1) - (1 lsl x2))

    let empty = [| 0|]

    let is_empty e = e = [| 0|]

    let cardinal e =
      let n = Array.length e in
      let res = ref 0 in
      for i = 1 to n-1 do
	res := !res + cardinal_word e.(i)
      done;
      !res

    let mem x e =
      let i, _, x2, present = get_index x e in
      present && test e.(i) x2

    let singleton x =
      assert (x < 961);
      let x1, x2 = x / 31, x mod 31 in
      [| 1 lsl x1; 1 lsl x2 |]

    let add x e =
      assert (x < 961);
      let i, x1, x2, present = get_index x e in
      if present
      then
	if test e.(i) x2
	then e
	else begin
	  let e' = Array.copy e in (* unsafe not to make a copy *)
	  e'.(i) <- set e'.(i) x2;
	  e'
	end
      else begin
	let n = Array.length e in
	let e' = Array.make (n+1) 0 in
	e'.(0) <- set e.(0) x1;
	for k = 1 to i-1 do
	  e'.(k) <- e.(k)
	done;
	for k = Array.length e' - 1 downto i+1 do
	  e'.(k) <- e.(k-1)
	done;
	e'.(i) <- set 0 x2;
	e' end

    let remove x e =
      let i, x1, x2, present = get_index x e in
      if present
      then
	if test e.(i) x2
	then
	  let e'_i = reset e.(i) x2 in
	  if e'_i = 0
	  then begin
	    let n = Array.length e in
	    let e' = Array.make (n-1) 0 in
	    e'.(0) <- reset e.(0) x1;
	    for k = 1 to i-1 do
	      e'.(k) <- e.(k)
	    done;
	    for k = i to n-2 do
	      e'.(k) <- e.(k+1)
	    done;
	    e' end
	  else begin
	    let e' = Array.copy e in
	    e'.(i) <- e'_i;
	    e'
	  end
	else e
      else e

    let subset e1 e2 =
      let subset_word i1 i2 = i1 land (lnot i2) = 0 in
      if not (subset_word e1.(0) e2.(0))
      then false
      else begin
	let res = ref true in
	let x1 = ref 0 in
	while !res && !x1 < 31 do
	  res := test e1.(0) !x1 && subset_word (get_word !x1 e1) (get_word !x1 e2);
	  incr x1
	done;
	!res
      end

    let union e1 e2 =
      let union_word i1 i2 = i1 lor i2 in
      let e_0 = union_word e1.(0) e2.(0) in
      let n = cardinal_word e_0 in
      let e = Array.make (n+1) 0 in
      e.(0) <- e_0;
      for x1 = 0 to 31 - 1 do
	if test e_0 x1
	then e.(get_i x1 e) <- union_word (get_word x1 e1) (get_word x1 e2)
      done;
      e

    let inter e1 e2 =
      let inter_word i1 i2 = i1 land i2 in
      let e_0 = inter_word e1.(0) e2.(0) in
      let n = cardinal_word e_0 in
      let e = Array.make (n+1) 0 in
      e.(0) <- e_0;
      for x1 = 31 - 1 downto 0 do
	if test e.(0) x1
	then
	  let e_x1 = inter_word (get_word x1 e1) (get_word x1 e2) in
	  if e_x1 = 0
	  then e.(0) <- reset e.(0) x1
	  else e.(get_i x1 e) <- e_x1
      done;
      Array.sub e 0 (1 + cardinal_word e.(0)) (* for removing extra words *)

    let diff e1 e2 =
      let diff_word i1 i2 = i1 land (lnot i2) in
      let e_0 = e1.(0) in
      let n = cardinal_word e_0 in
      let e = Array.make (n+1) 0 in
      e.(0) <- e_0;
      for x1 = 31 - 1 downto 0 do
	if test e.(0) x1
	then
	  let e_x1 = diff_word (get_word x1 e1) (get_word x1 e2) in
	  if e_x1 = 0
	  then e.(0) <- reset e.(0) x1
	  else e.(get_i x1 e) <- e_x1
      done;
      Array.sub e 0 (1 + cardinal_word e.(0)) (* for removing extra words *)

    let union_r l = List.fold_left (fun res set -> union res set) empty l

    let inter_r = function
      | [] -> raise (Invalid_argument "Intset.Bitmap961.inter_r : empty list of sets")
      | set::sets -> List.fold_right (fun set res -> inter set res) sets set

    let fold f init e =
      let res = ref init in
      for x1 = 0 to 31 - 1 do
	if test e.(0) x1 then begin
	  let i = get_word x1 e in
	  let x0 = 31 * x1 in
	  for x2 = 0 to 31 - 1 do
	    if test i x2 then begin
	      res := f !res (x0 + x2)
	    end
	  done
	end
      done;
      !res
	
    let iter f e =
      for x1 = 0 to 31 - 1 do
	if test e.(0) x1 then begin
	  let i = get_word x1 e in
	  let x0 = 31 * x1 in
	  for x2 = 0 to 31 - 1 do
	    if test i x2 then begin
	      f (x0 + x2)
	    end
	  done
	end
      done

    let map f e = fold (fun res x -> f x::res) [] e

    let filter p e1 =
      let filter_word x0 i =
	let res = ref i in
	for x2 = 0 to 31 - 1 do
	  if test !res x2 && not (p (x0 + x2))
	  then res := reset !res x2
	done;
	!res
      in
      let e_0 = e1.(0) in
      let n = cardinal_word e_0 in
      let e = Array.make (n+1) 0 in
      e.(0) <- e_0;
      for x1 = 31 - 1 downto 0 do
	if test e.(0) x1
	then
	  let e_x1 = filter_word (31*x1) (get_word x1 e1) in
	  if e_x1 = 0
	  then e.(0) <- reset e.(0) x1
	  else e.(get_i x1 e) <- e_x1
      done;
      Array.sub e 0 (1 + cardinal_word e.(0)) (* for removing extra words *)

    let elements e =
      List.rev (fold (fun res x -> x::res) [] e)

    let memory_size e = 2 + Array.length e