Common Lisp Blockchain - Scheme Coin
Scott McKay
swmckay at gmail.com
Mon Dec 18 21:09:34 UTC 2017
Ha ha ha, awesome!
On Sun, Dec 17, 2017 at 12:57 AM, Burton Samograd <busfactor1 at icloud.com>
wrote:
> 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/
>
> Check out my software in the macOS App Store.
>
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://mailman.common-lisp.net/pipermail/pro/attachments/20171218/7d77e918/attachment-0001.html>
More information about the pro
mailing list