High-Value Hash Highway

hashvaluehighway.ml

(* Andrew Miller March 2014 
   Hash-value Highway - See also: https://bitcointalk.org/index.php?topic=98986 *)

open Merkle (* provides authtype *)

type tx = string
type block = Genesis | Blk of block authtype * block authtype * tx * int * int

(* Boiler plate for authenticated data structure parser 
   Indicates data structure definitions end here *)
external merkle : 'a -> 'a = "MERKLE"


(* Returns 1 with probability 1/2, 2 with probability 1/4, etc. *)
let rec sample_value() = if Random.bool() then 1 else 1 + sample_value()


let extend (prev:block authtype) (t:tx) : block =
  (* Add a new block building on top of prev, with a "back" link
     pointing to prev, and an "up" link pointing to (the successor of
     a node 1 greater in value than prev *) 
  let (pwork,pval) = match (unauth prev) with
    | Genesis -> (0,0)
    | Blk(_, _, _, work, value) -> (work, value) 
  in
  let rec find_larger ptr = 
    (* Find the first ptr such that ptr->back->value >= pval *)
    match (unauth ptr) with
    | Genesis -> Genesis
    | Blk(back, _, _, _, _) -> 
      match (unauth back) with
      | Genesis -> Genesis
      | Blk(_, up, _, _, value) ->
        if value >= pval then ptr
        else find_larger up
  in
  Blk(prev, (find_larger prev), tx, pwork+1, sample_value())


let traverse (blk:block authtype) (btx:block authtype) (level:int) : int = 
  (* Traverse from blk back to btx, passing through (and counting) every 
     block with value >= level *)
  let (_, _, _, bwork, _) = unauth btx in
  let rec _traverse blk =
    let (back, up, _, _, value) = blk in
    match unauth back with
    | Genesis -> 0
    | Blk(_back, _, _, _work, _value) -> 
      if _work <= bwork then 0 (* Skipped all the way to tx, base case *)
      else if _value >= level then
        (* Valid sample - increment one, go one step back *)
        1 + _traverse back
      else
        let unup = unauth up in
        let (_, _, _, __work, _) = unup in
        if __work <= bwork then
          (* We can't skip up again without overshooting btx. *)
          _traverse back
        else
          _traverse unup
  in
  (* FIXME: I'm wary of several off-by-one edge cases here *)
  _traverse (unauth blk)


(* Prove and Verify are both instances of Traverse *)

let verify (blk:block authtype) (btx:block authtype) 
    (level:int) (minreq:int) : bool =
  let observed = traverse blk btx level in
  observed >= minreq