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