Merge branch 'master' into fixed-max-length

Author: backtracking

CHANGES.md

@@ -1,5 +1,7 @@
 
   - fixed negative `max_length` on JavaScript platform
+  - new function `random` (much faster than `init n (fun _ -> Random.bool ())`
+  - new in-place bitwise operations (contribution by Mathieu Barbin)
   - fixed division by zero in rotations of 0-length vectors
     (reported by Nikolaus Huber)
   - fixed integer overflows in bound tests in `fill`, `blit`, `sub`

bench.ml

@@ -3,11 +3,9 @@
 
 open Bitv
 
+let () = Random.self_init ()
 let n = int_of_string Sys.argv.(1)
-let v = init n (fun i -> i mod 5 = 0)
-let r = ref 0
-let add i = r := !r + i
-let () = iteri_true add v
-let () = Format.printf "%d@." !r
+(* let v = init n (fun _ -> Random.bool ()) *)
+let v = random n (* much faster *)
 
 

bitv.ml

@@ -94,6 +94,20 @@ let init n f =
   for i = 0 to pred n do unsafe_set v i (f i) done;
   v
 
+let random n =
+  let v = create n false in
+  let b = v.bits in
+  let n = Bytes.length b in
+  for i = 0 to n / 3 do let j = 3 * i in
+    let bits = Random.bits () in
+    set_byte b j     (bits          land 0xFF);
+    set_byte b (j+1) ((bits lsr  8) land 0xFF);
+    set_byte b (j+2) ((bits lsr 16) land 0xFF)
+  done;
+  for i = 3 * (n / 3) to n - 1 do set_byte b i (Random.int 256) done;
+  normalize v;
+  v
+
 let fill v ofs len b =
   if ofs < 0 || len < 0 || ofs > v.length - len then invalid_arg "Bitv.fill";
   if len > 0 then (
@@ -216,52 +230,96 @@ let pop v =
    However, one has to take care of normalizing the result of [bwnot]
    which introduces ones in highest significant positions. *)
 
+let[@inline always] bw_and_in_place_internal ~dest ~n b1 b2 =
+  for i = 0 to n - 1 do
+    set_byte dest i ((byte b1 i) land (byte b2 i))
+  done
+
+let bw_and_in_place ~dest v1 v2 =
+  let l = v1.length in
+  if l <> v2.length || l <> dest.length then invalid_arg "Bitv.bw_and_in_place";
+  let b1 = v1.bits
+  and b2 = v2.bits in
+  let n = Bytes.length b1 in
+  bw_and_in_place_internal ~dest:dest.bits ~n b1 b2
+
 let bw_and v1 v2 =
   let l = v1.length in
   if l <> v2.length then invalid_arg "Bitv.bw_and";
   let b1 = v1.bits
   and b2 = v2.bits in
   let n = Bytes.length b1 in
   let a = Bytes.make n (Char.chr 0) in
-  for i = 0 to n - 1 do
-    set_byte a i ((byte b1 i) land (byte b2 i))
-  done;
+  bw_and_in_place_internal ~dest:a ~n b1 b2;
   { length = l; bits = a }
 
+let[@inline always] bw_or_in_place_internal ~dest ~n b1 b2 =
+  for i = 0 to n - 1 do
+    set_byte dest i ((byte b1 i) lor (byte b2 i))
+  done
+
+let bw_or_in_place ~dest v1 v2 =
+  let l = v1.length in
+  if l <> v2.length || l <> dest.length then invalid_arg "Bitv.bw_or_in_place";
+  let b1 = v1.bits
+  and b2 = v2.bits in
+  let n = Bytes.length b1 in
+  bw_or_in_place_internal ~dest:dest.bits ~n b1 b2
+
 let bw_or v1 v2 =
   let l = v1.length in
   if l <> v2.length then invalid_arg "Bitv.bw_or";
   let b1 = v1.bits
   and b2 = v2.bits in
   let n = Bytes.length b1 in
   let a = Bytes.make n (Char.chr 0) in
-  for i = 0 to n - 1 do
-    set_byte a i ((byte b1 i) lor (byte b2 i))
-  done;
+  bw_or_in_place_internal ~dest:a ~n b1 b2;
   { length = l; bits = a }
 
+let[@inline always] bw_xor_in_place_internal ~dest ~n b1 b2 =
+  for i = 0 to n - 1 do
+    set_byte dest i ((byte b1 i) lxor (byte b2 i))
+  done
+
+let bw_xor_in_place ~dest v1 v2 =
+  let l = v1.length in
+  if l <> v2.length || l <> dest.length then invalid_arg "Bitv.bw_xor_in_place";
+  let b1 = v1.bits
+  and b2 = v2.bits in
+  let n = Bytes.length b1 in
+  bw_xor_in_place_internal ~dest:dest.bits ~n b1 b2
+
 let bw_xor v1 v2 =
   let l = v1.length in
-  if l <> v2.length then invalid_arg "Bitv.bw_or";
+  if l <> v2.length then invalid_arg "Bitv.bw_xor";
   let b1 = v1.bits
   and b2 = v2.bits in
   let n = Bytes.length b1 in
   let a = Bytes.make n (Char.chr 0) in
+  bw_xor_in_place_internal ~dest:a ~n b1 b2;
+  { length = l; bits = a }
+
+let[@inline always] bw_not_in_place_internal ~dest ~n b =
+  let a = dest.bits in
   for i = 0 to n - 1 do
-    set_byte a i ((byte b1 i) lxor (byte b2 i))
+    set_byte a i (255 land (lnot (byte b i)))
   done;
-  { length = l; bits = a }
+  normalize dest
+
+let bw_not_in_place ~dest v =
+  let l = v.length in
+  if l <> dest.length then invalid_arg "Bitv.bw_not_in_place";
+  let b = v.bits in
+  let n = Bytes.length b in
+  bw_not_in_place_internal ~dest ~n b
 
 let bw_not v =
   let b = v.bits in
   let n = Bytes.length b in
   let a = Bytes.make n (Char.chr 0) in
-  for i = 0 to n - 1 do
-    set_byte a i (255 land (lnot (byte b i)))
-  done;
-  let r = { length = v.length; bits = a } in
-  normalize r;
-  r
+  let dest = { length = v.length; bits = a } in
+  bw_not_in_place_internal ~dest ~n b;
+  dest
 
 (* Coercions to/from lists of integers *)
 

bitv.mli

@@ -33,6 +33,11 @@ val init : int -> (int -> bool) -> t
 (** [(Bitv.init n f)] returns a fresh vector of length [n],
     with bit number [i] initialized to the result of [(f i)]. *)
 
+val random: int -> t
+(** [Bitv.random n] returns a fresh vector of length [n] with random bits.
+    This is equivalent to [Bitv.init n (fun _ -> Random.bool ())],
+    but much faster. *)
+
 val set : t -> int -> bool -> unit
 (** [(Bitv.set v n b)] sets the [n]th bit of [v] to the value [b]. *)
 
@@ -177,6 +182,34 @@ val rotatel : t -> int -> t
 val rotater : t -> int -> t
 (** moves bits from most to least significant with wraparound *)
 
+(** {3 Bitwise in place operations.}
+
+    This part of the API extends some bitwise operations by making them operate
+    in place, that is mutating a destination bit vector supplied as a labeled
+    argument [dest], rather than returning a fresh one.
+
+    These in place operations support being called with [dest] being one of the
+    operands supplied to the function call.
+
+    For example [bw_and_in_place ~dest:a a b] will store in [a] the result of
+    the operation [bw_and a b]. *)
+
+val bw_and_in_place : dest:t -> t -> t -> unit
+(** bitwise AND in place into [dest];
+    raises [Invalid_argument] if the three vectors do not have the same length *)
+
+val bw_or_in_place : dest:t -> t -> t -> unit
+(** bitwise OR in place into [dest];
+    raises [Invalid_argument] if the three vectors do not have the same length *)
+
+val bw_xor_in_place : dest:t -> t -> t -> unit
+(** bitwise XOR in place into [dest];
+    raises [Invalid_argument] if the three vectors do not have the same length *)
+
+val bw_not_in_place : dest:t -> t -> unit
+(** bitwise NOT in place into [dest];
+    raises [Invalid_argument] if the two vectors do not have the same length *)
+
 (** {2 Test functions} *)
 
 val all_zeros : t -> bool

test.ml

@@ -45,6 +45,35 @@ let s = sub v 2 4
 let () = assert (equal (bw_not (bw_not s)) s)
 let () = assert (equal (bw_and e e) e)
 
+(* bitwise in place operations *)
+let va = init 10 (fun i -> i mod 2 = 0)
+let vb = init 10 (fun i -> i mod 4 = 0)
+let vc = create 10 false
+let ve = create 3 false
+let () =
+  assert (to_string va = "0101010101");
+  assert (to_string vb = "0100010001");
+  bw_and_in_place ~dest:vc va vb;
+  assert (equal vc (bw_and va vb));
+  assert (equal vc vb);
+  (try bw_and_in_place ~dest:ve va vb; assert false
+   with Invalid_argument msg -> assert (msg = "Bitv.bw_and_in_place"));
+  bw_or_in_place ~dest:vc va vb;
+  assert (equal vc (bw_or va vb));
+  assert (equal vc va);
+  (try bw_or_in_place ~dest:ve va vb; assert false
+   with Invalid_argument msg -> assert (msg = "Bitv.bw_or_in_place"));
+  bw_xor_in_place ~dest:vc va vb;
+  assert (equal vc (bw_xor va vb));
+  assert (to_string vc = "0001000100");
+  (try bw_xor_in_place ~dest:ve va vb; assert false
+   with Invalid_argument msg -> assert (msg = "Bitv.bw_xor_in_place"));
+  bw_not_in_place ~dest:vc va;
+  assert (to_string vc = "1010101010");
+  (try bw_not_in_place ~dest:ve va; assert false
+   with Invalid_argument msg -> assert (msg = "Bitv.bw_not_in_place"));
+  ()
+
 (* Tanimoto score *)
 let () =
   let b0 = create 10 false in
@@ -235,6 +264,10 @@ let () = assert (equal (bw_or v ones) ones)
 let () = assert (equal (bw_and v ones) v)
 let () = assert (equal (bw_xor v zeros) v)
 let () = assert (equal (bw_xor v ones) (bw_not v))
+let () =
+  let dest = create 30 false in
+  bw_not_in_place ~dest v;
+  assert (equal (bw_xor v ones) dest)
 
 (* fill overflow *)
 let () =