;;; blockchain.scm

(load (spheres/crypto digest))

(define-macro (for var to . body)
  `(let loop ((,var 0))
     (if (< ,var ,to)
         (begin ,@body (loop (+ ,var 1))))))

(define (char-is-zero? string index)
  (if (eq? #\0 (string-ref string index)) #t #f))

;; https://stackoverflow.com/a/6727536
(define and-l (lambda x
                (if (null? x)
                    #t
                    (if (car x) (apply and-l (cdr x)) #f))))

(define-macro (list-range* n proc)
  `(let loop ((i ,n) (lst '()))
     (if (zero? i)
         lst
         (loop (- i 1) (cons ,proc lst)))))

(define (n-chars-are-zero? string n)
  (let ((lst (list-range* n (char-is-zero? string (- i 1)))))
    (apply and-l lst)))

;; our blocks are just vectors of length 3
(define-structure block
  number
  data
  nonce
  prevhash)

;; required for block hashes to be identical between restarts
(define (block-to-string block)
  (let ((o (open-output-string)))
    (write (block-number block) o)
    (write (block-data block) o)
    (write (block-nonce block) o)
    (write (block-prevhash block) o)
    (get-output-string o)))

(define (hash-block block)
  (md5 (block-to-string block)))

;; zeroth (genesis) block is pre-defined
(define zeroth-block (make-block
                      0
                      ":)"
                      70924
                      "00000000000000000000000000000000"))

;; Block found!
;; #<block #2 number: 0 data: ":)" nonce: 70924 prevhash: "00000000000000000000000000000000">
;; 00002983b797351053bd7a2fd1f9da8f

(define leading-zeros 4) ; 4 leading zeros of md5 hash

(define blockchain (list zeroth-block))

(define blockchain-height ; there is only 1 blockchain
  (block-number (car blockchain)))

(define (new-block data)
  (make-block
   (+ 1 blockchain-height)
   data
   0
   (hash-block (car blockchain))))

(define (mine-block block)
  (let loop ((i 0) (block-hash (hash-block block)))
    (if (n-chars-are-zero? block-hash leading-zeros)
        (begin
          (print "\nBlock found!\n")
          (print block "\n")
          (print (hash-block block) "\n")
          (add-block-to-chain block))
        (begin
          (block-nonce-set! block (+ (block-nonce block) 1))
          (loop (+ i 1) (hash-block block))))))

(define (add-block-to-chain block)
  (if (and (equal? (hash-block (car blockchain)) (= (block-number block) (+ 1 (block-number (car blockchain))))))
      (block-prevhash block)
      (set! blockchain (cons block blockchain))))