imperative bitvector module

BV.ml

@@ -0,0 +1,179 @@
+
+(*
+copyright (c) 2013, simon cruanes
+all rights reserved.
+
+redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+redistributions of source code must retain the above copyright notice, this
+list of conditions and the following disclaimer.  redistributions in binary
+form must reproduce the above copyright notice, this list of conditions and the
+following disclaimer in the documentation and/or other materials provided with
+the distribution.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+*)
+
+(** {2 Imperative Bitvectors} *)
+
+let __width = Sys.word_size - 2
+
+(* int with [n] ones *)
+let rec __shift bv n =
+  if n = 0
+    then bv
+    else __shift ((bv lsl 1) lor 1) (n-1)
+
+(* only ones *)
+let __all_ones = __shift 0 __width
+
+type t = int array
+
+let create ~size default =
+  if size = 0 then [| 0 |]
+    else begin
+      let n = if size mod __width = 0 then size / __width else (size / __width) + 1 in
+      let arr = if default
+        then Array.make n __all_ones
+        else Array.make n 0
+      in
+      (* adjust last bits *)
+      if default && (size mod __width) <> 0
+        then arr.(n-1) <- __shift 0 (size - (n-1) * __width);
+      arr
+    end
+
+let copy = Array.copy
+
+let length bv = Array.length bv
+
+let resize bv ~size default =
+  failwith "not implemented"
+
+(* count the 1 bits in [n]. See https://en.wikipedia.org/wiki/Hamming_weight *)
+let __count_bits n =
+  let rec recurse count n =
+    if n = 0 then count else recurse (count+1) (n land (n-1))
+  in
+  if n < 0
+    then recurse 1 (n lsr 1)   (* only on unsigned *)
+    else recurse 0 n
+
+let cardinal bv =
+  let n = ref 0 in
+  for i = 0 to Array.length bv - 1 do
+    n := !n + __count_bits bv.(i)
+  done;
+  !n
+
+let is_empty bv =
+  try
+    for i = 0 to Array.length bv - 1 do
+      if bv.(i) <> 0 then raise Exit
+    done;
+    true
+  with Exit ->
+    false
+
+let get bv i =
+  let n = i / __width in
+  let i = i - n * __width in
+  bv.(n) land (1 lsl i) <> 0
+
+let set bv i =
+  let n = i / __width in
+  let i = i - n * __width in
+  bv.(n) <- bv.(n) lor (1 lsl i)
+
+let reset bv i =
+  let n = i / __width in
+  let i = i - n * __width in
+  bv.(n) <- bv.(n) land (lnot (1 lsl i))
+
+let flip bv i =
+  let n = i / __width in
+  let i = i - n * __width in
+  bv.(n) <- bv.(n) lxor (1 lsl i)
+
+let clear bv =
+  Array.iteri (fun i _ -> bv.(i) <- 0) bv
+
+let iter bv f =
+  for n = 0 to Array.length bv - 1 do
+    let j = __width * n in
+    for i = 0 to __width - 1 do
+      f (j+i) (bv.(n) land (1 lsl i) <> 0)
+    done
+  done
+
+let iter_true bv f =
+  for n = 0 to Array.length bv - 1 do
+    let j = __width * n in
+    for i = 0 to __width - 1 do
+      if bv.(n) land (1 lsl i) <> 0
+        then f (j+i)
+    done
+  done
+
+let to_list bv =
+  let l = ref [] in
+  iter_true bv (fun i -> l := i :: !l);
+  !l
+
+let of_list l =
+  let size = List.fold_left max 0 l in
+  let bv = create ~size false in
+  List.iter (fun i -> set bv i) l;
+  bv
+
+let union_into ~into bv =
+  assert (length into >= length bv);
+  for i = 0 to Array.length bv - 1 do
+    into.(i) <- into.(i) lor bv.(i)
+  done
+
+let union bv1 bv2 =
+  let size = __width * (max (Array.length bv1) (Array.length bv2)) in
+  let bv = create ~size false in
+  union_into ~into:bv bv1;
+  union_into ~into:bv bv2;
+  bv
+
+let inter_into ~into bv =
+  let n = min (length into) (length bv) in
+  for i = 0 to n - 1 do
+    into.(i) <- into.(i) land bv.(i)
+  done
+
+let inter bv1 bv2 =
+  if length bv1 < length bv2
+    then
+      let bv = copy bv1 in
+      let () = inter_into ~into:bv bv2 in
+      bv
+    else
+      let bv = copy bv2 in
+      let () = inter_into ~into:bv bv1 in
+      bv
+
+let select bv arr =
+  let l = ref [] in
+  begin try
+    iter_true bv
+      (fun i ->
+        if i >= Array.length arr
+          then raise Exit
+          else l := (arr.(i), i) :: !l)
+  with Exit -> ()
+  end;
+  !l

BV.mli

@@ -0,0 +1,93 @@
+
+(*
+copyright (c) 2013, simon cruanes
+all rights reserved.
+
+redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+redistributions of source code must retain the above copyright notice, this
+list of conditions and the following disclaimer.  redistributions in binary
+form must reproduce the above copyright notice, this list of conditions and the
+following disclaimer in the documentation and/or other materials provided with
+the distribution.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+*)
+
+(** {2 Imperative Bitvectors} *)
+
+type t
+
+val create : size:int -> bool -> t
+  (** Create a bitvector of given size, with given default value *)
+
+val copy : t -> t
+  (** Copy of bitvector *)
+
+val resize : t -> size:int -> bool -> t
+  (** [resize bv ~size default] resizes [bv] to the given size. If the
+      new size is bigger than the old one, new values are set to [default]. *)
+
+val cardinal : t -> int
+  (** Number of bits set *)
+
+val length : t -> int
+  (** Length of underlying array *)
+
+val is_empty : t -> bool
+  (** Any bit set? *)
+
+val set : t -> int -> unit
+  (** Set i-th bit *)
+
+val get : t -> int -> bool
+  (** Is the i-th bit true? *)
+
+val reset : t -> int -> unit
+  (** Set i-th bit to 0 *)
+
+val flip : t -> int -> unit
+  (** Flip i-th bit *)
+
+val clear : t -> unit
+  (** Set every bit to 0 *)
+
+val iter : t -> (int -> bool -> unit) -> unit
+  (** Iterate on all bits *)
+
+val iter_true : t -> (int -> unit) -> unit
+  (** Iterate on bits set to 1 *)
+
+val to_list : t -> int list
+  (** List of indexes that are true *)
+
+val of_list : int list -> t
+  (** From a list of true bits *)
+
+val union_into : into:t -> t -> unit
+  (** [union ~into bv] sets [into] to the union of itself and [bv].
+      [into] must have at least as long as [bv]. *)
+
+val inter_into : into:t -> t -> unit
+  (** [union ~into bv] sets [into] to the intersection of itself and [bv] *)
+
+val union : t -> t -> t
+  (** [union bv1 bv2] returns the union of the two sets *)
+
+val inter : t -> t -> t
+
+val select : t -> 'a array -> ('a * int) list
+  (** [select arr bv] selects the elements of [arr] whose index
+      correspond to a true bit in [bv]. The elements are paired to their
+      index in [arr]. If [bv] is too short, elements of [arr] with too high
+      an index cannot be returned. *)

containers.mllib

@@ -29,3 +29,4 @@ AbsSet
 CSM
 MultiMap
 ActionMan
+BV

tests/run_tests.ml

@@ -7,6 +7,7 @@ let suite =
     [ Test_pHashtbl.suite;
       Test_PersistentHashtbl.suite;
       Test_bencode.suite;
+      Test_bv.suite;
       Test_Behavior.suite;
       Test_PiCalculus.suite;
       Test_splayMap.suite;

tests/test_bv.ml

@@ -0,0 +1,73 @@
+open OUnit
+
+let test_cardinal () =
+  let bv1 = BV.create ~size:87 true in
+  assert_equal ~printer:string_of_int 87 (BV.cardinal bv1);
+  ()
+
+let test_get () =
+  let bv = BV.create ~size:99 false in
+  assert_bool "32 must be false" (not (BV.get bv 32));
+  assert_bool "88 must be false" (not (BV.get bv 88));
+  assert_bool "5 must be false" (not (BV.get bv 5));
+  BV.set bv 32;
+  BV.set bv 88;
+  BV.set bv 5;
+  assert_bool "32 must be true" (BV.get bv 32);
+  assert_bool "88 must be true" (BV.get bv 88);
+  assert_bool "5 must be true" (BV.get bv 5);
+  assert_bool "33 must be false" (not (BV.get bv 33));
+  assert_bool "44 must be false" (not (BV.get bv 44));
+  assert_bool "1 must be false" (not (BV.get bv 1));
+  ()
+
+let test_list () =
+  let bv = BV.of_list [1; 5; 156; 0; 222] in
+  assert_equal ~printer:string_of_int 5 (BV.cardinal bv);
+  BV.set bv 201;
+  assert_equal ~printer:string_of_int 6 (BV.cardinal bv);
+  let l = BV.to_list bv in
+  let l = List.sort compare l in
+  assert_equal [0;1;5;156;201;222] l;
+  ()
+
+let test_clear () =
+  let bv = BV.of_list [1; 5; 200] in
+  assert_equal ~printer:string_of_int 3 (BV.cardinal bv);
+  BV.clear bv;
+  assert_equal ~printer:string_of_int 0 (BV.cardinal bv);
+  assert_bool "must be empty" (BV.is_empty bv);
+  ()
+
+let test_union () =
+  let bv1 = BV.of_list [1;2;3;4] in
+  let bv2 = BV.of_list [4;200;3] in
+  let bv = BV.union bv1 bv2 in
+  let l = List.sort compare (BV.to_list bv) in
+  assert_equal [1;2;3;4;200] l;
+  ()
+
+let test_inter () =
+  let bv1 = BV.of_list [1;2;3;4] in
+  let bv2 = BV.of_list [4;200;3] in
+  BV.inter_into ~into:bv1 bv2;
+  let l = List.sort compare (BV.to_list bv1) in
+  assert_equal [3;4] l;
+  ()
+
+let test_select () =
+  let bv = BV.of_list [1;2;5;400] in
+  let arr = [|"a"; "b"; "c"; "d"; "e"; "f"|] in
+  let l = List.sort compare (BV.select bv arr) in
+  assert_equal [("b",1); ("c",2); ("f",5)] l;
+  ()
+
+let suite = "test_bv" >:::
+  [ "test_cardinal" >:: test_cardinal
+  ; "test_get" >:: test_get
+  ; "test_list" >:: test_list
+  ; "test_clear" >:: test_clear
+  ; "test_union" >:: test_union
+  ; "test_inter" >:: test_inter
+  ; "test_select" >:: test_select
+  ]