A Nock Interpreter and Compiler in Common Lisp #Urbit

nock.lisp

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; nock.lisp - The Interpretation and Compilation of Nock Programs.
;;
;; Nock is the Maxwell's Equations of Software. It is a language that
;; powers the Urbit virtual machine; its specification can fit on a 
;; t-shirt[1].  
;;
;; In this set of Common Lisp functions below are 'tar', 
;; a Nock interpreter, 'dao', a Nock compiler and 'phi',
;; a Nock compiler driver.
;; 
;; Usage:
;;
;; (tar code) ;; interpret Nock code
;; (phi code) ;; compile and run Nock code
;;
;; See the source of 'phi' below for an example using
;; 'dao' as a compiler and running the resulting code.
;;
;; Code Format:
;;
;; Assuming the following Hoon code for the function 'dec' running 
;; 100,000,000 times:
;;
;; > !=  %-  =+  n=0  |=  [a=@ud]  ?:  =(+(n) a)  n  $(n  +(n))  100.000.000
;;
;; The following code format is accepted:
;;
;; (setq code '(8 (8 (1 . 0) 8 (1 . 0) (1 6 (5 (4 0 . 14) 0 . 6) (0 . 14) 9 2 
;;             (0 . 2) (0 . 6) (4 0 . 14) 0 . 15) 0 . 1) 9 2 (0 . 4) (7 (0 . 3) 
;;             1 . 100000000) 0 . 11)))
;;
;; Note: the use of dotted lists to match with the Nock concept of a list.
;;
;; LICENSE: AGPL
;;
;; BusFactor1 Inc. - 2017
;; http://busfactor1.ca/
;; [email protected]

#|
;; Running (dec 100.000.000)...
CL-USER> (time (tar 0 '(8 (8 (1 . 0) 8 (1 . 0) (1 6 (5 (4 0 . 14) 0 . 6) (0 . 14) 9 2 (0 . 2) (0 . 6) (4 0 . 14) 0 . 15) 0 . 1) 9 2 (0 . 4) (7 (0 . 3) 1 . 100000000) 0 . 11)))
Evaluation took:
  154.804 seconds of real time
  154.191088 seconds of total run time (151.147045 user, 3.044043 system)
  [ Run times consist of 4.769 seconds GC time, and 149.423 seconds non-GC time. ]
  99.60% CPU
  433,556,434,319 processor cycles
  195,199,995,456 bytes consed

99999999
CL-USER> (time (funcall (phi '(8 (8 (1 . 0) 8 (1 . 0) (1 6 (5 (4 0 . 14) 0 . 6) (0 . 14) 9 2 (0 . 2) (0 . 6) (4 0 . 14) 0 . 15) 0 . 1) 9 2 (0 . 4) (7 (0 . 3) 1 . 100000000) 0 . 11)) 0))
Evaluation took:
  2.575 seconds of real time
  2.563883 seconds of total run time (2.488210 user, 0.075673 system)
  [ Run times consist of 0.093 seconds GC time, and 2.471 seconds non-GC time. ]
  99.57% CPU
  7,212,489,149 processor cycles
  4,800,019,808 bytes consed

99999999
|#

;; A nock interpreter
(defun tar (a f)
  (labels ((fas (b a)
	     (declare (integer b))
	     (cond
               ((= b 1) a)
               ((= b 2) (car a))
               ((= b 3) (cdr a))
               ((evenp b) (car (fas (/ b 2) a)))
               ((oddp b) (cdr (fas (/ (1- (the integer b)) 2) a))))))
    
        (if (consp (car f))
            (cons
             (tar a (car f))
             (tar a (cdr f)))
          (case (car f)
                (0 (let ((b (cdr f)))
                     (fas b a)))
                (1 (cdr f))
                (2 (let ((b (cadr f))
                         (c (cddr f)))
		     (let ((x (tar a b))
			   (y (tar a c)))
		       (tar x y))))
                (3 (let ((b (cdr f)))
		     (let ((x (tar a b)))
		       (if (consp x) 0 1))))
                (4 (let ((b (cdr f)))
		     (let ((x (tar a b)))
		       (1+ (the integer x)))))
                (5 (let ((b (cdr f)))
		     (let ((x (tar a b)))
		       (if (= (the integer (car x)) (the integer (cdr x))) 0 1))))
		(6 (let ((b (cadr f))
			 (c (caddr f))
			 (d (cdddr f)))
		     (tar a `(2 (0 . 1) 2 (1 ,c . ,d) (1 . 0) 2
			      (1 2 . 3) (1 . 0) 4 4 . ,b))))
		(7 (let ((b (cadr f))
			 (c (cddr f)))
		     (tar a `(2 ,b 1 . ,c))))
		(8 (let ((b (cadr f))
			 (c (cddr f)))
		     (tar a `(7 ((7 (0 . 1) . ,b) 0 . 1) . ,c))))
		(9 (let ((b (cadr f))
			 (c (cddr f)))
		     (tar a `(7 ,c 2 (0 . 1) 0 . ,b))))
		))))

;; A nock compiler
(defun dao (f)
  (declare (inline cons car cdr 1+))
  (labels
      ((fas (b)
	 (declare (integer b))
	 (cond
	   ((= b 1) 'a)
	   ((= b 2) '(car a))
	   ((= b 3) '(cdr a))
	   ((evenp b) `(car ,(fas (/ b 2))))
	   ((oddp b)
	    `(cdr ,(fas (/ (1- b) 2)))))))
    (declare (inline fas))
    (if (or (integerp f)
	    (symbolp f))
	f
	(if (consp (car f))
	    (let ((m (dao (car f)))
		  (n (dao (cdr f))))
	      `(cons ,m ,n))
	    (case (car f)
	      (0 (fas (cdr f)))
	      (1 (if (or (integerp (cdr f))
			 (symbolp (cdr f)))
		     (cdr f)
		     `',(cdr f)))
	      (2 (let ((bc (dao (cadr f)))
		       (d (dao (cddr f))))
		   (if (eq (car d) 'quote)
		       (let ((x (dao (cadr d))))
			 (if (or (eq bc 'a)
				 (integerp x))
			     x
			     `(let ((a ,bc))
				,x)))
		       `(funcall (the function (phi ,d a)) ,bc))))
	      (3 `(if (consp ,(dao (cdr f))) 0 1))
	      (4 `(1+ (the integer ,(dao (cdr f)))))
	      (5 (destructuring-bind (m . n) (cdr f)
		   `(if (= ,(dao m) ,(dao n)) 0 1)))
	      (6 (let ((b (dao (cadr f)))
		       (c (dao (caddr f)))
		       (d (dao (cdddr f))))
		   `(if (= (the integer ,b) 0)
			,c ,d)))
	      (7 (let ((b (dao (cadr f)))
		       (c (dao (cddr f))))
		   `(flet ((f (a) ,b)
			   (g (a) ,c))
		      (declare (inline f g))
		      (g (f a)))))
	      (8 (let ((b (dao (cadr f)))
		       (c (dao (cddr f))))
		   `(let ((a (cons ,b a)))
		      ,c)))
	      (9
	       (let ((b (dao (cadr f)))
		     (c (dao (cddr f))))
		 `(flet ((f (a) ,c))
		    (declare (inline f))
		    (let ((x (f a)))
		      (funcall (the function
				    (phi (let ((a x))
					    ,(fas b)))) x))))))
	      ))))

;; A nock compiler driver
(defparameter cache (make-hash-table :test #'equal))
(defun phi (f &optional a)
  (let ((compiled (gethash f cache)))
    (if compiled
	compiled
	(let ((code `(lambda (a)
		       (declare (optimize (speed 3) (safety 0)))
		       ,(dao f))))
	  (print code)
	  (setf (gethash f cache) (compile nil code))))))
;;
;; [1] The Nock specification is as follows:
;;
;; 1 Structures
;;
;;  A noun is an atom or a cell.  An atom is any natural number.  
;;  A cell is an ordered pair of nouns.
;;
;; 2 Reductions
;;
;;  nock(a)           *a
;;  [a b c]           [a [b c]]
;;
;;  ?[a b]            0
;;  ?a                1
;;  +a                1 + a
;;  =[a a]            0
;;  =[a b]            1
;;
;;  /[1 a]            a
;;  /[2 a b]          a
;;  /[3 a b]          b
;;  /[(a + a) b]      /[2 /[a b]]
;;  /[(a + a + 1) b]  /[3 /[a b]]
;;
;;  *[a [b c] d]      [*[a b c] *[a d]]
;;
;;  *[a 0 b]          /[b a]
;;  *[a 1 b]          b
;;  *[a 2 b c]        *[*[a b] *[a c]]
;;  *[a 3 b]          ?*[a b]
;;  *[a 4 b]          +*[a b]
;;  *[a 5 b]          =*[a b]
;;
;;  *[a 6 b c d]      *[a 2 [0 1] 2 [1 c d] [1 0] 2 [1 2 3] [1 0] 4 4 b]
;;  *[a 7 b c]        *[a 2 b 1 c]
;;  *[a 8 b c]        *[a 7 [[7 [0 1] b] 0 1] c]
;;  *[a 9 b c]        *[a 7 c 2 [0 1] 0 b]
;;  *[a 10 b c]       *[a c]
;;  *[a 10 [b c] d]   *[a 8 c 7 [0 2] d]
;;
;;  +[a b]            +[a b]
;;  =a                =a
;;  /a                /a
;;  *a                *a