diff --git a/Makefile b/Makefile index f70f36e6..600c94ca 100644 --- a/Makefile +++ b/Makefile @@ -6,7 +6,7 @@ build: dune build @install -p $(PACKAGES) test: build - dune runtest --cache=disabled --no-buffer --force + dune runtest --display=quiet --cache=disabled --no-buffer --force clean: dune clean diff --git a/src/core/CCInt32.ml b/src/core/CCInt32.ml index fbf4fa74..dd78fc63 100644 --- a/src/core/CCInt32.ml +++ b/src/core/CCInt32.ml @@ -27,6 +27,20 @@ let pow a b = raise (Invalid_argument "pow: can't raise int to negative power") | b -> aux a b +(* see {!CCInt.popcount} for more details *) +let[@inline] popcount (b : t) : int = + let m1 = 0x55555555l in + let m2 = 0x33333333l in + let m4 = 0x0f0f0f0fl in + + let b = sub b (logand (shift_right_logical b 1) m1) in + let b = add (logand b m2) (logand (shift_right_logical b 2) m2) in + let b = logand (add b (shift_right_logical b 4)) m4 in + let b = add b (shift_right_logical b 8) in + let b = add b (shift_right_logical b 16) in + let b = logand b 0x7fl in + to_int b + let floor_div a n = if compare a 0l < 0 && compare n 0l >= 0 then sub (div (add a 1l) n) 1l diff --git a/src/core/CCInt32.mli b/src/core/CCInt32.mli index 0be48a3b..8086d18f 100644 --- a/src/core/CCInt32.mli +++ b/src/core/CCInt32.mli @@ -41,6 +41,10 @@ val pow : t -> t -> t Raises [Invalid_argument] if [x = y = 0] or [y] < 0. @since 0.11 *) +val popcount : t -> int +(** Number of bits set to 1. + @since NEXT_RELEASE *) + val floor_div : t -> t -> t (** [floor_div x n] is integer division rounding towards negative infinity. It satisfies [x = m * floor_div x n + rem x n]. diff --git a/src/core/CCInt64.ml b/src/core/CCInt64.ml index 35997834..d8802983 100644 --- a/src/core/CCInt64.ml +++ b/src/core/CCInt64.ml @@ -8,6 +8,21 @@ let max : t -> t -> t = Stdlib.max let hash x = Stdlib.abs (to_int x) let sign i = compare i zero +(* see {!CCInt.popcount} for more details *) +let[@inline] popcount (b : t) : int = + let m1 = 0x5555555555555555L in + let m2 = 0x3333333333333333L in + let m4 = 0x0f0f0f0f0f0f0f0fL in + + let b = sub b (logand (shift_right_logical b 1) m1) in + let b = add (logand b m2) (logand (shift_right_logical b 2) m2) in + let b = logand (add b (shift_right_logical b 4)) m4 in + let b = add b (shift_right_logical b 8) in + let b = add b (shift_right_logical b 16) in + let b = add b (shift_right_logical b 32) in + let b = logand b 0x7fL in + to_int b + let pow a b = let rec aux acc = function | 1L -> acc diff --git a/src/core/CCInt64.mli b/src/core/CCInt64.mli index 30e2a764..eee5b711 100644 --- a/src/core/CCInt64.mli +++ b/src/core/CCInt64.mli @@ -30,6 +30,10 @@ val hash : t -> int (** [hash x] computes the hash of [x]. Like {!Stdlib.abs (to_int x)}. *) +val popcount : t -> int +(** Number of bits set to 1. + @since NEXT_RELEASE *) + val sign : t -> int (** [sign x] return [0] if [x = 0], [-1] if [x < 0] and [1] if [x > 0]. Same as [compare x zero]. diff --git a/src/data/CCBV.ml b/src/data/CCBV.ml index a3d12b5e..2f624271 100644 --- a/src/data/CCBV.ml +++ b/src/data/CCBV.ml @@ -1,186 +1,271 @@ -(** {2 Imperative Bitvectors} *) +let width_ = 8 -(* TODO: move to [bytes] and replace all [mod] and [/] with bitshifts - because width_=8 *) +(* Helper functions *) +let[@inline] get_ b i = Char.code (Bytes.get b i) +let[@inline] unsafe_get_ b i = Char.code (Bytes.unsafe_get b i) +let[@inline] set_ b i v = Bytes.set b i (Char.unsafe_chr v) +let[@inline] unsafe_set_ b i v = Bytes.unsafe_set b i (Char.unsafe_chr v) +let[@inline] mod_ n = n land 0b111 +let[@inline] div_ n = n lsr 3 +let[@inline] mul_ n = n lsl 3 +let zero = Char.unsafe_chr 0 -let width_ = Sys.word_size - 1 +(* 0b11111111 *) +let all_ones_ = Char.unsafe_chr ((1 lsl width_) - 1) +let () = assert (all_ones_ = Char.chr 0b1111_1111) -(** We use OCamls ints to store the bits. We index them from the - least significant bit. We create masks to zero out the most significant - bits that aren't used to store values. This is necessary when we are - constructing or negating a bit vector. *) -let lsb_masks_ = - let a = Array.make (width_ + 1) 0 in - for i = 1 to width_ do - a.(i) <- a.(i - 1) lor (1 lsl (i - 1)) - done; - a +(* [lsb_mask_ n] is [0b111111] with [n] ones. *) +let[@inline] __lsb_mask n = (1 lsl n) - 1 -let all_ones_ = lsb_masks_.(width_) +(* + from https://en.wikipedia.org/wiki/Hamming_weight -(* 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 - recurse 0 n + //This uses fewer arithmetic operations than any other known + //implementation on machines with slow multiplication. + //It uses 17 arithmetic operations. + int popcount_2(uint64_t x) { + x -= (x >> 1) & m1; //put count of each 2 bits into those 2 bits + x = (x & m2) + ((x >> 2) & m2); //put count of each 4 bits into those 4 bits + x = (x + (x >> 4)) & m4; //put count of each 8 bits into those 8 bits -(* Can I access the "private" members in testing? $Q - (Q.int_bound (Sys.word_size - 1)) (fun i -> count_bits_ lsb_masks_.(i) = i) + // not necessary for int8 + // x += x >> 8; //put count of each 16 bits into their lowest 8 bits + // x += x >> 16; //put count of each 32 bits into their lowest 8 bits + // x += x >> 32; //put count of each 64 bits into their lowest 8 bits + + return x & 0x7f; + } + + m1 = 0x5555555555555555 + m2 = 0x3333333333333333 + m4 = 0x0f0f0f0f0f0f0f0f *) +let[@inline] __popcount8 (b : int) : int = + let m1 = 0x55 in + let m2 = 0x33 in + let m4 = 0x0f in -type t = { mutable a: int array; mutable size: int } + let b = b - ((b lsr 1) land m1) in + let b = (b land m2) + ((b lsr 2) land m2) in + let b = (b + (b lsr 4)) land m4 in + b land 0x7f + +(* + invariants for [v:t]: + + - [Bytes.length v.b >= div_ v.size] (enough storage) + - all bits above [size] are 0 in [v.b] +*) +type t = { mutable b: bytes; mutable size: int } let length t = t.size -let empty () = { a = [||]; size = 0 } +let empty () = { b = Bytes.empty; size = 0 } -let array_length_of_size size = - if size mod width_ = 0 then - size / width_ +let bytes_length_of_size size = + if mod_ size = 0 then + div_ size else - (size / width_) + 1 + div_ size + 1 -let create ~size default = +let create ~size default : t = if size = 0 then - { a = [||]; size } + empty () else ( - let n = array_length_of_size size in - let a = + let n = bytes_length_of_size size in + let b = if default then - Array.make n all_ones_ + Bytes.make n all_ones_ else - Array.make n 0 + Bytes.make n zero in (* adjust last bits *) - let r = size mod width_ in - if default && r <> 0 then Array.unsafe_set a (n - 1) lsb_masks_.(r); - { a; size } + let r = mod_ size in + if default && r <> 0 then unsafe_set_ b (n - 1) (__lsb_mask r); + { b; size } ) -let copy bv = { bv with a = Array.copy bv.a } -let capacity bv = width_ * Array.length bv.a +let copy bv = { bv with b = Bytes.sub bv.b 0 (bytes_length_of_size bv.size) } +let[@inline] capacity bv = mul_ (Bytes.length bv.b) + +(* call [f i width(byte[i]) (byte[i])] on each byte. + The last byte might have a width of less than 8. *) +let iter_bytes_ (b : t) ~f : unit = + for n = 0 to div_ b.size - 1 do + f (mul_ n) width_ (unsafe_get_ b.b n) + done; + let r = mod_ b.size in + if r <> 0 then ( + let last = div_ b.size in + f (mul_ last) r (__lsb_mask r land unsafe_get_ b.b last) + ) + +(* set [byte[i]] to [f(byte[i])] *) +let map_bytes_ (b : t) ~f : unit = + for n = 0 to div_ b.size - 1 do + unsafe_set_ b.b n (f (unsafe_get_ b.b n)) + done; + let r = mod_ b.size in + if r <> 0 then ( + let last = div_ b.size in + let mask = __lsb_mask r in + unsafe_set_ b.b last (mask land f (mask land unsafe_get_ b.b last)) + ) let cardinal bv = if bv.size = 0 then 0 else ( let n = ref 0 in - for i = 0 to Array.length bv.a - 1 do - n := !n + count_bits_ bv.a.(i) (* MSB of last element are all 0 *) - done; + iter_bytes_ bv ~f:(fun _ _ b -> n := !n + __popcount8 b); !n ) let really_resize_ bv ~desired ~current size = - let a' = Array.make desired 0 in - Array.blit bv.a 0 a' 0 current; - bv.a <- a'; - bv.size <- size + bv.size <- size; + if desired <> current then ( + let b = Bytes.make desired zero in + Bytes.blit bv.b 0 b 0 (min desired current); + bv.b <- b + ) -let grow_ bv size = - if size <= capacity bv (* within capacity *) then +(* set bits above [n] to 0 *) +let[@inline never] clear_bits_above_ bv top = + let n = div_ top in + let j = mod_ top in + Bytes.fill bv.b (n + 1) + (bytes_length_of_size bv.size - n - 1) + (Char.unsafe_chr 0); + unsafe_set_ bv.b n (unsafe_get_ bv.b n land __lsb_mask j) + +let[@inline never] grow_to_at_least_real_ bv size = + (* beyond capacity *) + let current = Bytes.length bv.b in + let desired = bytes_length_of_size size in + let desired = + min Sys.max_string_length (max desired (current + (current / 2))) + in + assert (desired > current); + really_resize_ bv ~desired ~current size + +let grow_to_at_least_ bv size = + if size <= capacity bv then + (* within capacity *) bv.size <- size - else ( - (* beyond capacity *) - let desired = array_length_of_size size in - let current = Array.length bv.a in - assert (desired > current); + else + (* resize. This is a separate function so it's easier to + inline the happy path. *) + grow_to_at_least_real_ bv size + +let shrink_ bv size = + assert (size <= bv.size); + if size < bv.size then ( + let desired = bytes_length_of_size size in + let current = Bytes.length bv.b in + clear_bits_above_ bv size; really_resize_ bv ~desired ~current size ) -let shrink_ bv size = - let desired = array_length_of_size size in - let current = Array.length bv.a in - really_resize_ bv ~desired ~current size - let resize bv size = if size < 0 then invalid_arg "resize: negative size"; - if size < bv.size (* shrink *) then + if size < bv.size then ( + clear_bits_above_ bv size; + bv.size <- size + ) else if size > bv.size then + grow_to_at_least_ bv size + +let resize_minimize_memory bv size = + if size < 0 then invalid_arg "resize: negative size"; + if size < bv.size then shrink_ bv size - else if size = bv.size then - () - else - grow_ bv size + else if size > bv.size then + grow_to_at_least_ bv size let is_empty bv = + bv.size = 0 + || try - for i = 0 to Array.length bv.a - 1 do - if bv.a.(i) <> 0 then raise Exit (* MSB of last element are all 0 *) + for i = 0 to bytes_length_of_size bv.size - 1 do + if unsafe_get_ bv.b i <> 0 then raise_notrace Exit done; true with Exit -> false -let get bv i = +let[@inline] get bv i = if i < 0 then invalid_arg "get: negative index"; - let n = i / width_ in - let i = i mod width_ in - if n < Array.length bv.a then - Array.unsafe_get bv.a n land (1 lsl i) <> 0 + let idx_bucket = div_ i in + let idx_in_byte = mod_ i in + if idx_bucket < Bytes.length bv.b then + unsafe_get_ bv.b idx_bucket land (1 lsl idx_in_byte) <> 0 else false -let set bv i = +let[@inline] set bv i = if i < 0 then invalid_arg "set: negative index" else ( - let n = i / width_ in - let j = i mod width_ in - if i >= bv.size then grow_ bv (i + 1); - Array.unsafe_set bv.a n (Array.unsafe_get bv.a n lor (1 lsl j)) + let idx_bucket = div_ i in + let idx_in_byte = mod_ i in + if i >= bv.size then grow_to_at_least_ bv (i + 1); + unsafe_set_ bv.b idx_bucket + (unsafe_get_ bv.b idx_bucket lor (1 lsl idx_in_byte)) ) -let reset bv i = +let init size f : t = + let v = create ~size false in + for i = 0 to size - 1 do + if f i then set v i + done; + v + +let[@inline] reset bv i = if i < 0 then invalid_arg "reset: negative index" else ( - let n = i / width_ in - let j = i mod width_ in - if i >= bv.size then grow_ bv (i + 1); - Array.unsafe_set bv.a n (Array.unsafe_get bv.a n land lnot (1 lsl j)) + let n = div_ i in + let j = mod_ i in + if i >= bv.size then grow_to_at_least_ bv (i + 1); + unsafe_set_ bv.b n (unsafe_get_ bv.b n land lnot (1 lsl j)) ) +let[@inline] set_bool bv i b = + if b then + set bv i + else + reset bv i + let flip bv i = if i < 0 then invalid_arg "reset: negative index" else ( - let n = i / width_ in - let j = i mod width_ in - if i >= bv.size then grow_ bv (i + 1); - Array.unsafe_set bv.a n (Array.unsafe_get bv.a n lxor (1 lsl j)) + let n = div_ i in + let j = mod_ i in + if i >= bv.size then grow_to_at_least_ bv (i + 1); + unsafe_set_ bv.b n (unsafe_get_ bv.b n lxor (1 lsl j)) ) -let clear bv = Array.fill bv.a 0 (Array.length bv.a) 0 -let equal x y : bool = x.size = y.size && x.a = y.a +let clear bv = Bytes.fill bv.b 0 (Bytes.length bv.b) zero + +let clear_and_shrink bv = + clear bv; + bv.size <- 0 + +let equal_bytes_ size b1 b2 = + try + for i = 0 to bytes_length_of_size size - 1 do + if Bytes.get b1 i <> Bytes.get b2 i then raise_notrace Exit + done; + true + with Exit -> false + +let equal x y : bool = x.size = y.size && equal_bytes_ x.size x.b y.b let iter bv f = - let len = array_length_of_size bv.size in - assert (len <= Array.length bv.a); - for n = 0 to len - 2 do - let j = width_ * n in - let word_n = Array.unsafe_get bv.a n in - for i = 0 to width_ - 1 do - f (j + i) (word_n land (1 lsl i) <> 0) - done - done; - if bv.size > 0 then ( - let j = width_ * (len - 1) in - let r = bv.size mod width_ in - let final_length = - if r = 0 then - width_ - else - r - in - let final_word = Array.unsafe_get bv.a (len - 1) in - for i = 0 to final_length - 1 do - f (j + i) (final_word land (1 lsl i) <> 0) - done - ) + iter_bytes_ bv ~f:(fun off width_n word_n -> + for i = 0 to width_n - 1 do + f (off + i) (word_n land (1 lsl i) <> 0) + done) -let[@inline] iter_true bv f = +let iter_true bv f = iter bv (fun i b -> if b then f i @@ -196,7 +281,11 @@ let to_sorted_list bv = List.rev (to_list bv) (* Interpret these as indices. *) let of_list l = - let size = List.fold_left max 0 l + 1 in + let size = + match l with + | [] -> 0 + | _ -> List.fold_left max 0 l + 1 + in let bv = create ~size false in List.iter (fun i -> set bv i) l; bv @@ -205,43 +294,28 @@ exception FoundFirst of int let first_exn bv = try - iter_true bv (fun i -> raise (FoundFirst i)); + iter_true bv (fun i -> raise_notrace (FoundFirst i)); raise Not_found with FoundFirst i -> i let first bv = try Some (first_exn bv) with Not_found -> None let filter bv p = iter_true bv (fun i -> if not (p i) then reset bv i) +let negate_self bv = map_bytes_ bv ~f:(fun b -> lnot b) -let negate_self b = - let len = Array.length b.a in - for n = 0 to len - 1 do - Array.unsafe_set b.a n (lnot (Array.unsafe_get b.a n)) - done; - let r = b.size mod width_ in - if r <> 0 then ( - let l = Array.length b.a - 1 in - Array.unsafe_set b.a l (lsb_masks_.(r) land Array.unsafe_get b.a l) - ) - -let negate b = - let a = Array.map lnot b.a in - let r = b.size mod width_ in - if r <> 0 then ( - let l = Array.length b.a - 1 in - Array.unsafe_set a l (lsb_masks_.(r) land Array.unsafe_get a l) - ); - { a; size = b.size } +let negate a = + let b = copy a in + negate_self b; + b let union_into_no_resize_ ~into bv = - assert (Array.length into.a >= Array.length bv.a); - for i = 0 to Array.length bv.a - 1 do - Array.unsafe_set into.a i - (Array.unsafe_get into.a i lor Array.unsafe_get bv.a i) + assert (Bytes.length into.b >= bytes_length_of_size bv.size); + for i = 0 to bytes_length_of_size bv.size - 1 do + unsafe_set_ into.b i (unsafe_get_ into.b i lor unsafe_get_ bv.b i) done (* Underlying size grows for union. *) let union_into ~into bv = - if into.size < bv.size then grow_ into bv.size; + if into.size < bv.size then grow_to_at_least_ into bv.size; union_into_no_resize_ ~into bv (* To avoid potentially 2 passes, figure out what we need to copy. *) @@ -257,10 +331,9 @@ let union b1 b2 = ) let inter_into_no_resize_ ~into bv = - assert (Array.length into.a <= Array.length bv.a); - for i = 0 to Array.length into.a - 1 do - Array.unsafe_set into.a i - (Array.unsafe_get into.a i land Array.unsafe_get bv.a i) + assert (into.size <= bv.size); + for i = 0 to bytes_length_of_size into.size - 1 do + unsafe_set_ into.b i (unsafe_get_ into.b i land unsafe_get_ bv.b i) done (* Underlying size shrinks for inter. *) @@ -279,13 +352,12 @@ let inter b1 b2 = into ) -(* Underlying size depends on the 'in_' set for diff, so we don't change - it's size! *) +(* Underlying size depends on the [in_] set for diff, so we don't change + its size! *) let diff_into ~into bv = - let n = min (Array.length into.a) (Array.length bv.a) in + let n = min (Bytes.length into.b) (Bytes.length bv.b) in for i = 0 to n - 1 do - Array.unsafe_set into.a i - (Array.unsafe_get into.a i land lnot (Array.unsafe_get bv.a i)) + unsafe_set_ into.b i (unsafe_get_ into.b i land lnot (unsafe_get_ bv.b i)) done let diff in_ not_in = @@ -298,7 +370,7 @@ let select bv arr = (try iter_true bv (fun i -> if i >= Array.length arr then - raise Exit + raise_notrace Exit else l := arr.(i) :: !l) with Exit -> ()); @@ -309,7 +381,7 @@ let selecti bv arr = (try iter_true bv (fun i -> if i >= Array.length arr then - raise Exit + raise_notrace Exit else l := (arr.(i), i) :: !l) with Exit -> ()); @@ -338,4 +410,24 @@ let pp out bv = '0')); Format.pp_print_string out "}" -let __to_word_l bv = Array.to_list bv.a +module Internal_ = struct + let __to_word_l bv = + let l = ref [] in + Bytes.iter (fun c -> l := c :: !l) bv.b; + List.rev !l + + let __popcount8 = __popcount8 + let __lsb_mask = __lsb_mask + + let __check_invariant self = + let n = div_ self.size in + let j = mod_ self.size in + assert (Bytes.length self.b >= n); + if j > 0 then + assert ( + let c = get_ self.b n in + c land __lsb_mask j = c); + for i = n + 1 to Bytes.length self.b - 1 do + assert (get_ self.b i = 0) + done +end diff --git a/src/data/CCBV.mli b/src/data/CCBV.mli index 4f3b744d..af726dd8 100644 --- a/src/data/CCBV.mli +++ b/src/data/CCBV.mli @@ -1,6 +1,8 @@ -(* This file is free software, part of containers. See file "license" for more details. *) +(** Imperative Bitvectors. -(** Imperative Bitvectors + A bitvector is stored in some form of internal array (on the heap). + Is it a bit similar to a more storage-efficient version of [bool + CCVector.vector], with additional operations. {b BREAKING CHANGES} since 1.2: size is now stored along with the bitvector. Some functions have @@ -15,10 +17,16 @@ type t (** A resizable bitvector *) val empty : unit -> t -(** Empty bitvector. *) +(** Empty bitvector. Length is 0. *) val create : size:int -> bool -> t -(** Create a bitvector of given size, with given default value. *) +(** Create a bitvector of given size, with given default value. + Length of result is [size]. *) + +val init : int -> (int -> bool) -> t +(** [init len f] initializes a bitvector of length [len], where bit [i] + is true iff [f i] is. + @since NEXT_RELEASE *) val copy : t -> t (** Copy of bitvector. *) @@ -38,10 +46,16 @@ val capacity : t -> int @since 1.2 *) val resize : t -> int -> unit -(** Resize the BV so that it has the specified length. This can grow or shrink - the underlying bitvector. +(** Resize the BV so that it has the specified length. This can grow + the underlying array, but it will not shrink it, to minimize + memory traffic. + @raise Invalid_argument on negative sizes. *) - @raise Invalid_arg on negative sizes. *) +val resize_minimize_memory : t -> int -> unit +(** Same as {!resize}, but this can also shrink the underlying + array if this reduces the size. + @raise Invalid_argument on negative sizes. + @since NEXT_RELEASE *) val is_empty : t -> bool (** Are there any true bits? *) @@ -55,11 +69,19 @@ val get : t -> int -> bool val reset : t -> int -> unit (** Set i-th bit to 0, extending the bitvector if needed. *) +val set_bool : t -> int -> bool -> unit +(** Set or reset [i]-th bit. + @since NEXT_RELEASE *) + val flip : t -> int -> unit (** Flip i-th bit, extending the bitvector if needed. *) val clear : t -> unit -(** Set every bit to 0. *) +(** Set every bit to 0. Does not change the length. *) + +val clear_and_shrink : t -> unit +(** Set every bit to 0, and set length to 0. + @since NEXT_RELEASE *) val iter : t -> (int -> bool -> unit) -> unit (** Iterate on all bits. *) @@ -92,15 +114,17 @@ val first_exn : t -> int val filter : t -> (int -> bool) -> unit (** [filter bv p] only keeps the true bits of [bv] whose [index] - satisfies [p index]. *) + satisfies [p index]. + Length is unchanged. *) val negate_self : t -> unit -(** [negate_self t] flips all of the bits in [t]. +(** [negate_self t] flips all of the bits in [t]. Length is unchanged. @since 1.2 *) val negate : t -> t -(** [negate t] returns a copy of [t] with all of the bits flipped. *) +(** [negate t] returns a copy of [t] with all of the bits flipped. + Length is unchanged. *) val union_into : into:t -> t -> unit (** [union_into ~into bv] sets [into] to the union of itself and [bv]. @@ -108,13 +132,20 @@ val union_into : into:t -> t -> unit val inter_into : into:t -> t -> unit (** [inter_into ~into bv] sets [into] to the intersection of itself and [bv]. - Also updates the length of [into] to be at most [length bv]. *) + Also updates the length of [into] to be at most [length bv]. + + After executing: + - [length ~into' = min (length into) (length bv)]. + - [for all i: get into' ==> get into i /\ get bv i] + *) val union : t -> t -> t -(** [union bv1 bv2] returns the union of the two sets. *) +(** [union bv1 bv2] returns the union of the two sets. The length + of the result is the max of the inputs' lengths. *) val inter : t -> t -> t -(** [inter bv1 bv2] returns the intersection of the two sets. *) +(** [inter bv1 bv2] returns the intersection of the two sets. The length + of the result is the min of the inputs' lengths. *) val diff_into : into:t -> t -> unit (** [diff_into ~into t] modifies [into] with only the bits set but not in [t]. @@ -142,7 +173,10 @@ val equal : t -> t -> bool type 'a iter = ('a -> unit) -> unit val to_iter : t -> int iter +(** Iterate over the true bits. *) + val of_iter : int iter -> t +(** Build from true bits. *) val pp : Format.formatter -> t -> unit (** Print the bitvector as a string of bits. @@ -150,6 +184,11 @@ val pp : Format.formatter -> t -> unit (**/**) -val __to_word_l : t -> int list +module Internal_ : sig + val __to_word_l : t -> char list + val __popcount8 : int -> int + val __lsb_mask : int -> int + val __check_invariant : t -> unit +end (**/**) diff --git a/src/testlib/containers_testlib.ml b/src/testlib/containers_testlib.ml index 12914132..63a7264f 100644 --- a/src/testlib/containers_testlib.ml +++ b/src/testlib/containers_testlib.ml @@ -7,21 +7,29 @@ type 'a print = 'a -> string module Test = struct type run = - | T of (unit -> bool) + | T of { prop: unit -> bool } | Eq : { eq: 'a eq option; print: 'a print option; lhs: 'a; rhs: 'a } -> run | Q : { count: int option; arb: 'a Q.arbitrary; prop: 'a -> bool; long_factor: int option; + max_gen: int option; + max_fail: int option; + if_assumptions_fail: ([ `Fatal | `Warning ] * float) option; } -> run - type t = { run: run; __FILE__: string; n: int } + type t = { name: string option; run: run; __FILE__: string; n: int } (** Location for this test *) let str_loc (self : t) : string = - Printf.sprintf "(test :file '%s' :n %d)" self.__FILE__ self.n + let what = + match self.name with + | None -> "" + | Some f -> spf " :name %S" f + in + Printf.sprintf "(test :file '%s'%s :n %d)" self.__FILE__ what self.n [@@@ifge 4.08] @@ -36,14 +44,17 @@ module Test = struct [@@@endif] - let run ~seed (self : t) : _ result = + let run ?(long = false) ~seed (self : t) : _ result = match + let what = CCOption.map_or ~default:"" (fun s -> s ^ " ") self.name in match self.run with - | T f -> - if f () then - Ok () - else - Error "failed: returns false" + | T { prop } -> + let fail msg = Error (spf "%sfailed: %s" what msg) in + + (match prop () with + | exception e -> fail (spf "raised %s" (Printexc.to_string e)) + | true -> Ok () + | false -> fail "returns false") | Eq { eq; print; lhs; rhs } -> let eq = match eq with @@ -55,12 +66,22 @@ module Test = struct else ( let msg = match print with - | None -> "failed: not equal" - | Some p -> spf "failed: not equal:\nlhs=%s\nrhs=%s" (p lhs) (p rhs) + | None -> spf "%sfailed: not equal" what + | Some p -> + spf "%s failed: not equal:\nlhs=%s\nrhs=%s" what (p lhs) (p rhs) in Error msg ) - | Q { count; arb; prop; long_factor } -> + | Q + { + count; + arb; + prop; + long_factor; + max_fail; + max_gen; + if_assumptions_fail; + } -> (* create a random state from the seed *) let rand = let bits = @@ -71,7 +92,8 @@ module Test = struct let module Fmt = CCFormat in let cell = - Q.Test.make_cell ?count ?long_factor ~name:(str_loc self) arb prop + Q.Test.make_cell ?if_assumptions_fail ?max_gen ?max_fail ?count + ?long_factor ~name:(str_loc self) arb prop in let pp_cex out (cx : _ Q.TestResult.counter_ex) = @@ -91,24 +113,24 @@ module Test = struct in (* TODO: if verbose, print stats, etc. *) - let res = Q.Test.check_cell ~rand cell in + let res = Q.Test.check_cell ~long ~rand cell in (match get_state res with | QCheck.TestResult.Success -> Ok () | QCheck.TestResult.Failed { instances } -> let msg = - Format.asprintf "@[failed on instances:@ %a@]" + Format.asprintf "@[%sfailed on instances:@ %a@]" what (Fmt.list ~sep:(Fmt.return ";@ ") pp_cex) instances in Error msg | QCheck.TestResult.Failed_other { msg } -> - let msg = spf "failed: %s" msg in + let msg = spf "%sfailed: %s" what msg in Error msg | QCheck.TestResult.Error { instance; exn; backtrace } -> let msg = - Format.asprintf "@[raised %s@ on instance %a@ :backtrace %s@]" - (Printexc.to_string exn) pp_cex instance backtrace + Format.asprintf "@[%sraised %s@ on instance %a@ :backtrace %s@]" + what (Printexc.to_string exn) pp_cex instance backtrace in Error msg) with @@ -119,11 +141,19 @@ end module type S = sig module Q = QCheck - val t : (unit -> bool) -> unit - val eq : ?cmp:'a eq -> ?printer:'a print -> 'a -> 'a -> unit + val t : ?name:string -> (unit -> bool) -> unit + val eq : ?name:string -> ?cmp:'a eq -> ?printer:'a print -> 'a -> 'a -> unit val q : - ?count:int -> ?long_factor:int -> 'a Q.arbitrary -> ('a -> bool) -> unit + ?name:string -> + ?count:int -> + ?long_factor:int -> + ?max_gen:int -> + ?max_fail:int -> + ?if_assumptions_fail:[ `Fatal | `Warning ] * float -> + 'a Q.arbitrary -> + ('a -> bool) -> + unit val assert_equal : ?printer:('a -> string) -> ?cmp:('a -> 'a -> bool) -> 'a -> 'a -> unit @@ -144,18 +174,29 @@ struct let add_ t = all_ := t :: !all_ let n_ = ref 0 - let mk run : Test.t = + let mk ?name run : Test.t = let n = !n_ in incr n_; - { __FILE__ = X.file; n; run } + { __FILE__ = X.file; name; n; run } - let t f : unit = add_ @@ mk @@ Test.T f + let t ?name f : unit = add_ @@ mk ?name @@ Test.T { prop = f } - let eq ?cmp ?printer lhs rhs : unit = - add_ @@ mk @@ Test.Eq { eq = cmp; print = printer; lhs; rhs } + let eq ?name ?cmp ?printer lhs rhs : unit = + add_ @@ mk ?name @@ Test.Eq { eq = cmp; print = printer; lhs; rhs } - let q ?count ?long_factor arb prop : unit = - add_ @@ mk @@ Test.Q { arb; prop; count; long_factor } + let q ?name ?count ?long_factor ?max_gen ?max_fail ?if_assumptions_fail arb + prop : unit = + add_ @@ mk ?name + @@ Test.Q + { + arb; + prop; + count; + long_factor; + max_gen; + max_fail; + if_assumptions_fail; + } let assert_equal ?printer ?(cmp = ( = )) x y : unit = if not @@ cmp x y then ( @@ -188,7 +229,12 @@ let make ~__FILE__ () : (module S) = let getenv_opt s = try Some (Sys.getenv s) with _ -> None -let run_all ?seed:seed_hex ~descr (l : Test.t list list) : unit = +let long = + match getenv_opt "LONG" with + | Some ("true" | "1") -> true + | _ -> false + +let run_all ?seed:seed_hex ?(long = long) ~descr (l : Test.t list list) : unit = let start = Unix.gettimeofday () in (* generate or parse seed *) @@ -223,7 +269,7 @@ let run_all ?seed:seed_hex ~descr (l : Test.t list list) : unit = NOTE: we probably want this to be silent? Format.printf "> run %s@." (Test.str_loc t); *) - match Test.run ~seed t with + match Test.run ~long ~seed t with | Ok () -> () | Error msg -> Format.printf "FAILED: %s@." (Test.str_loc t); diff --git a/src/testlib/containers_testlib.mli b/src/testlib/containers_testlib.mli index 0e6aeff9..adebb0c7 100644 --- a/src/testlib/containers_testlib.mli +++ b/src/testlib/containers_testlib.mli @@ -8,11 +8,19 @@ end module type S = sig module Q = QCheck - val t : (unit -> bool) -> unit - val eq : ?cmp:'a eq -> ?printer:'a print -> 'a -> 'a -> unit + val t : ?name:string -> (unit -> bool) -> unit + val eq : ?name:string -> ?cmp:'a eq -> ?printer:'a print -> 'a -> 'a -> unit val q : - ?count:int -> ?long_factor:int -> 'a Q.arbitrary -> ('a -> bool) -> unit + ?name:string -> + ?count:int -> + ?long_factor:int -> + ?max_gen:int -> + ?max_fail:int -> + ?if_assumptions_fail:[ `Fatal | `Warning ] * float -> + 'a Q.arbitrary -> + ('a -> bool) -> + unit val assert_equal : ?printer:('a -> string) -> ?cmp:('a -> 'a -> bool) -> 'a -> 'a -> unit @@ -24,4 +32,6 @@ module type S = sig end val make : __FILE__:string -> unit -> (module S) -val run_all : ?seed:string -> descr:string -> Test.t list list -> unit + +val run_all : + ?seed:string -> ?long:bool -> descr:string -> Test.t list list -> unit diff --git a/tests/core/t_int32.ml b/tests/core/t_int32.ml index 6e27a4e9..1870c382 100644 --- a/tests/core/t_int32.ml +++ b/tests/core/t_int32.ml @@ -83,4 +83,20 @@ q eq ~printer:CCFun.id "0b111" (to_string_binary 7l);; eq ~printer:CCFun.id "-0b111" (to_string_binary (-7l));; -eq ~printer:CCFun.id "0b0" (to_string_binary 0l) +eq ~printer:CCFun.id "0b0" (to_string_binary 0l);; + +q + Q.(0 -- (Int32.max_int |> Int32.to_int)) + (fun i -> + let n1 = CCInt.popcount i in + let n2 = CCInt32.popcount (Int32.of_int i) in + CCInt.(n1 = n2)) + +let eq' = eq ~printer:CCInt.to_string;; + +eq' 0 (popcount 0l);; +eq' 1 (popcount 1l);; +eq' 31 (popcount max_int);; +eq' 1 (popcount min_int);; +eq' 10 (popcount 0b1110010110110001010l);; +eq' 5 (popcount 0b1101110000000000l) diff --git a/tests/core/t_int64.ml b/tests/core/t_int64.ml index 33d1deac..6f62cdc8 100644 --- a/tests/core/t_int64.ml +++ b/tests/core/t_int64.ml @@ -92,3 +92,12 @@ q eq ~printer:CCFun.id "0b111" (to_string_binary 7L);; eq ~printer:CCFun.id "-0b111" (to_string_binary (-7L));; eq ~printer:CCFun.id "0b0" (to_string_binary 0L) + +let eq' = eq ~printer:CCInt.to_string;; + +eq' 0 (popcount 0L);; +eq' 1 (popcount 1L);; +eq' 63 (popcount max_int);; +eq' 1 (popcount min_int);; +eq' 10 (popcount 0b1110010110110001010L);; +eq' 5 (popcount 0b1101110000000000L) diff --git a/tests/data/t_bv.ml b/tests/data/t_bv.ml index a8ec31f6..1d0428c9 100644 --- a/tests/data/t_bv.ml +++ b/tests/data/t_bv.ml @@ -1,16 +1,35 @@ module Test = (val Containers_testlib.make ~__FILE__ ()) open Test open CCBV +open Internal_ -let ppli = CCFormat.(Dump.list int);; +let spf = Printf.sprintf +let ppli = CCFormat.(Dump.list int) + +module Intset = CCSet.Make (CCInt);; q (Q.pair Q.small_int Q.bool) (fun (size, b) -> create ~size b |> length = size) ;; -t @@ fun () -> create ~size:17 true |> cardinal = 17;; -t @@ fun () -> create ~size:32 true |> cardinal = 32;; -t @@ fun () -> create ~size:132 true |> cardinal = 132;; -t @@ fun () -> create ~size:200 false |> cardinal = 0;; -t @@ fun () -> create ~size:29 true |> to_sorted_list = CCList.range 0 28;; + +t ~name:(spf "line %d" __LINE__) @@ fun () -> +create ~size:17 true |> cardinal = 17 +;; + +t ~name:(spf "line %d" __LINE__) @@ fun () -> +create ~size:32 true |> cardinal = 32 +;; + +t ~name:(spf "line %d" __LINE__) @@ fun () -> +create ~size:132 true |> cardinal = 132 +;; + +t ~name:(spf "line %d" __LINE__) @@ fun () -> +create ~size:200 false |> cardinal = 0 +;; + +t ~name:(spf "line %d" __LINE__) @@ fun () -> +create ~size:29 true |> to_sorted_list = CCList.range 0 28 +;; q (Q.list Q.small_int) (fun l -> let bv = of_list l in @@ -19,7 +38,11 @@ q (Q.list Q.small_int) (fun l -> q Q.small_int (fun size -> create ~size true |> cardinal = size);; -t @@ fun () -> +q Q.small_int (fun size -> + create ~size true |> to_sorted_list = CCList.init size CCFun.id) +;; + +t ~name:(spf "line %d" __LINE__) @@ fun () -> let bv1 = CCBV.create ~size:87 true in assert_equal ~printer:string_of_int 87 (CCBV.cardinal bv1); true @@ -27,7 +50,7 @@ true q Q.small_int (fun n -> CCBV.cardinal (CCBV.create ~size:n true) = n);; -t @@ fun () -> +t ~name:(spf "line %d" __LINE__) @@ fun () -> let bv = CCBV.create ~size:99 false in assert_bool "32 must be false" (not (CCBV.get bv 32)); assert_bool "88 must be false" (not (CCBV.get bv 88)); @@ -44,26 +67,26 @@ assert_bool "1 must be false" (not (CCBV.get bv 1)); true ;; -t @@ fun () -> +t ~name:(spf "line %d" __LINE__) @@ fun () -> let bv = create ~size:3 false in set bv 0; get bv 0 ;; -t @@ fun () -> +t ~name:(spf "line %d" __LINE__) @@ fun () -> let bv = create ~size:3 false in set bv 1; not (get bv 0) ;; -t @@ fun () -> +t ~name:(spf "line %d" __LINE__) @@ fun () -> let bv = create ~size:3 false in set bv 0; reset bv 0; not (get bv 0) ;; -t @@ fun () -> +t ~name:(spf "line %d" __LINE__) @@ fun () -> let bv = of_list [ 1; 10; 11; 30 ] in flip bv 10; assert_equal ~printer:Q.Print.(list int) [ 1; 11; 30 ] (to_sorted_list bv); @@ -83,7 +106,7 @@ assert_equal ~printer:Q.Print.bool true (get bv 100); true ;; -t @@ fun () -> +t ~name:(spf "line %d" __LINE__) @@ fun () -> let bv = create ~size:37 true in cardinal bv = 37 && @@ -91,7 +114,7 @@ cardinal bv = 37 cardinal bv = 0) ;; -t @@ fun () -> +t ~name:(spf "line %d" __LINE__) @@ fun () -> let bv = CCBV.of_list [ 1; 5; 200 ] in assert_equal ~printer:string_of_int 3 (CCBV.cardinal bv); CCBV.clear bv; @@ -100,13 +123,25 @@ assert_bool "must be empty" (CCBV.is_empty bv); true ;; -t @@ fun () -> equal (of_list [ 1; 3; 4 ]) (of_list [ 1; 3; 4 ]);; -t @@ fun () -> equal (empty ()) (empty ());; -t @@ fun () -> not (equal (empty ()) (of_list [ 1 ]));; -t @@ fun () -> not (equal (empty ()) (of_list [ 2; 5 ]));; -t @@ fun () -> not (equal (of_list [ 1; 3 ]) (of_list [ 2; 3 ]));; +t ~name:(spf "line %d" __LINE__) @@ fun () -> +equal (of_list [ 1; 3; 4 ]) (of_list [ 1; 3; 4 ]) +;; -t @@ fun () -> +t ~name:(spf "line %d" __LINE__) @@ fun () -> equal (empty ()) (empty ());; + +t ~name:(spf "line %d" __LINE__) @@ fun () -> +not (equal (empty ()) (of_list [ 1 ])) +;; + +t ~name:(spf "line %d" __LINE__) @@ fun () -> +not (equal (empty ()) (of_list [ 2; 5 ])) +;; + +t ~name:(spf "line %d" __LINE__) @@ fun () -> +not (equal (of_list [ 1; 3 ]) (of_list [ 2; 3 ])) +;; + +t ~name:(spf "line %d" __LINE__) @@ fun () -> List.iter (fun size -> let bv = create ~size false in @@ -142,7 +177,7 @@ q List.length l = n && List.for_all (fun (_, b) -> b) l) ;; -t @@ fun () -> +t ~name:(spf "line %d" __LINE__) @@ fun () -> of_list [ 1; 5; 7 ] |> iter_true |> Iter.to_list |> List.sort CCOrd.poly = [ 1; 5; 7 ] @@ -157,7 +192,7 @@ q gen_bv (fun bv -> CCBV.cardinal bv = CCBV.cardinal bv') ;; -t @@ fun () -> +t ~name:(spf "line %d" __LINE__) @@ fun () -> let bv = CCBV.of_list [ 1; 5; 156; 0; 222 ] in assert_equal ~printer:string_of_int 5 (CCBV.cardinal bv); CCBV.set bv 201; @@ -190,7 +225,7 @@ q let l1 = bv |> to_sorted_list in let l2 = CCList.init (length bv) (get bv) - |> List.mapi (fun i b -> i, b) + |> CCList.mapi (fun i b -> i, b) |> CCList.filter_map (function | i, true -> Some i | _ -> None) @@ -208,12 +243,23 @@ eq ~cmp:equal ~printer:(CCFormat.to_string pp) bv) ;; -t @@ fun () -> of_list [ 1; 32; 64 ] |> CCFun.flip get 64;; -t @@ fun () -> of_list [ 1; 32; 64 ] |> CCFun.flip get 32;; -t @@ fun () -> of_list [ 1; 31; 63 ] |> CCFun.flip get 63;; -t @@ fun () -> of_list [ 50; 10; 17; 22; 3; 12 ] |> first = Some 3;; +t ~name:(spf "line %d" __LINE__) @@ fun () -> +of_list [ 1; 32; 64 ] |> CCFun.flip get 64 +;; -t @@ fun () -> +t ~name:(spf "line %d" __LINE__) @@ fun () -> +of_list [ 1; 32; 64 ] |> CCFun.flip get 32 +;; + +t ~name:(spf "line %d" __LINE__) @@ fun () -> +of_list [ 1; 31; 63 ] |> CCFun.flip get 63 +;; + +t ~name:(spf "line %d" __LINE__) @@ fun () -> +of_list [ 50; 10; 17; 22; 3; 12 ] |> first = Some 3 +;; + +t ~name:(spf "line %d" __LINE__) @@ fun () -> let bv = of_list [ 1; 2; 3; 4; 5; 6; 7 ] in filter bv (fun x -> x mod 2 = 0); to_sorted_list bv = [ 2; 4; 6 ] @@ -227,7 +273,7 @@ eq ~printer:(CCFormat.to_string ppli) [ 0; 3; 4; 6 ] q Q.small_int (fun size -> create ~size false |> negate |> cardinal = size);; -t @@ fun () -> +t ~name:(spf "line %d" __LINE__) @@ fun () -> let bv1 = CCBV.of_list [ 1; 2; 3; 4 ] in let bv2 = CCBV.of_list [ 4; 200; 3 ] in let bv = CCBV.union bv1 bv2 in @@ -236,7 +282,20 @@ assert_equal ~printer:CCFormat.(to_string (Dump.list int)) [ 1; 2; 3; 4; 200 ] l true ;; -t @@ fun () -> +q ~name:"union" + Q.(pair (small_list small_nat) (small_list small_nat)) + (fun (l1, l2) -> + let bv1 = of_list l1 in + let bv2 = of_list l2 in + let l' = CCList.sort_uniq ~cmp:CCInt.compare (l1 @ l2) in + let bv = union bv1 bv2 in + let bv' = of_list l' in + if not (equal bv bv') then + Q.Test.fail_reportf "union (%a, %a) <> %a" ppli l1 ppli l2 ppli l'; + true) +;; + +t ~name:(spf "line %d" __LINE__) @@ fun () -> let bv1 = CCBV.of_list [ 1; 2; 3; 4; 64; 130 ] in let bv2 = CCBV.of_list [ 4; 64; 3; 120 ] in let bv = CCBV.union bv1 bv2 in @@ -246,7 +305,7 @@ assert_equal ~cmp:equal ~printer:(CCFormat.to_string pp) true ;; -t @@ fun () -> +t ~name:(spf "line %d" __LINE__) @@ fun () -> let bv1 = CCBV.of_list [ 1; 2; 3; 4 ] in let bv2 = CCBV.of_list [ 4; 200; 3 ] in let bv = CCBV.union bv1 bv2 in @@ -256,7 +315,7 @@ assert_equal ~cmp:equal ~printer:(CCFormat.to_string pp) true ;; -t @@ fun () -> +t ~name:(spf "line %d" __LINE__) @@ fun () -> let v1 = CCBV.empty () in let () = CCBV.set v1 64 in let v2 = CCBV.diff (CCBV.empty ()) (CCBV.empty ()) in @@ -265,17 +324,17 @@ assert_equal ~printer:(CCFormat.to_string pp) ~cmp:CCBV.equal v1 v3; true ;; -t @@ fun () -> +t ~name:(spf "line %d" __LINE__) @@ fun () -> union (of_list [ 1; 2; 3; 4; 5 ]) (of_list [ 7; 3; 5; 6 ]) |> to_sorted_list = CCList.range 1 7 ;; -t @@ fun () -> +t ~name:(spf "line %d" __LINE__) @@ fun () -> inter (of_list [ 1; 2; 3; 4 ]) (of_list [ 2; 4; 6; 1 ]) |> to_sorted_list = [ 1; 2; 4 ] ;; -t @@ fun () -> +t ~name:(spf "line %d" __LINE__) @@ fun () -> let bv1 = CCBV.of_list [ 1; 2; 3; 4; 200; 201 ] in let bv2 = CCBV.of_list [ 4; 200; 3 ] in let bv = CCBV.inter bv1 bv2 in @@ -284,7 +343,25 @@ assert_equal ~printer:CCFormat.(to_string (Dump.list int)) [ 3; 4; 200 ] l; true ;; -t @@ fun () -> +q ~name:"inter" ~count:10_000 + Q.(pair (small_list small_nat) (small_list small_nat)) + (fun (l1, l2) -> + let bv1 = of_list l1 in + let bv2 = of_list l2 in + let l' = CCList.inter ~eq:CCInt.equal l1 l2 in + let bv = inter bv1 bv2 in + let bv' = of_list l' in + (* make sure both are of the same length before comparing *) + let len = max (length bv) (length bv') in + resize bv len; + resize bv' len; + if not (equal bv bv') then + Q.Test.fail_reportf "inter (%a, %a) <> %a@ (@[bv= %a,@ bv'=%a@])" ppli + l1 ppli l2 ppli l' pp bv pp bv'; + true) +;; + +t ~name:(spf "line %d" __LINE__) @@ fun () -> let bv1 = CCBV.of_list [ 1; 2; 3; 4 ] in let bv2 = CCBV.of_list [ 4; 200; 3 ] in CCBV.inter_into ~into:bv1 bv2; @@ -293,33 +370,52 @@ assert_equal [ 3; 4 ] l; true ;; -t @@ fun () -> diff (of_list [ 1; 2; 3 ]) (of_list [ 1; 2; 3 ]) |> to_list = [] +t ~name:(spf "line %d" __LINE__) @@ fun () -> +diff (of_list [ 1; 2; 3 ]) (of_list [ 1; 2; 3 ]) |> to_list = [] ;; -t @@ fun () -> +q ~name:"diff" ~count:10_000 + Q.(pair (small_list small_nat) (small_list small_nat)) + (fun (l1, l2) -> + let bv1 = of_list l1 in + let bv2 = of_list l2 in + let bv = diff bv1 bv2 in + let l' = Intset.(diff (of_list l1) (of_list l2) |> to_list) in + let bv' = of_list l' in + (* make sure both are of the same length before comparing *) + let len = max (length bv) (length bv') in + resize bv len; + resize bv' len; + if not (equal bv bv') then + Q.Test.fail_reportf "idff (%a, %a) <> %a@ (@[bv= %a,@ bv'=%a@])" ppli + l1 ppli l2 ppli l' pp bv pp bv'; + true) +;; + +t ~name:(spf "line %d" __LINE__) @@ fun () -> diff (of_list [ 1; 2; 3 ]) (of_list [ 1; 2; 3; 4 ]) |> to_list = [] ;; -t @@ fun () -> +t ~name:(spf "line %d" __LINE__) @@ fun () -> diff (of_list [ 1; 2; 3; 4 ]) (of_list [ 1; 2; 3 ]) |> to_list = [ 4 ] ;; -t @@ fun () -> +t ~name:(spf "line %d" __LINE__) @@ fun () -> diff (of_list [ 1; 2; 3 ]) (of_list [ 1; 2; 3; 400 ]) |> to_list = [] ;; -t @@ fun () -> +t ~name:(spf "line %d" __LINE__) @@ fun () -> diff (of_list [ 1; 2; 3; 400 ]) (of_list [ 1; 2; 3 ]) |> to_list = [ 400 ] ;; -t @@ fun () -> +t ~name:(spf "line %d" __LINE__) @@ fun () -> let v1 = CCBV.empty () in set v1 65; let v2 = CCBV.diff v1 v1 in CCBV.is_empty v2 ;; -t @@ fun () -> +t ~name:(spf "line %d" __LINE__) @@ fun () -> let bv = CCBV.of_list [ 1; 2; 5; 400 ] in let arr = [| "a"; "b"; "c"; "d"; "e"; "f" |] in let l = List.sort compare (CCBV.select bv arr) in @@ -327,7 +423,7 @@ assert_equal [ "b"; "c"; "f" ] l; true ;; -t @@ fun () -> +t ~name:(spf "line %d" __LINE__) @@ fun () -> let bv = CCBV.of_list [ 1; 2; 5; 400 ] in let arr = [| "a"; "b"; "c"; "d"; "e"; "f" |] in let l = List.sort compare (CCBV.selecti bv arr) in @@ -350,9 +446,385 @@ q i = (to_iter bv |> Iter.length)) ;; -t @@ fun () -> +t ~name:(spf "line %d" __LINE__) @@ fun () -> CCList.range 0 10 |> CCList.to_iter |> of_iter |> to_iter |> CCList.of_iter |> List.sort CCOrd.poly = CCList.range 0 10 ;; eq ~printer:CCFun.id "bv {00001}" (CCFormat.to_string pp (of_list [ 4 ])) + +let eq' = eq ~printer:CCInt.to_string;; + +eq' 0b0 (__lsb_mask 0);; +eq' 0b1 (__lsb_mask 1);; +eq' 0b11 (__lsb_mask 2);; +eq' 0b111 (__lsb_mask 3);; +eq' 0b1111 (__lsb_mask 4);; +eq' 0b1_1111 (__lsb_mask 5);; +eq' 0b11_1111 (__lsb_mask 6);; +eq' 0b111_1111 (__lsb_mask 7);; +eq' 0b1111_1111 (__lsb_mask 8) + +let popcount8_ref n = + let rec loop n = + if n = 0 then + 0 + else if n land 1 = 0 then + loop (n lsr 1) + else + 1 + loop (n lsr 1) + in + loop n +;; + +(* test __popcount8 just to be sure. *) +t ~name:(spf "line %d" __LINE__) (fun () -> + for i = 0 to 255 do + let n = __popcount8 i in + let n2 = popcount8_ref i in + if n <> n2 then ( + Printf.printf "bad: i=%d => %d,%d\n" i n n2; + assert false + ) + done; + true) +;; + +t ~name:(spf "line %d" __LINE__) (fun () -> + let b = create ~size:10 false in + assert_equal 10 (length b); + set b 9; + for i = 0 to 9 do + assert (i = 9 || not (get b i)) + done; + + resize b 42; + assert_equal 42 (length b); + for i = 0 to 41 do + assert (i = 9 || not (get b i)) + done; + resize b 11; + assert_equal 11 (length b); + for i = 0 to 11 do + assert (i = 9 || not (get b i)) + done; + + true) +;; + +t ~name:(spf "line %d" __LINE__) (fun () -> + let v = empty () in + resize v 9; + inter_into ~into:v (of_list []); + true) +;; + +t ~name:(spf "line %d" __LINE__) (fun () -> + let l = [ 1; 3; 10; 29; 55 ] in + let v = init 120 (fun i -> List.mem i l) in + assert_equal ~printer:(CCFormat.to_string ppli) l (to_sorted_list v); + true) +;; + +q ~name:(spf "line %d" __LINE__) + Q.(small_list small_nat) + (fun l -> + let l = CCList.sort_uniq ~cmp:CCInt.compare l in + let max = 1 + List.fold_left max 0 l in + let v = init max (fun i -> List.mem i l) in + assert_equal ~printer:(CCFormat.to_string ppli) l (to_sorted_list v); + true) +;; + +t ~name:(spf "line %d" __LINE__) (fun () -> + let bv = empty () in + flip bv 0; + resize bv 0; + negate_self bv; + union_into ~into:bv (of_list [ 2 ]); + assert_equal ~printer:(CCFormat.to_string ppli) [ 2 ] (to_list bv); + true) +;; + +t ~name:(spf "line %d" __LINE__) (fun () -> + let bv = empty () in + flip bv 0; + inter_into ~into:bv (of_list []); + negate_self bv; + assert_equal ~printer:(CCFormat.to_string ppli) [] (to_list bv); + true) +;; + +t ~name:(spf "line %d" __LINE__) (fun () -> + let v = empty () in + union_into ~into:v (of_list [ 9; 16 ]); + resize_minimize_memory v 9; + Internal_.__check_invariant v; + is_empty v) + +module Op = struct + type t = + | Resize of int + | Resize_min_mem of int + | Set of int + | Reset of int + | Set_bool of int * bool + | Flip of int + | Clear + | Clear_and_shrink + | Filter_is_odd + | Negate + | Inter of int list + | Union of int list + | Diff of int list + + let apply (self : CCBV.t) (op : t) : unit = + match op with + | Resize n -> resize self n + | Resize_min_mem n -> resize_minimize_memory self n + | Set i -> set self i + | Reset i -> reset self i + | Set_bool (i, b) -> set_bool self i b + | Flip i -> flip self i + | Clear -> clear self + | Clear_and_shrink -> clear_and_shrink self + | Filter_is_odd -> filter self (fun i -> i mod 2 = 1) + | Negate -> negate_self self + | Inter l -> + let bv' = of_list l in + inter_into ~into:self bv' + | Union l -> + let bv' = of_list l in + union_into ~into:self bv' + | Diff l -> + let bv' = of_list l in + diff_into ~into:self bv' + + let post_size sz (self : t) = + match self with + | Resize i -> i + | Resize_min_mem i -> i + | Set j | Reset j | Set_bool (j, _) | Flip j -> max sz (j + 1) + | Clear -> sz + | Clear_and_shrink -> 0 + | Filter_is_odd | Negate -> sz + | Diff _ -> sz + | Inter [] | Union [] -> sz + | Union l -> max sz (succ (List.fold_left max 0 l)) + | Inter l -> min sz (succ (List.fold_left max 0 l)) + + let gen_ size : t Q.Gen.t = + let open Q.Gen in + let nonzero = + [ + (3, 0 -- size >|= fun x -> Set x); + (3, 0 -- size >|= fun x -> Reset x); + ( 3, + 0 -- size >>= fun x -> + bool >|= fun y -> Set_bool (x, y) ); + (3, 0 -- size >|= fun x -> Flip x); + ] + in + + (* random list of integers *) + let rand_list = + 0 -- 200 >>= fun n st -> + CCList.init n (fun i -> + if bool st then + Some i + else + None) + |> CCList.keep_some + in + + frequency + @@ List.flatten + [ + (if size > 0 then + nonzero + else + []); + [ + 1, return Clear; + 1, return Clear_and_shrink; + 1, return Negate; + 1, return Filter_is_odd; + (1, rand_list >|= fun l -> Inter l); + (1, rand_list >|= fun l -> Union l); + (1, rand_list >|= fun l -> Diff l); + (1, 0 -- 100 >|= fun x -> Resize x); + (1, 0 -- 100 >|= fun x -> Resize_min_mem x); + ]; + ] + + let shrink = + let open Q.Iter in + let module S = Q.Shrink in + function + | Resize i -> S.int i >|= fun i -> Resize i + | Resize_min_mem i -> S.int i >|= fun i -> Resize_min_mem i + | Set i -> S.int i >|= fun i -> Resize i + | Reset i -> S.int i >|= fun i -> Resize i + | Set_bool (i, b) -> + S.int i + >|= (fun i -> Set_bool (i, b)) + <+> + if b then + return @@ Set_bool (i, b) + else + empty + | Flip i -> S.int i >|= fun i -> Flip i + | Clear | Clear_and_shrink | Filter_is_odd | Negate -> empty + | Inter l -> S.list ~shrink:S.int l >|= fun l -> Inter l + | Union l -> S.list ~shrink:S.int l >|= fun l -> Union l + | Diff l -> S.list ~shrink:S.int l >|= fun l -> Diff l + + let pp out = + let fpf = Format.fprintf in + function + | Resize i -> fpf out "resize %d" i + | Resize_min_mem i -> fpf out "resize_minimize_memory %d" i + | Set i -> fpf out "set %d" i + | Reset i -> fpf out "reset %d" i + | Set_bool (i, b) -> fpf out "set_bool(%d,%b)" i b + | Flip i -> fpf out "flip %d" i + | Clear -> fpf out "clear" + | Clear_and_shrink -> fpf out "clear_and_shrink" + | Filter_is_odd -> fpf out "filter_is_odd" + | Negate -> fpf out "negate" + | Inter l -> fpf out "inter %a" ppli l + | Union l -> fpf out "union %a" ppli l + | Diff l -> fpf out "diff %a" ppli l + + let arb_l = + let rec gen_l sz n = + let open Q.Gen in + if n = 0 then + return [] + else + gen_ sz >>= fun op -> + let sz' = post_size sz op in + gen_l sz' (n - 1) >|= fun tl -> op :: tl + in + + Q.make + ~print:CCFormat.(to_string @@ Dump.list pp) + ~shrink:(Q.Shrink.list ~shrink) + Q.Gen.(0 -- 30 >>= fun len -> gen_l 0 len) +end + +module Ref_ = struct + type t = { mutable set: Intset.t; mutable size: int } + + let empty () = { size = 0; set = Intset.empty } + + let to_list self = + Intset.to_list self.set |> List.filter (fun x -> x < self.size) + + let pp out (self : t) = ppli out (to_list self) + + let equal_to_bv (self : t) (bv : CCBV.t) : bool = + to_list self = CCBV.to_sorted_list bv + + let cardinal self : int = + Intset.filter (fun x -> x < self.size) self.set |> Intset.cardinal + + let get (self : t) i = Intset.mem i self.set + + let rec apply_op (self : t) (op : Op.t) = + match op with + | Resize n | Resize_min_mem n -> + self.set <- Intset.filter (fun x -> x < n) self.set; + self.size <- n + | Set i -> + self.size <- max self.size (i + 1); + self.set <- Intset.add i self.set + | Reset i -> + self.size <- max self.size (i + 1); + self.set <- Intset.remove i self.set + | Set_bool (i, b) -> + apply_op self + (if b then + Set i + else + Reset i) + | Flip i -> + self.size <- max self.size (i + 1); + apply_op self + (if Intset.mem i self.set then + Reset i + else + Set i) + | Clear -> self.set <- Intset.empty + | Clear_and_shrink -> + self.set <- Intset.empty; + self.size <- 0 + | Filter_is_odd -> self.set <- Intset.filter (fun x -> x mod 2 = 1) self.set + | Negate -> + let l' = + CCList.init self.size (fun x -> x) + |> List.filter (fun x -> not (Intset.mem x self.set)) + in + self.set <- Intset.of_list l' + | Inter l -> + let s' = Intset.of_list l in + let sz' = List.fold_left (fun s x -> max s (x + 1)) 0 l in + self.size <- min self.size sz'; + self.set <- Intset.inter self.set s' + | Union l -> + let s' = Intset.of_list l in + self.size <- List.fold_left (fun s x -> max s (x + 1)) self.size l; + self.set <- Intset.union self.set s' + | Diff l -> + let s' = Intset.of_list l in + self.set <- Intset.diff self.set s' +end +;; + +q ~name:"list ops: invariant" ~max_fail:1 ~long_factor:10 ~count:20_000 Op.arb_l + (fun ops -> + let bv = empty () in + + Internal_.__check_invariant bv; + List.iter + (fun op -> + Op.apply bv op; + Internal_.__check_invariant bv) + ops; + true) +;; + +q ~name:"list ops: compare to ref" ~max_fail:1 ~long_factor:10 ~count:2_000 + Op.arb_l (fun ops -> + let bv = empty () in + let bv' = Ref_.empty () in + + List.iter + (fun op -> + Op.apply bv op; + Ref_.apply_op bv' op; + + if cardinal bv <> Ref_.cardinal bv' then + Q.Test.fail_reportf + "@[different cardinal:@ actual=%a@ ref=%a@ @[actual.card \ + %d@]@ @[ref.cardinal %d@]@]" + pp bv Ref_.pp bv' (cardinal bv) (Ref_.cardinal bv'); + + let bad_idx = + Iter.(0 -- CCBV.length bv) + |> Iter.find_pred (fun i -> get bv i <> Ref_.get bv' i) + in + (match bad_idx with + | None -> () + | Some idx -> + Q.Test.fail_reportf + "at idx %d, not same `get`@ actual.get=%b,@ ref.get=%b" idx + (get bv idx) (Ref_.get bv' idx)); + + if not (Ref_.equal_to_bv bv' bv) then + Q.Test.fail_reportf + "@[not equal:@ actual=%a@ ref=%a@ @[actual.to_list@ %a@]@ \ + @[ref.to_list@ %a@]@]" + pp bv Ref_.pp bv' ppli (to_sorted_list bv) ppli (Ref_.to_list bv')) + ops; + true)