mirror of
https://gitlab.com/scemama/QCaml.git
synced 2024-12-23 04:43:32 +01:00
448 lines
16 KiB
Org Mode
448 lines
16 KiB
Org Mode
#+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
|