Source file gadget_merkle_narity.ml

(*****************************************************************************)
(*                                                                           *)
(* MIT License                                                               *)
(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.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.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Lang_stdlib
open Lang_core

module type HASH = Hash_sig.HASH

module type MERKLE_NARITY = functor (H : HASH) (L : LIB) -> sig
  open L

  type direction = scalar

  type proof = (scalar * (scalar list * direction) list) repr

  type root = scalar repr

  val merkle_proof : int -> proof -> root -> bool repr t
end

module P (Mec : Hash_sig.P_HASH) = struct
  type tree = Leaf of S.t | Branch of S.t * tree list

  let root = function Leaf h -> h | Branch (h, _) -> h

  let rec generate_tree n depth =
    if depth = 0 then Leaf (S.random ())
    else
      let children = List.init n (fun _ -> generate_tree n (depth - 1)) in
      let root = Mec.direct (Array.of_list (List.map root children)) in
      Branch (root, children)

  (* This function assumes that the length of pos and the depth of tree coincide.
     Furthermore, that pos is a list of integers between 0 and n-1, where n is
     the arity of the tree (which is consistent in arity).
  *)
  let proof_path_narity pos tree =
    let rec aux path pos = function
      | Leaf h -> (path, h)
      | Branch (_, children) ->
          let direction = List.hd pos in
          let t = List.nth children direction in
          let level_witnesses =
            List.filteri (fun j _ -> direction <> j) children |> List.map root
          in
          aux
            ((level_witnesses, S.of_z (Z.of_int direction)) :: path)
            (List.tl pos)
            t
    in
    aux [] pos tree
end

module V : MERKLE_NARITY =
functor
  (H : HASH)
  (L : LIB)
  ->
  struct
    open L

    open H (L)

    type direction = scalar

    (* leaf, path *)
    type proof = (scalar * (scalar list * direction) list) repr

    type root = scalar repr

    let merkle_proof : int -> proof -> root -> bool repr t =
     fun n witness expected_root ->
      with_label ~label:"MerkleNArity.merkle_proof"
      @@
      let module E = Enum (struct
        let n = n
      end) in
      let leaf, path = of_pair witness in
      let* root =
        foldM
          (fun computed_h step ->
            let level_witnesses, direction = of_pair step in
            let level_witnesses = of_list level_witnesses in
            let* hash_inputs =
              foldiM
                (fun hash_inputs i ->
                  let hash_inputs = of_list hash_inputs in
                  let cand_i =
                    if i > 0 then List.nth level_witnesses (i - 1)
                    else computed_h
                  in
                  let cand_i' =
                    if i < n - 1 then List.nth level_witnesses i else computed_h
                  in
                  let candidates =
                    to_list
                    @@ List.init n (fun j ->
                           if j < i then cand_i
                           else if j = i then computed_h
                           else cand_i')
                  in
                  let* input_i = E.switch_case direction candidates in
                  let hash_inputs = to_list (input_i :: hash_inputs) in
                  ret hash_inputs)
                (to_list [])
                n
            in
            digest (to_list @@ List.rev (of_list hash_inputs)))
          leaf
          (of_list path)
      in
      equal root expected_root
  end