; YourDSL - Can you evaluate this S-expr?
; ------------------------------
; The Little Lisper 3rd Edition
; Chapter 10
; Exercise 1
; Common Lisp
; http://t...content-available-to-author-only...r.com/thelittlelisper
; http://t...content-available-to-author-only...t.com/2010/06/little-lisper-chapter-10-what-is-value.html
; http://t...content-available-to-author-only...t.com/2010/06/little-lisper.html
; ------------------------------

(defun first_ (l)
  (cond
   ((null l) '())
   (t (car l))))

(defun second_ (l)
  (cond
   ((null l) '())
   (t (car (cdr l)))))


(defun build (a b)
  (cons a (cons b '())))

(setf e4
     '(3 (quote a)(quote b)))

(defun *self-evaluating (e table)
  e)
          
(defun atom-to-action (e)
  (cond
   ((numberp e) '*self-evaluating)
   (t '*identifier)))

(defun list-to-action (e)
  (cond
   ((atom (car e))
    (cond
     ((eq (car e) (quote quote))
      '*quote)
     ((eq (car e) (quote lambda))
      '*lambda)
     ((eq (car e) (quote cond))
      '*cond)
     (t '*application)))
   (t '*application)))
                
(defun expression-to-action (e)
  (cond
   ((atom e) (atom-to-action e))
   (t (list-to-action e))))
          
(defun meaning (e table)
  (funcall (expression-to-action e) e table))
     
(defun value_ (e)
  (meaning e (quote ())))

(defun *quote (e table)
      (text-of-quotation e))

(defun text-of-quotation (l) 
  (second_ l))

(defun *identifier (e table)
  (lookup-in-table
   e table 'initial-table))

(defun initial-table (name)
  (cond
   ((eq name (quote t)) t)
   ((eq name (quote nil)) nil)
  (t (build 
      (quote primitive)
      name))))

(defun lookup-in-table (name table table-f)
  (cond
   ((null table) (funcall table-f name))
   (t (lookup-in-entry
       name
       (car table)
       (lambda (name)
         (lookup-in-table
          name
          (cdr table)
          table-f))))))

(defun lookup-in-entry (name entry entry-f)
  (lookup-in-entry-help
   name
   (first_ entry)
   (second_ entry)
   entry-f))

(defun lookup-in-entry-help (name names values entry-f)
  (cond
   ((null names) (funcall entry-f name))
   ((eq (car names) name)
   (car values))
  (t (lookup-in-entry-help
      name
      (cdr names)
      (cdr values)
      entry-f))))

(defun *application (e table)
  (apply_
   (meaning (function-of e) table)
   (evlis (arguments-of e) table)))

(defun evcon (lines table)
  (cond
   ((meaning
     (question-of (car lines)) table)
    (meaning
     (answer-of (car lines)) table))
   (t (evcon (cdr lines) table))))

(defun question-of (l)
  (first_ l))
    
(defun answer-of (l)
  (second_ l))

(defun *cond (e table)
  (evcon (cond-lines e) table))

(defun cond-lines (l) 
  (cdr l))


(defun apply_ (fun vals)
  (cond
   ((primitive? fun)
    (apply-primitive
     (second_ fun) vals))
   ((non-primitive? fun)
    (apply-closure
     (second_ fun) vals))))

(defun primitive? (l)
  (eq
   (first_ l)
   (quote primitive)))

(defun non-primitive? (l)
  (eq
   (first_ l)
   (quote non-primitive)))

(defun add1 (n)
  (+ 1 n))

(defun apply-primitive (name vals)
  (cond
   ((eq name (quote car))
    (car (first_ vals)))
   ((eq name (quote cdr))
    (cdr (first_ vals)))
   ((eq name (quote cons))
    (cons (first_ vals) (second_ vals)))
   ((eq name (quote eq))
    (eq (first_ vals) (second_ vals)))
   ((eq name (quote atom))
    (atom (first_ vals) ))   
   ((eq name (quote not))
    (not (first_ vals) ))   
   ((eq name (quote null))
    (null (first_ vals) ))   
   ((eq name (quote number))
    (numberp (first_ vals) ))   
   ((eq name (quote zero))
    (zero (first_ vals) ))      
   ((eq name (quote add1))
    (add1 (first_ vals) ) )  
   ((eq name (quote sub1))
    (sub1 (first_ vals) )) ))

(defun function-of (l) 
  (car l))

(defun arguments-of (l) 
  (cdr l))

(defun evlis (args table)
  (cond
   ((null args) (quote ()))
   (t (cons (meaning (car args) table)
            (evlis (cdr args) table)))))

(defun apply-closure (closure vals)
  (meaning (body-of closure)
           (extend-table
            (new-entry
             (formals-of closure) vals)
            (table-of closure))))

(defun body-of (l)
  (third l))

(defun extend-table (a b)
  (cons a b))

(defun new-entry (a b)
  (build a b))

(defun formals-of (l)
  (second_ l))

(defun table-of (l)
  (first_ l))

(defun *lambda (e table)
  (build (quote non-primitive)
         (cons table (cdr e))))
    
; ------------------------------
;truth values
(print (value_ '(eq 1 1)))
; T

(print (value_ '(eq 1 2)))
; NIL false

;truth values
(print (value_ '(cond ((eq 1 2) 'non-normality) (t 'normality))))
; NORMALITY

;numbers
(print (value_ '23))
; 23

;quoted s-expression
(print (value_ '(add1 1)))
; 2