Common Lisp Blockchain - Scheme Coin

[Burton Samograd]

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.

[David McClain]

seems to be a problem with the use of TRANSFER here:


(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)))))

Also redefines BLOCK and so we probably need to declare shadowing at the top.

Not sure what the quickload stuff was trying to accomplish, but my resident version of Ironclad kept shadowing anything imported by quickload. No SHA3 digest in my resident version, so I replaced it (for now) with the bleeding edge version from GitHub. That worked, as far as I can tell.

Actually had to compile buffer twice in order to get past the TRANSFER error (not sure why that even works?) but the system appears to be hung waiting for some kind of network connection. Perhaps you could give us a usage hint?

Cheers,

- DM

[David McClain]

okay, my bad
 I see that the TRANSFER is part of a CASE construct. But here is the error on initial compile buffer:

The call (#<Function TRANSFER 422001358C> #(58 EF D8 12 7C 50 5F 84 C4 53 B3 DE EB 5E 5 8 CB E2 ED B7 D2 75 7C 34 1D DD 8 6 C0 74 8B 5F B3 13 91 D3 BD A7 FB E4 ...) #(5F 80 7 5C C6 4E 24 BE 27
EA EB DE 93 B5 92 E5 27 FF BF 37 40 90 63 D0 F5 38 D5 0 DA 6E 15 62 FA B5 CC 5 84 CC C5 A5 ...) 1) does not match definition (#<Function TRANSFER 422001358C> FROM TO VALUE).

Debugger points to MINE. Happens during COMPILE-FILE.

- DM

Post by Burton Samograd
(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)))))
Also redefines BLOCK and so we probably need to declare shadowing at the top.
Not sure what the quickload stuff was trying to accomplish, but my resident version of Ironclad kept shadowing anything imported by quickload. No SHA3 digest in my resident version, so I replaced it (for now) with the bleeding edge version from GitHub. That worked, as far as I can tell.
Actually had to compile buffer twice in order to get past the TRANSFER error (not sure why that even works?) but the system appears to be hung waiting for some kind of network connection. Perhaps you could give us a usage hint?
Cheers,
- DM

[David McClain]

Problem with TRANSFER seems to be that its first use was prior to its Macro Definition. Placing the Macro Definition ahead of first use clears up the problem. But system is still hung waiting for a network connection


- DM

Post by David McClain
The call (#<Function TRANSFER 422001358C> #(58 EF D8 12 7C 50 5F 84 C4 53 B3 DE EB 5E 5 8 CB E2 ED B7 D2 75 7C 34 1D DD 8 6 C0 74 8B 5F B3 13 91 D3 BD A7 FB E4 ...) #(5F 80 7 5C C6 4E 24 BE 27
EA EB DE 93 B5 92 E5 27 FF BF 37 40 90 63 D0 F5 38 D5 0 DA 6E 15 62 FA B5 CC 5 84 CC C5 A5 ...) 1) does not match definition (#<Function TRANSFER 422001358C> FROM TO VALUE).
Debugger points to MINE. Happens during COMPILE-FILE.
- DM

Post by Burton Samograd
(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)))))
Also redefines BLOCK and so we probably need to declare shadowing at the top.
Not sure what the quickload stuff was trying to accomplish, but my resident version of Ironclad kept shadowing anything imported by quickload. No SHA3 digest in my resident version, so I replaced it (for now) with the bleeding edge version from GitHub. That worked, as far as I can tell.
Actually had to compile buffer twice in order to get past the TRANSFER error (not sure why that even works?) but the system appears to be hung waiting for some kind of network connection. Perhaps you could give us a usage hint?
Cheers,
- DM

[David McClain]

umm… was this supposed to be some kind of joke? I’ll bite... I don’t get it. I was actually hoping to learn something here...

But the code does look rather peculiar on close inspection. Why the use of macros for pushing new transaction blocks? And the conversions to octet vectors may work for strings, but not in general for arbitrary integer or float values…

If it is supposed to be a joke, I’ll chuckle and just chuck the code…

- DM

[Pascal Bourguignon]

umm
 was this supposed to be some kind of joke? I’ll bite... I don’t get it. I was actually hoping to learn something here...
But the code does look rather peculiar on close inspection. Why the use of macros for pushing new transaction blocks? And the conversions to octet vectors may work for strings, but not in general for arbitrary integer or float values

If it is supposed to be a joke, I’ll chuckle and just chuck the code


I guess not: https://dev.to/damcosset/trying-to-understand-blockchain-by-making-one-ce4
It’s like, everybody will be busy implementing blockchains. It’s the new fizz-buzz


[David McClain]

Well, I thought, after delving deeper into the code, that it might be some kind of sophisticated programmer humor, making a comment about the vast amount of CPU cycles devoted to nonsensical computing or some such


- DM

umm
 was this supposed to be some kind of joke? I’ll bite... I don’t get it. I was actually hoping to learn something here...
But the code does look rather peculiar on close inspection. Why the use of macros for pushing new transaction blocks? And the conversions to octet vectors may work for strings, but not in general for arbitrary integer or float values

If it is supposed to be a joke, I’ll chuckle and just chuck the code


I guess not: https://dev.to/damcosset/trying-to-understand-blockchain-by-making-one-ce4 <https://dev.to/damcosset/trying-to-understand-blockchain-by-making-one-ce4>
It’s like, everybody will be busy implementing blockchains. It’s the new fizz-buzz

--
__Pascal J. Bourguignon__

[Burton Samograd]

Hi David,

An attempt at humour? No, not intentionally! haha But anything I can do that can make people laugh is good in my books.

It’s a somewhat serious ‘rough sketch’ of a working blockchain (at least I think it’s working) and an example of how such a system would work; a springboard. I got a bit creative with the addition of a Scheme interpreter in an attempt to make the system ‘useful’ rather than ‘wasteful’. It’s incomplete, i know that at this point, but I thought I would share. Writing explanatory blockchains is pretty hot right now. I hope this one is simple (and correct!) enough to show the concepts in a familiar language.

—
Burton Samograd

Post by David McClain
Well, I thought, after delving deeper into the code, that it might be some kind of sophisticated programmer humor, making a comment about the vast amount of CPU cycles devoted to nonsensical computing or some such

- DM

umm
 was this supposed to be some kind of joke? I’ll bite... I don’t get it. I was actually hoping to learn something here...
But the code does look rather peculiar on close inspection. Why the use of macros for pushing new transaction blocks? And the conversions to octet vectors may work for strings, but not in general for arbitrary integer or float values

If it is supposed to be a joke, I’ll chuckle and just chuck the code


I guess not: https://dev.to/damcosset/trying-to-understand-blockchain-by-making-one-ce4 <https://dev.to/damcosset/trying-to-understand-blockchain-by-making-one-ce4>
It’s like, everybody will be busy implementing blockchains. It’s the new fizz-buzz

--
__Pascal J. Bourguignon__

[David McClain]

Hi Burton,

Post by Burton Samograd
Hi David,
An attempt at humour? No, not intentionally! haha But anything I can do that can make people laugh is good in my books.

I was wondering, after some of the other comments. But now I understand why you used macros on the major update functions. That isn’t something I would normally do because it precludes introducing computed parameter values, and also leaves you open to variable capture. So that degree of complexity seemed like it might have been part of the joke.

I don’t recall completely, but it did seem like one of your uses of an update macro actually did introduce a free variable inside the macro, and that would then only work if the outer lexical context of the macro had a same-named binding. Macros introduce a whole other layer of complexity. That’s probably why so many in the Scheme camp seem bent on hygienic macros.

Cheers,

- DM

[Burton Samograd]

It is. I submitted it to Hacker News, but the upvotes didn’t show like the Python one that got up there today:

https://news.ycombinator.com/item?id=15938348

Upvote please, if you have an account.

--
Burton Samograd

umm
 was this supposed to be some kind of joke? I’ll bite... I don’t get it. I was actually hoping to learn something here...
But the code does look rather peculiar on close inspection. Why the use of macros for pushing new transaction blocks? And the conversions to octet vectors may work for strings, but not in general for arbitrary integer or float values

If it is supposed to be a joke, I’ll chuckle and just chuck the code


I guess not: https://dev.to/damcosset/trying-to-understand-blockchain-by-making-one-ce4 <https://dev.to/damcosset/trying-to-understand-blockchain-by-making-one-ce4>
It’s like, everybody will be busy implementing blockchains. It’s the new fizz-buzz

--
__Pascal J. Bourguignon__

[Antoniotti Marco]

Post by Pascal Bourguignon

Post by David McClain
umm… was this supposed to be some kind of joke? I’ll bite... I don’t get it. I was actually hoping to learn something here...
But the code does look rather peculiar on close inspection. Why the use of macros for pushing new transaction blocks? And the conversions to octet vectors may work for strings, but not in general for arbitrary integer or float values…
If it is supposed to be a joke, I’ll chuckle and just chuck the code…

I guess not: https://dev.to/damcosset/trying-to-understand-blockchain-by-making-one-ce4
It’s like, everybody will be busy implementing blockchains. It’s the new fizz-buzz…

… or planting tulips :) :) :)


Cheers

MA

[David McClain]

It seems to me that, instead of performing totally useless computations for POW, a group like CERN might enlist the miners to search for W-Boson events from their detector trails, or astronomers might enlist the mining enclaves to search for SETI events
 (no joke
)

- DM

Post by Pascal Bourguignon

umm
 was this supposed to be some kind of joke? I’ll bite... I don’t get it. I was actually hoping to learn something here...
But the code does look rather peculiar on close inspection. Why the use of macros for pushing new transaction blocks? And the conversions to octet vectors may work for strings, but not in general for arbitrary integer or float values

If it is supposed to be a joke, I’ll chuckle and just chuck the code


I guess not: https://dev.to/damcosset/trying-to-understand-blockchain-by-making-one-ce4
It’s like, everybody will be busy implementing blockchains. It’s the new fizz-buzz



 or planting tulips :) :) :)
Cheers
MA
--
Marco Antoniotti

[Alessio Stalla]

Well, that's a great idea!

Il 19 dic 2017 11:36, "David McClain" <***@refined-audiometrics.com> ha
scritto:

It seems to me that, instead of performing totally useless computations for
POW, a group like CERN might enlist the miners to search for W-Boson events
from their detector trails, or astronomers might enlist the mining enclaves
to search for SETI events
 (no joke
)

- DM

On Dec 18, 2017, at 23:03, Antoniotti Marco <***@disco.
unimib.it> wrote:


On Dec 18, 2017, at 23:54 , Pascal Bourguignon <***@informatimago.com>
wrote:



On 18 Dec 2017, at 23:31, David McClain <***@refined-audiometrics.com>
wrote:

umm
 was this supposed to be some kind of joke? I’ll bite... I don’t get
it. I was actually hoping to learn something here...

But the code does look rather peculiar on close inspection. Why the use of
macros for pushing new transaction blocks? And the conversions to octet
vectors may work for strings, but not in general for arbitrary integer or
float values


If it is supposed to be a joke, I’ll chuckle and just chuck the code



I guess not: https://dev.to/damcosset/trying-to-understand-
blockchain-by-making-one-ce4
It’s like, everybody will be busy implementing blockchains. It’s the new
fizz-buzz




 or planting tulips :) :) :)


Cheers

MA


--
Marco Antoniotti

[Burton Samograd]

Post by David McClain
umm… was this supposed to be some kind of joke?

Not intentionally, but I think I cleared that up earlier :)

Post by David McClain
I’ll bite... I don’t get it. I was actually hoping to learn something here…

What didn’t you learn? What were you expecting to see?

Post by David McClain
But the code does look rather peculiar on close inspection.

I’ve got my own style. I rarely work with other people(’s) code in CL, so this is how I write it.

Post by David McClain
Why the use of macros for pushing new transaction blocks?

So I don’t have to quote arguments in the REPL when typing in the calls manually. It also saves the caller from having to remember which arguments to quote when calling, just their form.

Post by David McClain
And the conversions to octet vectors may work for strings, but not in general for arbitrary integer or float values…

I’m not sure what you mean there. This code?

(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)))

I would think the ~A in the format would give a solid textual representation for any type that has a printable expression. Am I incorrect in that?

Post by David McClain
If it is supposed to be a joke, I’ll chuckle and just chuck the code…

I hope you enjoyed reading it as much as I enjoyed writing it. I hope others find it useful.

Post by David McClain
- DM

—
Burton Samograd

[David McClain]

Post by Burton Samograd

Post by David McClain
And the conversions to octet vectors may work for strings, but not in general for arbitrary integer or float values…

I’m not sure what you mean there. This code?
(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)))
I would think the ~A in the format would give a solid textual representation for any type that has a printable expression. Am I incorrect in that?

Sorry, I might have got a bit ahead of myself there. But in general, objects that might be involved in a transaction could have values that are difficult to print.

Take for example a structure, or a class instance. And for floating point values, the ~A is too lenient in terms of digits printed, rounding, etc. This code will also be dependent on the current value of *PRINT-BASE*, which I noticed that you permanently set to 16 along the way.

But I saw your intent, and I substituted my own network byte encoding which handles everything except compiled closures.

- DM

[Burton Samograd]

Patches welcome.

Burton

Post by David McClain

Post by Burton Samograd

Post by David McClain
And the conversions to octet vectors may work for strings, but not in general for arbitrary integer or float values…

I’m not sure what you mean there. This code?
(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)))
I would think the ~A in the format would give a solid textual representation for any type that has a printable expression. Am I incorrect in that?

Sorry, I might have got a bit ahead of myself there. But in general, objects that might be involved in a transaction could have values that are difficult to print.
Take for example a structure, or a class instance. And for floating point values, the ~A is too lenient in terms of digits printed, rounding, etc. This code will also be dependent on the current value of *PRINT-BASE*, which I noticed that you permanently set to 16 along the way.
But I saw your intent, and I substituted my own network byte encoding which handles everything except compiled closures.
- DM

[Burton Samograd]

TBH it doesn’t really do anything yet but evaluate ‘code’ transactions that are placed on the blockchain using the (execute 
) macro, like this:

CL-USER 20 : 2 > (execute *quester-address* 1 (set! square (lambda (x) (* x x))))
(#S(TRANSACTION :FROM #(82 47 C9 D C8 6F 69 5A 25 3B 8A 6F 44 17 8F A8 EC 6B F8 24 30 3F AC FC D8 B7 20 4 BD F0 4F 8F 39 C1 EA C4 67 1F A2 2A ...) :TO #(FE BA 12 F3 81 48 A2 89 31 7D 9C D5 8D 80 91 C4 F4 CE 6B 7B B6 E7 A8 8F 11 89 8 F6 6E 7E 26 E8 39 95 73 BD 63 B0 4D 54 ...) :VALUE 1 :ACCURACY 1 :DURATION 13D5 :|DATA| (SET! SQUARE #) :HASH #(A5 42 F8 E3 CE 1E 2B 4C BF C2 83 C9 CF 45 38 CF CB 9B CB 85 9A F2 AC D7 26 5A A0 BE D4 C4 6E 37 F3 DD DC 85 A4 50 7B BD ...) :PREVIOUS-HASH NIL))

CL-USER 21 : 2 > (execute *quester-address* 1 (set! double (lambda (x) (+ x x))))
(#S(TRANSACTION :FROM #(82 47 C9 D C8 6F 69 5A 25 3B 8A 6F 44 17 8F A8 EC 6B F8 24 30 3F AC FC D8 B7 20 4 BD F0 4F 8F 39 C1 EA C4 67 1F A2 2A ...) :TO #(FE BA 12 F3 81 48 A2 89 31 7D 9C D5 8D 80 91 C4 F4 CE 6B 7B B6 E7 A8 8F 11 89 8 F6 6E 7E 26 E8 39 95 73 BD 63 B0 4D 54 ...) :VALUE 1 :ACCURACY 1 :DURATION 13D6 :|DATA| (SET! DOUBLE #) :HASH #(65 66 2D CD 38 AD 3D 5C 2 2D 4D 86 CE D2 79 D8 FC 63 B1 45 FF 7E 79 94 EF 82 D2 AD B5 3F B1 DD A5 70 1E E9 4E 6C 4E 1C ...) :PREVIOUS-HASH NIL))

CL-USER 22 : 2 > (execute *quester-address* 1 (set! x (+ (double 4) (square 4))))
(#S(TRANSACTION :FROM #(82 47 C9 D C8 6F 69 5A 25 3B 8A 6F 44 17 8F A8 EC 6B F8 24 30 3F AC FC D8 B7 20 4 BD F0 4F 8F 39 C1 EA C4 67 1F A2 2A ...) :TO #(FE BA 12 F3 81 48 A2 89 31 7D 9C D5 8D 80 91 C4 F4 CE 6B 7B B6 E7 A8 8F 11 89 8 F6 6E 7E 26 E8 39 95 73 BD 63 B0 4D 54 ...) :VALUE 1 :ACCURACY 1 :DURATION 13D7 :|DATA| (SET! X #) :HASH #(21 5C 71 F2 1F 5C B9 4F AE 4D 44 90 3 C8 7 39 51 64 5A D4 39 69 95 C0 4A 9F E6 30 8C 9D 4E DB E4 57 6C 98 31 79 E7 C2 ...) :PREVIOUS-HASH NIL))

CL-USER 23 : 2 > (pprint (car *blockchain*))

#S(BLOCK :INDEX 13D6
:TIMESTAMP DDE31477
:|DATA| (#S(TRANSACTION :FROM #
:TO #
:VALUE 1
:ACCURACY NIL
:DURATION NIL
:|DATA| NIL
:HASH #
:PREVIOUS-HASH NIL)
#S(TRANSACTION :FROM #
:TO #
:VALUE 0
:ACCURACY NIL
:DURATION NIL
:|DATA| 18
:HASH #
:PREVIOUS-HASH #)
#S(TRANSACTION :FROM #
:TO #
:VALUE 1
:ACCURACY 1
:DURATION 13D7
:|DATA| #
:HASH #
:PREVIOUS-HASH NIL))
:PREVIOUS-HASH #(D8 35 FF D5 4B 42 89 FA D4 E1 BB 16 BA C1 8 70
B8 A9 73 64 20 C9 7A D2 20 C1 50 5E 10 38 9E 3
D6 DF 95 C3 39 7 F8 74 ...)
:HASH #(D 33 62 56 1E ED 9D EE 93 A2 53 95 21 39 9F C2 54 40 DE
3D D2 4A 90 20 CD 4D FF 4B C2 68 7D 4F FA 4D 4 9 EC 93
CC F ...))

CL-USER 24 : 2 >

Where *quester-address* is an address that has some ‘value’ (as given to it by the “genesis” transaction in this implementation (aka this is totally premined)), the amount they are sending to ‘give’ to the miner for answering (aka the value that is transferred between accounts upon proof of work).

—
Burton Samograd

Post by David McClain
Problem with TRANSFER seems to be that its first use was prior to its Macro Definition. Placing the Macro Definition ahead of first use clears up the problem. But system is still hung waiting for a network connection

- DM

Post by David McClain
The call (#<Function TRANSFER 422001358C> #(58 EF D8 12 7C 50 5F 84 C4 53 B3 DE EB 5E 5 8 CB E2 ED B7 D2 75 7C 34 1D DD 8 6 C0 74 8B 5F B3 13 91 D3 BD A7 FB E4 ...) #(5F 80 7 5C C6 4E 24 BE 27
EA EB DE 93 B5 92 E5 27 FF BF 37 40 90 63 D0 F5 38 D5 0 DA 6E 15 62 FA B5 CC 5 84 CC C5 A5 ...) 1) does not match definition (#<Function TRANSFER 422001358C> FROM TO VALUE).
Debugger points to MINE. Happens during COMPILE-FILE.
- DM

Post by Burton Samograd
(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)))))
Also redefines BLOCK and so we probably need to declare shadowing at the top.
Not sure what the quickload stuff was trying to accomplish, but my resident version of Ironclad kept shadowing anything imported by quickload. No SHA3 digest in my resident version, so I replaced it (for now) with the bleeding edge version from GitHub. That worked, as far as I can tell.
Actually had to compile buffer twice in order to get past the TRANSFER error (not sure why that even works?) but the system appears to be hung waiting for some kind of network connection. Perhaps you could give us a usage hint?
Cheers,
- DM

[Burton Samograd]

As someone pointed out, I used the macro transfer before defining it accidentally. Sorry about, I’ve fixed that in the next version.

—
Burton

Post by David McClain
The call (#<Function TRANSFER 422001358C> #(58 EF D8 12 7C 50 5F 84 C4 53 B3 DE EB 5E 5 8 CB E2 ED B7 D2 75 7C 34 1D DD 8 6 C0 74 8B 5F B3 13 91 D3 BD A7 FB E4 ...) #(5F 80 7 5C C6 4E 24 BE 27
EA EB DE 93 B5 92 E5 27 FF BF 37 40 90 63 D0 F5 38 D5 0 DA 6E 15 62 FA B5 CC 5 84 CC C5 A5 ...) 1) does not match definition (#<Function TRANSFER 422001358C> FROM TO VALUE).
Debugger points to MINE. Happens during COMPILE-FILE.
- DM

Post by Burton Samograd
(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)))))
Also redefines BLOCK and so we probably need to declare shadowing at the top.
Not sure what the quickload stuff was trying to accomplish, but my resident version of Ironclad kept shadowing anything imported by quickload. No SHA3 digest in my resident version, so I replaced it (for now) with the bleeding edge version from GitHub. That worked, as far as I can tell.
Actually had to compile buffer twice in order to get past the TRANSFER error (not sure why that even works?) but the system appears to be hung waiting for some kind of network connection. Perhaps you could give us a usage hint?
Cheers,
- DM

[Burton Samograd]

Post by Burton Samograd
(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)))))
Also redefines BLOCK and so we probably need to declare shadowing at the top.

My bad, totally slipped my mind.

I’ll rename that to resolve the conflict in the next version.

Post by Burton Samograd
Not sure what the quickload stuff was trying to accomplish, but my resident version of Ironclad kept shadowing anything imported by quickload. No SHA3 digest in my resident version, so I replaced it (for now) with the bleeding edge version from GitHub. That worked, as far as I can tell.

Yes, I tend to use the most recent versions of your library, but given it’s crypto library it might be good you upgraded.

Post by Burton Samograd
Actually had to compile buffer twice in order to get past the TRANSFER error (not sure why that even works?) but the system appears to be hung waiting for some kind of network connection. Perhaps you could give us a usage hint?

My mistake on not doing a clean compile before releasing; most of this was made interactively and I haven’t gotten around to writing a full app target in my LW.

Thanks for the feedback.

Post by Burton Samograd
Cheers,

--
Burton Samograd

Post by Burton Samograd
- DM

[Scott McKay]

Ha ha ha, awesome!

Post by Burton Samograd
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.