fr.ml
(*****************************************************************************)
(* *)
(* Copyright (c) 2020-2021 Danny Willems <be.danny.willems@gmail.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
module Stubs = struct
type fr
type scalar
external allocate_scalar : unit -> scalar = "allocate_scalar_stubs"
external callocate_fr : unit -> fr = "callocate_fr_stubs"
external mallocate_fr : unit -> fr = "mallocate_fr_stubs"
external scalar_of_fr : scalar -> fr -> int = "caml_blst_scalar_from_fr_stubs"
external fr_of_scalar : fr -> scalar -> int = "caml_blst_fr_from_scalar_stubs"
external fr_of_bytes_le : fr -> Bytes.t -> bool
= "caml_blst_fr_from_lendian_stubs"
external fr_to_bytes_le : Bytes.t -> fr -> int
= "caml_blst_lendian_from_fr_stubs"
external scalar_of_bytes_le : scalar -> Bytes.t -> int
= "caml_blst_scalar_of_bytes_stubs"
external scalar_to_bytes_le : Bytes.t -> scalar -> int
= "caml_blst_scalar_to_bytes_stubs"
external check_scalar : scalar -> bool = "caml_blst_check_scalar_stubs"
external add : fr -> fr -> fr -> int = "caml_blst_fr_add_stubs"
external eq : fr -> fr -> bool = "caml_blst_fr_is_equal_stubs"
external cneg : fr -> fr -> bool -> bool = "caml_blst_fr_cneg_stubs"
external is_zero : fr -> bool = "caml_blst_fr_is_zero_stubs"
external is_one : fr -> bool = "caml_blst_fr_is_one_stubs"
external sub : fr -> fr -> fr -> int = "caml_blst_fr_sub_stubs"
external mul : fr -> fr -> fr -> int = "caml_blst_fr_mul_stubs"
external pow : fr -> fr -> Bytes.t -> int -> int = "caml_blst_fr_pow_stubs"
external sqr : fr -> fr -> int = "caml_blst_fr_sqr_stubs"
external eucl_inverse : fr -> fr -> int = "caml_blst_fr_eucl_inverse_stubs"
external memcpy : fr -> fr -> int = "caml_blst_fr_memcpy_stubs"
external inner_product : fr -> fr array -> fr array -> int -> int
= "caml_blst_fr_inner_product_stubs"
end
(* module = Blst_bindings.r (Blst_stubs) *)
module Fr = struct
exception Not_in_field of Bytes.t
type t = Stubs.fr
let copy src =
let dst = Stubs.mallocate_fr () in
ignore @@ Stubs.memcpy dst src ;
dst
let memcpy a b = ignore @@ Stubs.memcpy a b
let size_in_bytes = 32
let order =
Z.of_string
"52435875175126190479447740508185965837690552500527637822603658699938581184513"
let pad_if_require bs =
(* Pad to 32 bytes. In anycase, copy the bytes to a new buffer *)
if Bytes.length bs < size_in_bytes then (
let padded_bytes = Bytes.make size_in_bytes '\000' in
Bytes.blit bs 0 padded_bytes 0 (Bytes.length bs) ;
padded_bytes)
else Bytes.copy bs
let of_bytes_opt bs =
if Bytes.length bs > size_in_bytes then None
else
let bs = pad_if_require bs in
let buffer = Stubs.mallocate_fr () in
let is_ok = Stubs.fr_of_bytes_le buffer bs in
if is_ok then Some buffer else None
let of_bytes_exn bs =
let buffer_opt = of_bytes_opt bs in
match buffer_opt with
| None -> raise (Not_in_field bs)
| Some buffer -> buffer
let check_bytes bs =
if Bytes.length bs = size_in_bytes then (
let buffer_scalar = Stubs.allocate_scalar () in
ignore @@ Stubs.scalar_of_bytes_le buffer_scalar bs ;
Stubs.check_scalar buffer_scalar)
else false
let zero = of_bytes_exn (Bytes.make size_in_bytes '\000')
let one =
let bytes = Bytes.make size_in_bytes '\000' in
Bytes.set bytes 0 '\001' ;
of_bytes_exn bytes
let to_bytes x =
let buffer_bytes = Bytes.make size_in_bytes '\000' in
ignore @@ Stubs.fr_to_bytes_le buffer_bytes x ;
buffer_bytes
let size_in_memory = Obj.reachable_words (Obj.repr one) * 8
let eq x y = Stubs.eq x y
let ( = ) = eq
let is_zero s = Stubs.is_zero s
let is_one s = Stubs.is_one s
let rec random ?state () =
let random_int =
match state with
| None -> Random.int
| Some state -> Random.State.int state
in
let random_bytes =
Bytes.init size_in_bytes (fun _ -> char_of_int @@ random_int 256)
in
let res = of_bytes_opt random_bytes in
match res with None -> random ?state () | Some res -> res
let rec non_null_random ?state () =
let r = random ?state () in
if is_zero r then non_null_random ?state () else r
let add x y =
let buffer = Stubs.mallocate_fr () in
ignore @@ Stubs.add buffer x y ;
buffer
let add_inplace res a b = ignore @@ Stubs.add res a b
let add_bulk xs =
let buffer = Stubs.callocate_fr () in
List.iter (fun x -> ignore @@ Stubs.add buffer buffer x) xs ;
buffer
let ( + ) = add
let mul x y =
let buffer = Stubs.mallocate_fr () in
ignore @@ Stubs.mul buffer x y ;
buffer
let mul_inplace res a b = ignore @@ Stubs.mul res a b
let mul_bulk xs =
let buffer = Stubs.callocate_fr () in
ignore @@ Stubs.add buffer buffer one ;
List.iter (fun x -> ignore @@ Stubs.mul buffer buffer x) xs ;
buffer
let ( * ) = mul
let inverse_opt x =
if is_zero x then None
else
let buffer = Stubs.mallocate_fr () in
ignore @@ Stubs.eucl_inverse buffer x ;
Some buffer
let inverse_exn x =
match inverse_opt x with None -> raise Division_by_zero | Some x -> x
let inverse_exn_inplace res x =
if is_zero x then raise Division_by_zero
else ignore @@ Stubs.eucl_inverse res x
let sub a b =
let buffer = Stubs.mallocate_fr () in
ignore @@ Stubs.sub buffer a b ;
buffer
let sub_inplace res x y = ignore @@ Stubs.sub res x y
let square x =
let buffer = Stubs.mallocate_fr () in
ignore @@ Stubs.sqr buffer x ;
buffer
let square_inplace res x = ignore @@ Stubs.sqr res x
let double x = x + x
let double_inplace res x = ignore @@ Stubs.add res x x
let negate x =
let buffer = Stubs.mallocate_fr () in
ignore @@ Stubs.cneg buffer x true ;
buffer
let negate_inplace res x = ignore @@ Stubs.cneg res x true
let ( - ) = negate
let div_exn x y = x * inverse_exn y
let div_opt x y =
match inverse_opt y with None -> None | Some inv_y -> Some (x * inv_y)
let ( / ) = div_exn
let two_z = Z.(one + one)
let pow x n =
let n = Z.erem n (Z.pred order) in
let buffer = Stubs.mallocate_fr () in
let exp = Z.to_bits n |> Bytes.unsafe_of_string in
let exp_len = Z.numbits n in
ignore @@ Stubs.pow buffer x exp exp_len ;
buffer
let ( ** ) = pow
let to_string s =
let bytes = to_bytes s in
let z = Z.of_bits (Bytes.to_string bytes) in
Z.to_string z
let of_z z =
let z = Bytes.of_string (Z.to_bits (Z.erem z order)) in
let x = Bytes.make size_in_bytes '\000' in
Bytes.blit z 0 x 0 (min (Bytes.length z) size_in_bytes) ;
of_bytes_exn x
let to_z b =
let bytes = to_bytes b in
Z.of_bits (Bytes.to_string bytes)
let of_string s = of_z (Z.of_string s)
let factor_power_of_two =
let rec aux i n =
let q, r = Z.ediv_rem n two_z in
if Z.equal r Z.zero then aux Int.(succ i) q else (i, n)
in
aux 0 (Z.pred order)
let legendre_symbol x =
if is_zero x then Z.zero
else if is_one (pow x (Z.divexact (Z.pred order) (Z.of_int 2))) then Z.one
else Z.neg Z.one
let is_quadratic_residue x =
if is_zero x then true else Z.equal (legendre_symbol x) Z.one
let rec pick_non_square () =
let z = random ?state:None () in
if Z.equal (legendre_symbol z) (Z.of_int (-1)) then z
else pick_non_square ()
let sqrt_opt x =
if not (is_quadratic_residue x) then None
else
(* https://en.wikipedia.org/wiki/Tonelli%E2%80%93Shanks_algorithm *)
let s, q = factor_power_of_two in
(* implies p = 3 mod 4 *)
if Int.equal s 1 then
(* r = x^((p + 1) / 4) *)
let r = pow x (Z.divexact (Z.succ order) (Z.of_string "4")) in
Some r
else
let rec compute_lowest_n_2th_root_of_unity (i : int) x upper : int =
let x = square x in
if is_one x then i
else if Int.(equal i upper) then
failwith "Upperbound should be higher"
(* should never happen in this case, just being explicit *)
else compute_lowest_n_2th_root_of_unity (Int.succ i) x upper
in
let z = pick_non_square () in
let c = pow z q in
let rec aux m c t r =
if eq t zero then zero (* case x is zero *)
else if eq t one then r (* base case *)
else
let i = compute_lowest_n_2th_root_of_unity 1 t m in
let b = pow c (Z.pow two_z Int.(pred (sub m i))) in
let m = i in
let c = mul b b in
let t = mul t c in
let r = mul r b in
aux m c t r
in
Some (aux s c (pow x q) (pow x (Z.divexact (Z.succ q) two_z)))
let compare x y = Stdlib.compare (to_bytes x) (to_bytes y)
let inner_product_opt a b =
if Array.length a <> Array.length b then None
else
let res = copy zero in
ignore @@ Stubs.inner_product res a b (Array.length a) ;
Some res
let inner_product_exn a b =
match inner_product_opt a b with
| None ->
raise (Invalid_argument "Both parameters must be of the same length")
| Some x -> x
let of_int x = of_z (Z.of_int x)
end
include Fr