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