;; see roots_of_lisp

;; 1. seven primitive operators:
;; (quote x)
;; (atom x)
;; (eq x y)
;; (car x)
;; (cdr x)
;; (cons x y)
;; (cond (p1 e2) ... (pn en))

;; ======================================================================
;; 2. denoting functions
;; TODO?

;; ======================================================================
;; 3. some functions

;; 1. (null. x) tests whether its argument is the empty list.
;; ? (null. 'a) => ()
;; ? (null. '()) => t

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

;; 2. (and. x y) returns t if both its arguments do and () otherwise.
;; ? (and. (atom 'a) (eq 'a 'a)) => t
;; ? (and. (atom 'a) (eq 'a 'b)) => ()

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

;; 3. (not. x) returns t if its argument returns (), and () if its argument
;;    returns t.
;; ? (not (eq 'a 'a)) => ()
;; ? (not (eq 'a 'b)) => t

(defun not. (x)
  (cond (x '())
        ('t 't)))

;; 4. (append. x y) takes two lists and returns their concatenation.
;; ? (append. '(a b) '(c d)) => (a b c d)
;; ? (append. '() '(c d)) => (c d)

(defun append. (x y)
  (cond ((null. x) y)
        ('t (cons (car x) (append. (cdr x) y)))))

;; 5. (pair. x y) takes two lists of the same length and returns a list of two
;;    element lists containing successive pairs of an element from each.
;; ? (pair. '(x y z) '(a b c)) => ((x a) (y b) (z c))

(defun pair. (x y)
  (cond ((and. (null. x) (null. y)) '())
        ((and. (not. (atom x)) (not. (atom y)))
         (cons (list (car x) (car y))
               (pair. (cdr x) (cdr y))))))

;; 6. (assoc. x y) takes an atom x and a list y of the form created by pair.,
;;    and returns the second element of the first list in y whose first
;;    element is x.
;; ? (assoc. 'x '((x a) (y b))) => a
;; ? (assoc. 'x '((x new) (x a) (y b))) => new

(defun assoc. (x y)
  (cond ((eq (caar y) x) (cadar y))
        ('t (assoc. x (cdr y)))))

;; ======================================================================
;; 4. the surprise

(defun eval. (e a)
  (cond
   ((atom e) (assoc. e a))
   ((atom (car e))
    (cond
     ((eq (car e) 'quote) (cadr e))
     ((eq (car e) 'atom) (atom (eval. (cadr e) a)))
     ((eq (car e) 'eq) (eq (eval. (cadr e) a)
                           (eval. (caddr e) a)))
     ((eq (car e) 'car) (car (eval. (cadr e) a)))
     ((eq (car e) 'cdr) (cdr (eval. (cadr e) a)))
     ((eq (car e) 'cons) (cons (eval. (cadr e) a)
                               (eval. (caddr e) a)))
     ((eq (car e) 'cond) (evcon. (cdr e) a))
     ('t (eval. (cons (assoc. (car e) a)
                      (cdr e))
                a))))
   ((eq (caar e) 'label)
    (eval. (cons (caddar e) (cdr e))
           (cons (list (cadar e) (car e)) a)))
   ((eq (caar e) 'lambda)
    (eval. (caddar e)
           (append. (pair. (cadar e) (evlis. (cdr e) a))
                    a)))))

(defun evcon. (c a)
  (cond ((eval. (caar c) a)
         (eval. (cadar c) a)) ('t (evcon. (cdr c) a))))

(defun evlis. (m a)
  (cond ((null. m) '())
        ('t (cons (eval. (car m) a)
                  (evlis. (cdr m) a)))))