golomb-forest-eval.lisp

;Lisp in Lisp in Golomb forests.  Includes use of linked lists.
;Based on Paul Graham's version of McCarthy's paper and code.
;Uses only eq, cond, atom, quote, cons, car, and cdr.

(defun null. (x)
  (eq x '()))

(defun and. (x y)
  (cond (x 
	 (cond (y 't)
	       ('t '())))
        ('t '())))

(defun or. (x y)
  (cond (x 't)
	(y 't)
	('t '())))

(defun plus1. (lst)
  (cond ((null. lst) (cons '1 '()))
	((eq (car lst) '1)
	 (cons '0 (plus1. (cdr lst))))
	('t (cons '1 (cdr lst)))))

(defun minus1. (lst)
  (cond ((null. lst) '())
	((and. (null. (cdr lst)) (eq (car lst) '1)) '())
	((eq (car lst) '0)
	 (cons '1 (minus1. (cdr lst))))
	((eq (car lst) '1) (cons '0 (cdr lst)))))

(defun +. (lst1 lst2)
  (cond ((null. lst2) lst1)
	('t (+. (plus1.   lst1) (minus1. lst2)))))

(defun -. (lst1 lst2)
  (cond ((null. lst2) lst1)
	('t (-. (minus1. lst1) (minus1. lst2)))))

(defun ash+. (lst1 lst2)
  (cond ((null. lst2) lst1)
	('t (ash+. (cons '0 lst1) (minus1. lst2)))))

(defun >. (lst1 lst2)
  (cond ((and. (null. lst2) (null. lst1)) '())
	((null. lst2) 't)
	((null. lst1) '())
	('t (>. (minus1. lst1) (minus1. lst2)))))

(defun eqnum. (lst1 lst2)
  (cond ((and. (null. lst1) (null. lst2)) 't)
	((eq (car lst1) (car lst2))
	 (eqnum. (cdr lst1) (cdr lst2)))
	('t '())))

(defun fullness. (tree size)
  (cond ((null. size)
	 '(1))
	((null. (cdr tree))
	     (fullness. (car tree) (minus1. size)))
	('t (+. (ash+. '(1) (minus1. size))  (fullness. (cdr tree) (minus1. size))))))

(defun length. (glf size)
  (cond ((null. glf) '())
	((or. (null. (cdr glf))
	     (eq 'sen2 (cdr glf)))
	 (minus1. (+. (ash+. '(1) size)
		     (+. (fullness. (car glf) size)
			 (cond ((eq '() (cdr glf))
				'())
			       ('t '(1)))))))
	('t (length. (cdr glf) (plus1. size)))))

(defun tree-nth. (number tree size)
  (cond ((null. size)
	 tree)
	((>. (ash+. '(1) (minus1. size)) number)
	 (tree-nth. number (car tree) (minus1. size)))
	('t (tree-nth. (-. number (ash+. '(1) (minus1. size))) (cdr tree) (minus1. size)))))

(defun g-nth. (x glf size)
  (cond ((>. (minus1. (ash+. '(0 1) size)) x)
	 (tree-nth. (-. x (minus1. (ash+. '(1) size))) (car glf) size))
	('t (g-nth. x (cdr glf) (plus1. size)))))

(defun tree-add. (elt tree size number)
  (cond ((null. size)
	 elt)
	((>. (ash+. '(1) (minus1. size)) number)
	 (cons (tree-add. elt (car tree) (minus1. size) number) '()))
	('t (cons (car tree) (tree-add. elt (cdr tree) (minus1. size) (-. number (ash+. '(1) (minus1. size))))))))

(defun sentinel-change. (glf)
  (cond ((null. (cdr glf))
	 (cons (car glf) 'sen2))
	('t (cons (car glf) (sentinel-change. (cdr glf))))))

(defun g-add. (elt glf size number)
  (cond ((eq 'sen2 glf)
	 (cons (tree-add. elt '() size '()) '()))
	((and. (eq '0 (car number)) (null. elt))
	 (sentinel-change. glf))
	((>. (-. (ash+. '(0 1) size) '(1)) number)
	 (cons (tree-add. elt (car glf) size (-. number (-. (ash+. '(1) size) '(1)))) '()))
	('t (cons (car glf) (g-add. elt (cdr glf) (plus1. size) number)))))

(defun assoc. (atom a x)
  (cond ((eq atom (car (g-nth. x a '())))
	 (cdr (g-nth. x a '())))
	('t (assoc. atom a (minus1. x)))))

(defun append. (glf1 glf2 x)
  (cond ((eqnum. x (length. glf2 '()))
	 glf1)
	('t (append. (g-add. (g-nth. x glf2 '()) glf1 '() (length. glf1 '())) glf2 (plus1. x)))))

(defun pair. (glf1 glf2 glf3 x)
  (cond ((eqnum. x (length. glf2 '()))
	 glf1)
	('t (pair. (g-add. (cons (g-nth. x glf2 '()) (g-nth. x glf3 '())) glf1 '() (length. glf1 '())) 
		   glf2 glf3 (plus1. x)))))

(defun eval. (e a)
  (cond
    ((atom e) (assoc. e a (minus1. (length. a '()))))
    ((atom (car e))
     (cond
       ((eq (car e) 'quote) (caadr e))
       ((eq (car e) 'atom)  (atom   (eval. (caadr e) a)))
       ((eq (car e) 'eq)    (eq     (eval. (caadr e) a)  
                                    (eval. (cdadr e) a)))
       ((eq (car e) 'car)   (car    (eval. (caadr e) a)))
       ((eq (car e) 'cdr)   (cdr    (eval. (caadr e) a)))
       ((eq (car e) 'cons)  (cons   (eval. (caadr e) a)
                                    (eval. (cdadr e) a)))
       ((eq (car e) 'cond)  (evcon. (cdr e) a '()))
       ('t (eval. (cons (assoc. (car e) a (minus1. (length. a '())))
                        (cdr e)) a))))
    ((eq (caar e) 'label)
     (eval. (cons (cdadar e) (cdr e))
	    (g-add. (cons (caadar e) (car e)) a '() (length. a '()))))
    ((eq (caar e) 'lambda)
     (eval. (cdadar e)
            (append. a (pair. '() (caadar e) (evlis. (append. '() e '(1)) a '()) '()) '())))))

(defun evcon. (glf a x)
  (cond ((eval. (car (g-nth. x glf '())) a) (eval. (cdr (g-nth. x glf '())) a))
	('t (evcon. glf a (plus1. x)))))

(defun evlis. (glf a x)
  (cond ((eqnum. x (length. glf '()))
	 '())
	('t (append. (cons (eval. (g-nth. x glf '()) a) '()) (evlis. glf a (plus1. x)) '()))))