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))) (ironclad:update-digest digester (to-byte-array x)) (ironclad:produce-digest digester)))
(defun hash-block (block) (let ((digester (ironclad:make-digest :sha3))) (ironclad:update-digest digester (to-byte-array (block-index block))) (ironclad:update-digest digester (to-byte-array (block-timestamp block))) (ironclad:update-digest digester (to-byte-array (block-data block))) (ironclad:update-digest digester (to-byte-array (block-previous-hash block))) (ironclad:produce-digest digester)))
(defun hash-transaction (block) (let ((digester (ironclad:make-digest :sha3))) (ironclad:update-digest digester (to-byte-array (transaction-from block))) (ironclad:update-digest digester (to-byte-array (transaction-to block))) (ironclad:update-digest digester (to-byte-array (transaction-value block))) (ironclad:update-digest digester (to-byte-array (transaction-accuracy block))) (ironclad:update-digest digester (to-byte-array (transaction-duration block))) (ironclad:update-digest digester (to-byte-array (transaction-data block))) (ironclad:produce-digest digester)))
(defun make-genesis-block (data time) (let* ((block (make-block :index 0 :timestamp time :data data :hash 0)) (hash (hash-block block))) (setf (block-hash block) hash) block))
(defmacro create-genesis-block (data) `(let ((time (get-universal-time))) (make-genesis-block ,data time)))
(defun next-block (last-block data) (let ((block (make-block :index (1+ (block-index last-block)) :timestamp (get-universal-time) :data data :previous-hash (hash-block last-block)))) (setf (block-hash block) (hash-block block)) (push block *blockchain*) block))
(setf *print-base* 16)
(defconstant *base-code* '(set! x 0))
(defparameter *network-address* (make-address *coin-name*)) (defparameter *quester-address* (make-address "quester")) (defparameter *miner-address* (make-address "miner")) (defparameter *contract-address* (make-address "contract"))
(defparameter *block-transactions* (let ((transaction (make-transaction :from *network-address* :to *quester-address* :value (* 10000 10000 10000) :data *base-code*))) (setf (transaction-hash transaction) (hash-transaction transaction)) (list transaction)))
(defparameter *blockchain* (list (create-genesis-block *block-transactions*)))
(defparameter *previous-block* (car *blockchain*))
(defparameter *solved-transactions* (make-hash-table :test #'equalp :weak-kind t)) (eval-when (compile load) (defun new-transaction (&key from to (value 0) accuracy data previous-hash duration) (let ((transaction (make-transaction :from from :to to :value value :accuracy accuracy :data data :previous-hash previous-hash :duration duration))) (setf (transaction-hash transaction) (hash-transaction transaction)) (when previous-hash (setf (gethash (transaction-hash transaction) *solved-transactions*) t)) transaction)))
(defmacro submit-answer (from transaction data) `(push (new-transaction :from ,from :to *contract-address* :previous-hash (transaction-hash transaction) :data ,data) *block-transactions*))
(defun has-transaction-not-been-solved (transaction) (if (gethash (transaction-hash transaction) *solved-transactions*) (not (setf (gethash (transaction-hash transaction) *solved-transactions*) transaction)) t))
(defun viable-transaction (transaction) (and (has-transaction-not-been-solved transaction) (<= (block-index (car *blockchain*)) (or (transaction-duration transaction) (get-universal-time))))) ;; can still submit
(defun verify-transaction (transaction) (handler-case (interp (transaction-data transaction)) (error (e) e)))
(defun execute-transactions (miner-address) (dolist (transaction *block-transactions*) (when (viable-transaction transaction) (print :submitting-answer) (submit-answer miner-address transaction (verify-transaction transaction)) )))
(defun mine () (when *block-transactions* (execute-transactions *miner-address*) (transfer *network-address* *miner-address* 1) (setf *previous-block* (next-block *previous-block* *block-transactions*)) (setf *block-transactions* nil)))
(defmacro transfer (from to value) `(push (new-transaction :from ,from :to ,to :value ,value) *block-transactions*))
(defmacro execute (from value code &key (accuracy value) (duration (+ 2 (block-index (car *blockchain*))))) `(push (new-transaction :from ,from :to *contract-address* :value ,value :accuracy ,accuracy :data ',code :duration ,duration) *block-transactions*))
(defun process-transfer-request (request stream) (destructuring-bind (from to value) request (transfer from to value)))
(defun process-execute-request (request stream) (destructuring-bind (from value data &key (accuracy value) (duration (+ 2 (block-index (car *blockchain*))))) request (execute from value data :accuracy accuracy :duration duration)))
(defun process-blocks-request (request stream) (print *blockchain* stream))
(defun process-coin-server-request (stream) (let ((request (read stream))) (case request (transfer (process-transfer-request (cdr request) stream)) (execute (process-execute-request (cdr request) stream)) (blocks (process-blocks-request (cdr request) stream)))))
(defun coin-server (handle) (let ((stream (make-instance 'comm:socket-stream :socket handle :direction :io :element-type 'base-char))) (process-coin-server-request stream)))
(defvar *server* (comm:start-up-server :function #'coin-server :service 9999 :process-name (format nil "~A server" *coin-name*)))
(loop (mine) (sleep 1))
Enjoy! If you have any questions, feel free to ask.
Made with LispWorks, but it really only uses the function comm:start-up-server I think.
— Burton Samograd BusFactor1 Inc. http://busfactor1.ca/ http://busfactor1.ca/
Check out my software in the macOS App Store.