BusFactor1Inc · April 16, 2021 16:37 · Dec 19, 2017 · Dec 19, 2017 · Dec 19, 2017
diff --git a/lispchain.lisp b/lispchain.lisp
@@ -7,6 +7,8 @@
 ;;
 ;; Interested in helping out with the code? Email me.
 ;;
+;; Bitcoin: 1HzWXjoQjzdLBm1eKeuWFrZx96kiop5GGy
+;;
 
 (load "~/quicklisp/setup.lisp")
 

diff --git a/lispchain.lisp b/lispchain.lisp
@@ -140,7 +140,7 @@
 ;;;;;; and there we have a scheme interpreter with macros. ;;;;;;;;;;;;;;;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(defstruct %lisp
+(defstruct lisp
   (index 0) (timestamp 0) data (previous-hash "") hash)
 
 (defstruct transaction 

diff --git a/lispchain.lisp b/lispchain.lisp
@@ -0,0 +1,347 @@
+;;
+;; scheme coin - a lispchain (aka blockchain) implementation
+;;
+;; Burton Samograd
+;; burton.samograd@gmail.com
+;; Copyright - 2017
+;;
+;; Interested in helping out with the code? Email me.
+;;
+
+(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 %lisp
+  (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-lisp (lisp)
+  (let ((digester (ironclad:make-digest :sha3)))
+    (ironclad:update-digest digester
+                            (to-byte-array (lisp-index lisp)))
+    (ironclad:update-digest digester
+                            (to-byte-array (lisp-timestamp lisp)))
+    (ironclad:update-digest digester
+                            (to-byte-array (lisp-data lisp)))
+    (ironclad:update-digest digester
+                            (to-byte-array (lisp-previous-hash lisp)))
+    (ironclad:produce-digest digester)))
+
+(defun hash-transaction (lisp)
+  (let ((digester (ironclad:make-digest :sha3)))
+    (ironclad:update-digest digester
+                            (to-byte-array (transaction-from lisp)))
+    (ironclad:update-digest digester
+                            (to-byte-array (transaction-to lisp)))
+    (ironclad:update-digest digester
+                            (to-byte-array (transaction-value lisp)))
+    (ironclad:update-digest digester
+                            (to-byte-array (transaction-accuracy lisp)))
+    (ironclad:update-digest digester
+                            (to-byte-array (transaction-duration lisp)))
+    (ironclad:update-digest digester
+                            (to-byte-array (transaction-data lisp)))
+    (ironclad:produce-digest digester)))
+
+(defun make-genesis-lisp (data time)
+  (let* ((lisp (make-lisp 
+                 :index 0
+                 :timestamp time
+                 :data data
+                 :hash 0))
+         (hash (hash-lisp lisp)))
+    (setf (lisp-hash lisp) hash)
+    lisp))
+
+(defmacro create-genesis-lisp (data)
+  `(let ((time (get-universal-time)))
+     (make-genesis-lisp ,data time)))
+
+(defun next-lisp (last-lisp data)
+  (let ((lisp (make-lisp :index (1+ (lisp-index last-lisp))
+                           :timestamp (get-universal-time)
+                           :data data
+                           :previous-hash (hash-lisp last-lisp))))
+    (setf (lisp-hash lisp) (hash-lisp lisp))
+    (push  lisp *lispchain*)
+    lisp))
+
+(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 *lisp-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 *lispchain* 
+  (list (create-genesis-lisp *lisp-transactions*)))
+
+(defparameter *previous-lisp* (car *lispchain*))
+
+(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)
+         *lisp-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)
+       (<= (lisp-index (car *lispchain*))
+           (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 *lisp-transactions*)
+    (when (viable-transaction transaction)
+      (print :submitting-answer)
+      (submit-answer miner-address transaction     
+                     (verify-transaction transaction))
+      )))
+
+(defmacro transfer (from to value)
+  `(push (new-transaction :from ,from :to ,to
+                          :value ,value)
+         *lisp-transactions*))
+
+(defmacro execute (from value code &key (accuracy value) 
+                        (duration (+ 2 (lisp-index (car *lispchain*)))))
+  `(push (new-transaction :from ,from :to *contract-address*
+                          :value ,value
+                          :accuracy ,accuracy :data ',code 
+                          :duration ,duration)
+         *lisp-transactions*))
+
+(defun mine ()
+  (when *lisp-transactions*
+    (execute-transactions *miner-address*)
+    (transfer *network-address* *miner-address* 1)
+    (setf *previous-lisp* 
+          (next-lisp *previous-lisp* *lisp-transactions*))
+    (setf *lisp-transactions* nil)))
+
+(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 (lisp-index (car *lispchain*))))) 
+        request
+      (execute from value data :accuracy accuracy :duration duration)))
+
+(defun process-lisps-request (request stream)
+  (print *lispchain* 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))
+      (lisps (process-lisps-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))
No results found