Common Lisp Blockchain - Scheme Coin

Here’s a little ditty I decided to share. A Common Lisp Blockchain implementation of a coin that has a useful Proof of Work: Scheme Evaluation.

Incomplete, but still interesting per the previous week’s discussion.

;;

;; scheme coin - a common lisp blockchain

;;

;; Burton Samograd

;; 2017

(load "~/quicklisp/setup.lisp")

(defconstant *coin-name* "Scheme Coin")

(eval-when (compile load)

(ql:quickload "ironclad"))

(defun rest2 (l)

(cddr l))

(defun interp (x &optional env)

"Interpret (evaluate) the expression x in the environment env."

(cond

((symbolp x) (get-var x env))

((atom x) x)

((scheme-macro (first x))

(interp (scheme-macro-expand x) env))

((case (first x)

(QUOTE (second x))

(BEGIN (last1 (mapcar #'(lambda (y) (interp y env))

(rest x))))

(SET! (set-var! (second x) (interp (third x) env) env))

(if (if (interp (second x) env)

(interp (third x) env)

(interp (fourth x) env)))

(LAMBDA (let ((parms (second x))

(code (maybe-add 'begin (rest2 x))))

#'(lambda (&rest args)

(interp code (extend-env parms args env)))))

(t ;; a procedure application

(apply (interp (first x) env)

(mapcar #'(lambda (v) (interp v env))

(rest x))))))))

(defun scheme-macro (symbol)

(and (symbolp symbol) (get symbol 'scheme-macro)))

(defmacro def-scheme-macro (name parmlist &body body)

`(setf (get ',name 'scheme-macro)

#'(lambda ,parmlist .,body)))

(defun scheme-macro-expand (x)

(if (and (listp x) (scheme-macro (first x)))

(scheme-macro-expand

(apply (scheme-macro (first x)) (rest x)))

x))

(defun set-var! (var val env)

"Set a variable to a value, in the given or global environment."

(if (assoc var env)

(setf (second (assoc var env)) val)

(set-global-var! var val))

val)

(defun get-var (var env)

(if (assoc var env)

(second (assoc var env))

(get-global-var var)))

(defun set-global-var! (var val)

(setf (get var 'global-val) val))

(defun get-global-var (var)

(let* ((default "unbound")

(val (get var 'global-val default)))

(if (eq val default)

(error "Unbound scheme variable: ~A" var)

val)))

(defun extend-env (vars vals env)

"Add some variables and values to and environment."

(nconc (mapcar #'list vars vals) env))

(defparameter *scheme-procs*

'(+ - * / = < > <= >= cons car cdr not append list read member

(null? null) (eq? eq) (equal? equal) (eqv? eql)

(write prin1) (display princ) (newline terpri)))

(defun init-scheme-interp ()

(mapc #'init-scheme-proc *scheme-procs*)

(set-global-var! t t)

(set-global-var! nil nil))

(defun init-scheme-proc (f)

(if (listp f)

(set-global-var! (first f) (symbol-function (second f)))

(set-global-var! f (symbol-function f))))

(defun maybe-add (op exps &optional if-nil)

(cond ((null exps) if-nil)

((length=1 exps) (first exps))

(t (cons op exps))))

(defun length=1 (x)

(and (consp x) (null (cdr x))))

(defun last1 (list)

(first (last list)))

(defun scheme ()

(init-scheme-interp)

(loop (format t "~&==> ")

(print (interp (read) nil))))

(def-scheme-macro let (bindings &rest body)

`((lambda ,(mapcar #'first bindings) . ,body)

.,(mapcar #'second bindings)))

(def-scheme-macro let* (bindings &rest body)

(if (null bindings)

`(begin . ,body)

`(let (,(first bindings))

(let* ,(rest bindings) . ,body))))

(def-scheme-macro and (&rest args)

(cond ((null args) 'T)

((length=1 args) (first args))

(t `(if ,(first args)

(and . ,(rest args))))))

(def-scheme-macro or (&rest args)

(cond ((null args) 'nil)

((length=1 args) (first args))

(t (let ((var (gensym)))

`(let ((,var ,(first args)))

(if ,var ,var (or . ,(rest args))))))))

(init-scheme-interp)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;; and there we have a scheme interpreter with macros. ;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defstruct block

(index 0) (timestamp 0) data (previous-hash "") hash)

(defstruct transaction

from to (value 0) (accuracy 1)

(duration 0)

data hash previous-hash)

(defun to-byte-array (x)

(let ((retval (make-array 0 :adjustable t

:fill-pointer t

:element-type '(unsigned-byte 8))))

(map 'nil (lambda (c) (vector-push-extend (char-code c) retval))

(format nil "~A" x)) ;

(coerce retval 'ironclad::simple-octet-vector)))

(defun make-address (x)

(let ((digester (ironclad:make-digest :sha3)))