Ha ha ha, awesome! On Sun, Dec 17, 2017 at 12:57 AM, Burton Samograd <busfact...@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. >