QCaml/common/bitstring.org

#+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

   <<<~Bitstring.t~>>>
   #+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)

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_x" true (one_x = (of_int x));
check_bool "of_z" true (one_x = (of_z (Z.of_int x)));
   #+end_src
    
   Example:
   #+begin_example
Bitstring.of_int 15;;
- : Bitstring.t =
++++------------------------------------------------------------
   #+end_example
   
   #+begin_src ocaml :tangle (eval ml) :exports none
let zero = function
  | n when n < 64 -> One (One.zero)
  | _ -> Many (Many.zero)


let numbits = function
  | One x -> One.numbits x
  | Many x -> Many.numbits x


let is_zero = function
  | One x -> One.is_zero x
  | Many x -> Many.is_zero x


let neg = function
  | One x -> One (One.neg x)
  | Many x -> Many (Many.neg x)


let shift_left x i = match x with
  | One x -> One (One.shift_left x i)
  | Many x -> Many (Many.shift_left x i)


let shift_right x i = match x with
  | One x -> One (One.shift_right x i)
  | Many x -> Many (Many.shift_right x i)

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)

let testbit = function
  | One x -> One.testbit x
  | Many x -> Many.testbit x
   #+end_src

   Example:
   #+begin_example
Bitstring.(shift_left (of_int 15) 2);;
- : Bitstring.t =
--++++----------------------------------------------------------

Bitstring.(shift_right (of_int 15) 2);;
- : Bitstring.t =
++--------------------------------------------------------------

Bitstring.shift_left_one 32 4;;
- : Bitstring.t =
----+-----------------------------------------------------------

Bitstring.(testbit (of_int 15) 3);;
- : bool = true

Bitstring.(testbit (of_int 15) 4);;
- : bool = false
   #+end_example

   #+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);
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);
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);
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"


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"


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"


let lognot = function
  | One x -> One (One.lognot x)
  | Many x -> Many (Many.lognot x)
   #+end_src


   Example:
   #+begin_example
Bitstring.(logor (of_int 15) (of_int 73));;
- : Bitstring.t =
++++--+---------------------------------------------------------

Bitstring.(logand (of_int 15) (of_int 10));;
- : Bitstring.t =
-+-+------------------------------------------------------------

Bitstring.(logxor (of_int 15) (of_int 73));;
- : Bitstring.t =
-++---+---------------------------------------------------------
   #+end_example

   
   #+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)));
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)));
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 minus_one = function
  | One x -> One (One.minus_one x)
  | Many x -> Many (Many.minus_one x)


let plus_one = function
  | One x -> One (One.plus_one x)
  | Many x -> Many (Many.plus_one x)
   #+end_src


   Example:
   #+begin_example
Bitstring.(plus_one (of_int 15));;
- : Bitstring.t =
----+-----------------------------------------------------------
   
Bitstring.(minus_one (of_int 15));;
- : Bitstring.t =
-+++------------------------------------------------------------
   #+end_example


   #+begin_src ocaml :tangle (eval ml) :exports none
let trailing_zeros = function
  | One x -> One.trailing_zeros x
  | Many x -> Many.trailing_zeros x


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"


let popcount = function
  | One x -> One.popcount x
  | Many x -> Many.popcount x
   #+end_src


   Example:
   #+begin_example
Bitstring.(trailing_zeros (of_int 12));;
- : int = 2

Bitstring.(hamdist (of_int 15) (of_int 73));;
- : int = 3

Bitstring.(popcount (of_int 15));;
- : int = 4
   #+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
      let b = logand t @@ minus_one t in
      (to_list [@tailcall]) ~accu:newlist b
   #+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

   Example:
   #+begin_example
Bitstring.(to_list (of_int 45));;
- : int list = [1; 3; 4; 6]
   #+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

   Example:
   #+begin_example
   Bitstring.permutations 2 4;;
- : Bitstring.t list =
[++--------------------------------------------------------------;
 +-+-------------------------------------------------------------;
 -++-------------------------------------------------------------;
 +--+------------------------------------------------------------;
 -+-+------------------------------------------------------------;
 --++------------------------------------------------------------]
   #+end_example

   #+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