<html><head><meta http-equiv="Content-Type" content="text/html; charset=utf-8"></head><body style="word-wrap: break-word; -webkit-nbsp-mode: space; line-break: after-white-space;" class="">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. <div class=""><br class=""></div><div class="">Incomplete, but still interesting per the previous week’s discussion.</div><div class=""><br class=""></div><div class=""><div class="">;;</div><div class="">;; scheme coin - a common lisp blockchain</div><div class="">;;</div><div class="">;; Burton Samograd</div><div class="">;; 2017</div><div class=""><br class=""></div><div class="">(load "~/quicklisp/setup.lisp")</div><div class=""><br class=""></div><div class="">(defconstant *coin-name* "Scheme Coin")</div><div class=""><br class=""></div><div class="">(eval-when (compile load)</div><div class=""> (ql:quickload "ironclad"))</div><div class=""><br class=""></div><div class="">(defun rest2 (l)</div><div class=""> (cddr l))</div><div class=""><br class=""></div><div class="">(defun interp (x &optional env)</div><div class=""> "Interpret (evaluate) the expression x in the environment env."</div><div class=""> (cond</div><div class=""> ((symbolp x) (get-var x env))</div><div class=""> ((atom x) x)</div><div class=""> ((scheme-macro (first x))</div><div class=""> (interp (scheme-macro-expand x) env))</div><div class=""> ((case (first x)</div><div class=""> (QUOTE (second x))</div><div class=""> (BEGIN (last1 (mapcar #'(lambda (y) (interp y env))</div><div class=""> (rest x))))</div><div class=""> (SET! (set-var! (second x) (interp (third x) env) env))</div><div class=""> (if (if (interp (second x) env)</div><div class=""> (interp (third x) env)</div><div class=""> (interp (fourth x) env)))</div><div class=""> (LAMBDA (let ((parms (second x))</div><div class=""> (code (maybe-add 'begin (rest2 x))))</div><div class=""> #'(lambda (&rest args)</div><div class=""> (interp code (extend-env parms args env)))))</div><div class=""> (t ;; a procedure application</div><div class=""> (apply (interp (first x) env)</div><div class=""> (mapcar #'(lambda (v) (interp v env))</div><div class=""> (rest x))))))))</div><div class=""><br class=""></div><div class="">(defun scheme-macro (symbol)</div><div class=""> (and (symbolp symbol) (get symbol 'scheme-macro)))</div><div class=""><br class=""></div><div class="">(defmacro def-scheme-macro (name parmlist &body body)</div><div class=""> `(setf (get ',name 'scheme-macro)</div><div class=""> #'(lambda ,parmlist .,body)))</div><div class=""><br class=""></div><div class="">(defun scheme-macro-expand (x)</div><div class=""> (if (and (listp x) (scheme-macro (first x)))</div><div class=""> (scheme-macro-expand</div><div class=""> (apply (scheme-macro (first x)) (rest x)))</div><div class=""> x))</div><div class=""><br class=""></div><div class="">(defun set-var! (var val env)</div><div class=""> "Set a variable to a value, in the given or global environment."</div><div class=""> (if (assoc var env)</div><div class=""> (setf (second (assoc var env)) val)</div><div class=""> (set-global-var! var val))</div><div class=""> val)</div><div class=""><br class=""></div><div class="">(defun get-var (var env)</div><div class=""> (if (assoc var env)</div><div class=""> (second (assoc var env))</div><div class=""> (get-global-var var)))</div><div class=""><br class=""></div><div class="">(defun set-global-var! (var val)</div><div class=""> (setf (get var 'global-val) val))</div><div class=""><br class=""></div><div class="">(defun get-global-var (var)</div><div class=""> (let* ((default "unbound")</div><div class=""> (val (get var 'global-val default)))</div><div class=""> (if (eq val default)</div><div class=""> (error "Unbound scheme variable: ~A" var)</div><div class=""> val)))</div><div class=""><br class=""></div><div class="">(defun extend-env (vars vals env)</div><div class=""> "Add some variables and values to and environment."</div><div class=""> (nconc (mapcar #'list vars vals) env))</div><div class=""><br class=""></div><div class="">(defparameter *scheme-procs*</div><div class=""> '(+ - * / = < > <= >= cons car cdr not append list read member </div><div class=""> (null? null) (eq? eq) (equal? equal) (eqv? eql)</div><div class=""> (write prin1) (display princ) (newline terpri)))</div><div class=""><br class=""></div><div class="">(defun init-scheme-interp ()</div><div class=""> (mapc #'init-scheme-proc *scheme-procs*)</div><div class=""> (set-global-var! t t)</div><div class=""> (set-global-var! nil nil))</div><div class=""><br class=""></div><div class="">(defun init-scheme-proc (f)</div><div class=""> (if (listp f)</div><div class=""> (set-global-var! (first f) (symbol-function (second f)))</div><div class=""> (set-global-var! f (symbol-function f))))</div><div class=""><br class=""></div><div class="">(defun maybe-add (op exps &optional if-nil)</div><div class=""> (cond ((null exps) if-nil)</div><div class=""> ((length=1 exps) (first exps))</div><div class=""> (t (cons op exps))))</div><div class=""><br class=""></div><div class="">(defun length=1 (x) </div><div class=""> (and (consp x) (null (cdr x))))</div><div class=""><br class=""></div><div class="">(defun last1 (list)</div><div class=""> (first (last list)))</div><div class=""><br class=""></div><div class="">(defun scheme ()</div><div class=""> (init-scheme-interp)</div><div class=""> (loop (format t "~&==> ")</div><div class=""> (print (interp (read) nil))))</div><div class=""><br class=""></div><div class="">(def-scheme-macro let (bindings &rest body)</div><div class=""> `((lambda ,(mapcar #'first bindings) . ,body)</div><div class=""> .,(mapcar #'second bindings)))</div><div class=""><br class=""></div><div class="">(def-scheme-macro let* (bindings &rest body)</div><div class=""> (if (null bindings)</div><div class=""> `(begin . ,body)</div><div class=""> `(let (,(first bindings))</div><div class=""> (let* ,(rest bindings) . ,body))))</div><div class=""><br class=""></div><div class="">(def-scheme-macro and (&rest args)</div><div class=""> (cond ((null args) 'T)</div><div class=""> ((length=1 args) (first args))</div><div class=""> (t `(if ,(first args)</div><div class=""> (and . ,(rest args))))))</div><div class=""><br class=""></div><div class="">(def-scheme-macro or (&rest args)</div><div class=""> (cond ((null args) 'nil)</div><div class=""> ((length=1 args) (first args))</div><div class=""> (t (let ((var (gensym)))</div><div class=""> `(let ((,var ,(first args)))</div><div class=""> (if ,var ,var (or . ,(rest args))))))))</div><div class=""><br class=""></div><div class="">(init-scheme-interp)</div><div class="">;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;</div><div class="">;;;;;; and there we have a scheme interpreter with macros. ;;;;;;;;;;;;;;;</div><div class="">;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;</div><div class=""><br class=""></div><div class="">(defstruct block</div><div class=""> (index 0) (timestamp 0) data (previous-hash "") hash)</div><div class=""><br class=""></div><div class="">(defstruct transaction </div><div class=""> from to (value 0) (accuracy 1)</div><div class=""> (duration 0)</div><div class=""> data hash previous-hash)</div><div class=""><br class=""></div><div class="">(defun to-byte-array (x)</div><div class=""> (let ((retval (make-array 0 :adjustable t </div><div class=""> :fill-pointer t </div><div class=""> :element-type '(unsigned-byte 8))))</div><div class=""> (map 'nil (lambda (c) (vector-push-extend (char-code c) retval))</div><div class=""> (format nil "~A" x)) ;</div><div class=""> (coerce retval 'ironclad::simple-octet-vector)))</div><div class=""><br class=""></div><div class="">(defun make-address (x)</div><div class=""> (let ((digester (ironclad:make-digest :sha3)))</div><div class=""> (ironclad:update-digest digester</div><div class=""> (to-byte-array x))</div><div class=""> (ironclad:produce-digest digester)))</div><div class=""><br class=""></div><div class="">(defun hash-block (block)</div><div class=""> (let ((digester (ironclad:make-digest :sha3)))</div><div class=""> (ironclad:update-digest digester</div><div class=""> (to-byte-array (block-index block)))</div><div class=""> (ironclad:update-digest digester</div><div class=""> (to-byte-array (block-timestamp block)))</div><div class=""> (ironclad:update-digest digester</div><div class=""> (to-byte-array (block-data block)))</div><div class=""> (ironclad:update-digest digester</div><div class=""> (to-byte-array (block-previous-hash block)))</div><div class=""> (ironclad:produce-digest digester)))</div><div class=""><br class=""></div><div class="">(defun hash-transaction (block)</div><div class=""> (let ((digester (ironclad:make-digest :sha3)))</div><div class=""> (ironclad:update-digest digester</div><div class=""> (to-byte-array (transaction-from block)))</div><div class=""> (ironclad:update-digest digester</div><div class=""> (to-byte-array (transaction-to block)))</div><div class=""> (ironclad:update-digest digester</div><div class=""> (to-byte-array (transaction-value block)))</div><div class=""> (ironclad:update-digest digester</div><div class=""> (to-byte-array (transaction-accuracy block)))</div><div class=""> (ironclad:update-digest digester</div><div class=""> (to-byte-array (transaction-duration block)))</div><div class=""> (ironclad:update-digest digester</div><div class=""> (to-byte-array (transaction-data block)))</div><div class=""> (ironclad:produce-digest digester)))</div><div class=""><br class=""></div><div class="">(defun make-genesis-block (data time)</div><div class=""> (let* ((block (make-block </div><div class=""> :index 0</div><div class=""> :timestamp time</div><div class=""> :data data</div><div class=""> :hash 0))</div><div class=""> (hash (hash-block block)))</div><div class=""> (setf (block-hash block) hash)</div><div class=""> block))</div><div class=""><br class=""></div><div class="">(defmacro create-genesis-block (data)</div><div class=""> `(let ((time (get-universal-time)))</div><div class=""> (make-genesis-block ,data time)))</div><div class=""><br class=""></div><div class="">(defun next-block (last-block data)</div><div class=""> (let ((block (make-block :index (1+ (block-index last-block))</div><div class=""> :timestamp (get-universal-time)</div><div class=""> :data data</div><div class=""> :previous-hash (hash-block last-block))))</div><div class=""> (setf (block-hash block) (hash-block block))</div><div class=""> (push block *blockchain*)</div><div class=""> block))</div><div class=""> </div><div class="">(setf *print-base* 16)</div><div class=""><br class=""></div><div class="">(defconstant *base-code* '(set! x 0))</div><div class=""><br class=""></div><div class="">(defparameter *network-address* (make-address *coin-name*))</div><div class="">(defparameter *quester-address* (make-address "quester"))</div><div class="">(defparameter *miner-address* (make-address "miner"))</div><div class="">(defparameter *contract-address* (make-address "contract"))</div><div class=""><br class=""></div><div class="">(defparameter *block-transactions*</div><div class=""> (let ((transaction (make-transaction :from *network-address*</div><div class=""> :to *quester-address*</div><div class=""> :value (* 10000 10000 10000)</div><div class=""> :data *base-code*)))</div><div class=""> (setf (transaction-hash transaction)</div><div class=""> (hash-transaction transaction))</div><div class=""> (list transaction)))</div><div class=""><br class=""></div><div class="">(defparameter *blockchain* </div><div class=""> (list (create-genesis-block *block-transactions*)))</div><div class=""><br class=""></div><div class="">(defparameter *previous-block* (car *blockchain*))</div><div class=""><br class=""></div><div class="">(defparameter *solved-transactions* (make-hash-table :test #'equalp</div><div class=""> :weak-kind t))</div><div class="">(eval-when (compile load)</div><div class=""> (defun new-transaction (&key from to (value 0) accuracy data </div><div class=""> previous-hash duration)</div><div class=""> (let ((transaction (make-transaction :from from :to to :value value</div><div class=""> :accuracy accuracy :data data </div><div class=""> :previous-hash previous-hash</div><div class=""> :duration duration)))</div><div class=""> (setf (transaction-hash transaction)</div><div class=""> (hash-transaction transaction))</div><div class=""> (when previous-hash</div><div class=""> (setf (gethash</div><div class=""> (transaction-hash transaction)</div><div class=""> *solved-transactions*)</div><div class=""> t))</div><div class=""> transaction)))</div><div class=""><br class=""></div><div class="">(defmacro submit-answer (from transaction data)</div><div class=""> `(push (new-transaction :from ,from :to *contract-address*</div><div class=""> :previous-hash (transaction-hash transaction)</div><div class=""> :data ,data)</div><div class=""> *block-transactions*))</div><div class=""><br class=""></div><div class="">(defun has-transaction-not-been-solved (transaction)</div><div class=""> (if (gethash (transaction-hash transaction) </div><div class=""> *solved-transactions*)</div><div class=""> (not (setf (gethash (transaction-hash transaction) </div><div class=""> *solved-transactions*)</div><div class=""> transaction))</div><div class=""> t))</div><div class=""><br class=""></div><div class="">(defun viable-transaction (transaction)</div><div class=""> (and (has-transaction-not-been-solved transaction)</div><div class=""> (<= (block-index (car *blockchain*))</div><div class=""> (or (transaction-duration transaction) </div><div class=""> (get-universal-time))))) ;; can still submit</div><div class=""><br class=""></div><div class="">(defun verify-transaction (transaction)</div><div class=""> (handler-case</div><div class=""> (interp (transaction-data transaction))</div><div class=""> (error (e) e)))</div><div class=""> </div><div class="">(defun execute-transactions (miner-address)</div><div class=""> (dolist (transaction *block-transactions*)</div><div class=""> (when (viable-transaction transaction)</div><div class=""> (print :submitting-answer)</div><div class=""> (submit-answer miner-address transaction </div><div class=""> (verify-transaction transaction))</div><div class=""> )))</div><div class=""><br class=""></div><div class="">(defun mine ()</div><div class=""> (when *block-transactions*</div><div class=""> (execute-transactions *miner-address*)</div><div class=""> (transfer *network-address* *miner-address* 1)</div><div class=""> (setf *previous-block* </div><div class=""> (next-block *previous-block* *block-transactions*))</div><div class=""> (setf *block-transactions* nil)))</div><div class=""> </div><div class="">(defmacro transfer (from to value)</div><div class=""> `(push (new-transaction :from ,from :to ,to</div><div class=""> :value ,value)</div><div class=""> *block-transactions*))</div><div class=""><br class=""></div><div class="">(defmacro execute (from value code &key (accuracy value) </div><div class=""> (duration (+ 2 (block-index (car *blockchain*)))))</div><div class=""> `(push (new-transaction :from ,from :to *contract-address*</div><div class=""> :value ,value</div><div class=""> :accuracy ,accuracy :data ',code </div><div class=""> :duration ,duration)</div><div class=""> *block-transactions*))</div><div class=""><br class=""></div><div class="">(defun process-transfer-request (request stream)</div><div class=""> (destructuring-bind (from to value)</div><div class=""> request</div><div class=""> (transfer from to value)))</div><div class=""><br class=""></div><div class="">(defun process-execute-request (request stream)</div><div class=""> (destructuring-bind (from value data &key (accuracy value) </div><div class=""> (duration (+ 2 (block-index (car *blockchain*))))) </div><div class=""> request</div><div class=""> (execute from value data :accuracy accuracy :duration duration)))</div><div class=""><br class=""></div><div class="">(defun process-blocks-request (request stream)</div><div class=""> (print *blockchain* stream))</div><div class=""><br class=""></div><div class="">(defun process-coin-server-request (stream)</div><div class=""> (let ((request (read stream)))</div><div class=""> (case request</div><div class=""> (transfer (process-transfer-request (cdr request) stream))</div><div class=""> (execute (process-execute-request (cdr request) stream))</div><div class=""> (blocks (process-blocks-request (cdr request) stream)))))</div><div class=""><br class=""></div><div class="">(defun coin-server (handle)</div><div class=""> (let ((stream (make-instance 'comm:socket-stream</div><div class=""> :socket handle</div><div class=""> :direction :io</div><div class=""> :element-type</div><div class=""> 'base-char)))</div><div class=""> (process-coin-server-request stream)))</div><div class=""><br class=""></div><div class="">(defvar *server* (comm:start-up-server :function #'coin-server</div><div class=""> :service 9999</div><div class=""> :process-name </div><div class=""> (format nil "~A server" *coin-name*)))</div><div class=""><br class=""></div><div class="">(loop</div><div class=""> (mine)</div><div class=""> (sleep 1))</div></div><div class=""><br class=""></div><div class="">Enjoy! If you have any questions, feel free to ask.</div><div class=""><br class=""></div><div class="">Made with LispWorks, but it really only uses the function comm:start-up-server I think.</div><div class=""><br class=""></div><div class="">—</div><div class="">Burton Samograd</div><div class="">BusFactor1 Inc.</div><div class=""><a href="http://busfactor1.ca/" class="">http://busfactor1.ca/</a></div><div class=""><br class=""></div><div class="">Check out my software in the macOS App Store.</div></body></html>