#+begin_src elisp tangle: no :results none :exports none (setq pwd (file-name-directory buffer-file-name)) (setq name (file-name-nondirectory (substring buffer-file-name 0 -4))) (setq lib (concat pwd "lib/")) (setq testdir (concat pwd "test/")) (setq mli (concat lib name ".mli")) (setq ml (concat lib name ".ml")) (setq test-ml (concat testdir name ".ml")) (org-babel-tangle) #+end_src * Bit string :PROPERTIES: :header-args: :noweb yes :comments both :END: We define here a data type to handle bit strings efficiently. When the bit string contains less than 64 bits, it is stored internally in a 63-bit integer and uses bitwise instructions. When more than 63 bits are required, the =zarith= library is used to consider the bit string as a multi-precision integer. ** Single-integer implementation :noexport: #+begin_src ocaml :tangle (eval ml) :exports none module One = struct let of_int x = assert (x > 0); x let numbits _ = 63 let zero = 0 let is_zero x = x = 0 let shift_left x i = x lsl i let shift_right x i = x lsr i let shift_left_one i = 1 lsl i let testbit x i = ( (x lsr i) land 1 ) = 1 let logor a b = a lor b let neg a = - a let logxor a b = a lxor b let logand a b = a land b let lognot a = lnot a let minus_one a = a - 1 let plus_one a = a + 1 let popcount = function | 0 -> 0 | r -> Util.popcnt (Int64.of_int r) let trailing_zeros r = Util.trailz (Int64.of_int r) let hamdist a b = a lxor b |> popcount let pp ppf s = Format.fprintf ppf "@[@[%a@]@]" (Util.pp_bitstring 64) (Z.of_int s) end #+end_src ** Zarith implementation :noexport: #+begin_src ocaml :tangle (eval ml) :exports none module Many = struct let of_z x = x let zero = Z.zero let is_zero x = x = Z.zero let shift_left = Z.shift_left let shift_right = Z.shift_right let shift_left_one i = Z.shift_left Z.one i let testbit = Z.testbit let logor = Z.logor let logxor = Z.logxor let logand = Z.logand let lognot = Z.lognot let neg = Z.neg let minus_one = Z.pred let plus_one = Z.succ let trailing_zeros = Z.trailing_zeros let hamdist = Z.hamdist let numbits i = max (Z.numbits i) 64 let popcount z = if z = Z.zero then 0 else Z.popcount z let pp ppf s = Format.fprintf ppf "@[@[%a@]@]" (Util.pp_bitstring (Z.numbits s)) s end #+end_src ** Type #+begin_src ocaml :tangle (eval mli) type t #+end_src #+begin_src ocaml :tangle (eval ml) :exports none type t = | One of int | Many of Z.t #+end_src ** Tests header :noexport: #+begin_src ocaml :tangle (eval test-ml) open Common.Bitstring let check_bool = Alcotest.(check bool) let check msg x = check_bool msg true x let test_all () = let x = 8745687 in let one_x = of_int x in let z = Z.shift_left (Z.of_int x) 64 in let many_x = of_z z in #+end_src ** General implementation #+begin_src ocaml :tangle (eval mli) val of_int : int -> t val of_z : Z.t -> t val zero : int -> t val is_zero : t -> bool val numbits : t -> int val testbit : t -> int -> bool val neg : t -> t val shift_left : t -> int -> t val shift_right : t -> int -> t val shift_left_one : int -> int -> t val logor : t -> t -> t val logxor : t -> t -> t val logand : t -> t -> t val lognot : t -> t val plus_one : t -> t val minus_one : t -> t val hamdist : t -> t -> int val trailing_zeros : t -> int val popcount : t -> int val to_list : ?accu:(int list) -> t -> int list val permutations : int -> int -> t list #+end_src | ~of_int~ | Creates a bit string from an ~int~ | | ~of_z~ | Creates a bit string from an ~Z.t~ multi-precision integer | | ~zero~ | ~zero n~ creates a zero bit string with ~n~ bits | | ~is_zero~ | True if all the bits of the bit string are zero. | | ~numbits~ | Returns the number of bits used to represent the bit string | | ~testbit~ | ~testbit t n~ is true if the ~n~-th bit of the bit string ~t~ is set to ~1~ | | ~neg~ | Returns the negative of the integer interpretation of the bit string | | ~shift_left~ | ~shift_left t n~ returns a new bit strings with all the bits shifted ~n~ positions to the left | | ~shift_right~ | ~shift_right t n~ returns a new bit strings with all the bits shifted ~n~ positions to the right | | ~shift_left_one~ | ~shift_left_one size n~ returns a new bit strings with the ~n~-th bit set to one. It is equivalent as shifting ~1~ by ~n~ bits to the left, ~size~ is the total number of bits of the bit string | | ~logor~ | Bitwise logical or | | ~logxor~ | Bitwise logical exclusive or | | ~logand~ | Bitwise logical and | | ~lognot~ | Bitwise logical negation | | ~plus_one~ | Takes the integer representation of the bit string and adds one | | ~minus_one~ | Takes the integer representation of the bit string and removes one | | ~hamdist~ | Returns the Hamming distance, i.e. the number of bits differing between two bit strings | | ~trailing_zeros~ | Returns the number of trailing zeros in the bit string | | ~permutations~ | ~permutations m n~ generates the list of all possible ~n~-bit strings with ~m~ bits set to ~1~. Algorithm adapted from [[https://graphics.stanford.edu/~seander/bithacks.html#NextBitPermutation][Bit twiddling hacks]] | | ~popcount~ | Returns the number of bits set to one in the bit string | | ~to_list~ | Converts a bit string into a list of integers indicating the positions where the bits are set to ~1~. The first value for the position is not ~0~ but ~1~ | #+begin_src ocaml :tangle (eval ml) :exports none let of_int x = One (One.of_int x) #+end_src #+begin_src ocaml :tangle (eval test-ml) :exports none check_bool "of_x" true (one_x = (of_int x)); #+end_src #+begin_src ocaml :tangle (eval ml) :exports none let of_z x = if Z.numbits x < 64 then One (Z.to_int x) else Many (Many.of_z x) #+end_src #+begin_src ocaml :tangle (eval test-ml) :exports none check_bool "of_z" true (one_x = (of_z (Z.of_int x))); #+end_src #+begin_src ocaml :tangle (eval ml) :exports none let zero = function | n when n < 64 -> One (One.zero) | _ -> Many (Many.zero) #+end_src #+begin_src ocaml :tangle (eval ml) :exports none let numbits = function | One x -> One.numbits x | Many x -> Many.numbits x #+end_src #+begin_src ocaml :tangle (eval ml) :exports none let is_zero = function | One x -> One.is_zero x | Many x -> Many.is_zero x #+end_src #+begin_src ocaml :tangle (eval ml) :exports none let neg = function | One x -> One (One.neg x) | Many x -> Many (Many.neg x) #+end_src #+begin_src ocaml :tangle (eval ml) :exports none let shift_left x i = match x with | One x -> One (One.shift_left x i) | Many x -> Many (Many.shift_left x i) #+end_src #+begin_src ocaml :tangle (eval test-ml) :exports none check_bool "shift_left1" true (of_int (x lsl 3) = shift_left one_x 3); check_bool "shift_left2" true (of_z (Z.shift_left z 3) = shift_left many_x 3); check_bool "shift_left3" true (of_z (Z.shift_left z 100) = shift_left many_x 100); #+end_src #+begin_src ocaml :tangle (eval ml) :exports none let shift_right x i = match x with | One x -> One (One.shift_right x i) | Many x -> Many (Many.shift_right x i) #+end_src #+begin_src ocaml :tangle (eval test-ml) :exports none check_bool "shift_right1" true (of_int (x lsr 3) = shift_right one_x 3); check_bool "shift_right2" true (of_z (Z.shift_right z 3) = shift_right many_x 3); #+end_src #+begin_src ocaml :tangle (eval ml) :exports none let shift_left_one = function | n when n < 64 -> fun i -> One (One.shift_left_one i) | _ -> fun i -> Many (Many.shift_left_one i) #+end_src #+begin_src ocaml :tangle (eval test-ml) :exports none check_bool "shift_left_one1" true (of_int (1 lsl 3) = shift_left_one 4 3); check_bool "shift_left_one2" true (of_z (Z.shift_left Z.one 200) = shift_left_one 300 200); #+end_src #+begin_src ocaml :tangle (eval ml) :exports none let testbit = function | One x -> One.testbit x | Many x -> Many.testbit x #+end_src #+begin_src ocaml :tangle (eval test-ml) :exports none check_bool "testbit1" true (testbit (of_int 8) 3); check_bool "testbit2" false (testbit (of_int 8) 2); check_bool "testbit3" false (testbit (of_int 8) 4); check_bool "testbit4" true (testbit (of_z (Z.of_int 8)) 3); check_bool "testbit5" false (testbit (of_z (Z.of_int 8)) 2); check_bool "testbit6" false (testbit (of_z (Z.of_int 8)) 4); #+end_src #+begin_src ocaml :tangle (eval ml) :exports none let logor a b = match a,b with | One a, One b -> One (One.logor a b) | Many a, Many b -> Many (Many.logor a b) | _ -> invalid_arg "Bitstring.logor" #+end_src #+begin_src ocaml :tangle (eval test-ml) :exports none check_bool "logor1" true (of_int (1 lor 2) = logor (of_int 1) (of_int 2)); check_bool "logor2" true (of_z (Z.of_int (1 lor 2)) = logor (of_z Z.one) (of_z (Z.of_int 2))); #+end_src #+begin_src ocaml :tangle (eval ml) :exports none let logxor a b = match a,b with | One a, One b -> One (One.logxor a b) | Many a, Many b -> Many (Many.logxor a b) | _ -> invalid_arg "Bitstring.logxor" #+end_src #+begin_src ocaml :tangle (eval test-ml) :exports none check_bool "logxor1" true (of_int (1 lxor 2) = logxor (of_int 1) (of_int 2)); check_bool "logxor2" true (of_z (Z.of_int (1 lxor 2)) = logxor (of_z Z.one) (of_z (Z.of_int 2))); #+end_src #+begin_src ocaml :tangle (eval ml) :exports none let logand a b = match a,b with | One a, One b -> One (One.logand a b) | Many a, Many b -> Many (Many.logand a b) | _ -> invalid_arg "Bitstring.logand" #+end_src #+begin_src ocaml :tangle (eval test-ml) :exports none check_bool "logand1" true (of_int (1 land 3) = logand (of_int 1) (of_int 3)); check_bool "logand2" true (of_z (Z.of_int (1 land 3)) = logand (of_z Z.one) (of_z (Z.of_int 3))); #+end_src #+begin_src ocaml :tangle (eval ml) :exports none let lognot = function | One x -> One (One.lognot x) | Many x -> Many (Many.lognot x) #+end_src #+begin_example minus_one (of_int 10) = of_int 9 #+end_example #+begin_src ocaml :tangle (eval ml) :exports none let minus_one = function | One x -> One (One.minus_one x) | Many x -> Many (Many.minus_one x) #+end_src #+begin_example plus_one (of_int 10) = of_int 11 #+end_example #+begin_src ocaml :tangle (eval ml) :exports none let plus_one = function | One x -> One (One.plus_one x) | Many x -> Many (Many.plus_one x) #+end_src #+begin_src ocaml :tangle (eval ml) :exports none let trailing_zeros = function | One x -> One.trailing_zeros x | Many x -> Many.trailing_zeros x #+end_src #+begin_src ocaml :tangle (eval ml) :exports none let hamdist a b = match a, b with | One a, One b -> One.hamdist a b | Many a, Many b -> Many.hamdist a b | _ -> invalid_arg "Bitstring.hamdist" #+end_src #+begin_src ocaml :tangle (eval ml) :exports none let popcount = function | One x -> One.popcount x | Many x -> Many.popcount x #+end_src #+begin_example Bitstring.to_list (of_int 5);; - : int list = [1; 3] #+end_example #+begin_src ocaml :tangle (eval ml) :exports none let rec to_list ?(accu=[]) = function | t when (is_zero t) -> List.rev accu | t -> let newlist = (trailing_zeros t + 1)::accu in logand t @@ minus_one t |> (to_list [@tailcall]) ~accu:newlist #+end_src #+begin_src ocaml :tangle (eval test-ml) :exports none check_bool "to_list" true ([ 1 ; 3 ; 4 ; 6 ] = (to_list (of_int 45))); #+end_src #+begin_example Bitstring.permutations 2 4 |> List.map (fun x -> Format.asprintf "%a" Bitstring.pp x) ;; - : string list = ["++--------------------------------------------------------------"; "+-+-------------------------------------------------------------"; "-++-------------------------------------------------------------"; "+--+------------------------------------------------------------"; "-+-+------------------------------------------------------------"; "--++------------------------------------------------------------"] #+end_example #+begin_src ocaml :tangle (eval ml) :exports none let permutations m n = let rec aux k u rest = if k=1 then List.rev (u :: rest) else let t = logor u @@ minus_one u in let t' = plus_one t in let not_t = lognot t in let neg_not_t = neg not_t in let t'' = shift_right (minus_one @@ logand not_t neg_not_t) (trailing_zeros u + 1) in (* let t'' = shift_right (minus_one (logand (lognot t) t')) (trailing_zeros u + 1) in ,*) (aux [@tailcall]) (k-1) (logor t' t'') (u :: rest) in aux (Util.binom n m) (minus_one (shift_left_one n m)) [] #+end_src #+begin_src ocaml :tangle (eval test-ml) :exports none check "permutations" (permutations 2 4 = List.map of_int [ 3 ; 5 ; 6 ; 9 ; 10 ; 12 ]); #+end_src ** Printers #+begin_src ocaml :tangle (eval mli) val pp : Format.formatter -> t -> unit #+end_src #+begin_src ocaml :tangle (eval ml) :exports none let pp ppf = function | One x -> One.pp ppf x | Many x -> Many.pp ppf x #+end_src ** Tests :noexport: #+begin_src ocaml :tangle (eval test-ml) :exports none () let tests = [ "all", `Quick, test_all; ] #+end_src