;--------------------- cs480/680 :: tkprasad@cs.wright.edu-------------

;----------------------------------------------------------------------
;--------- Code for the Scheme interpreter adapted from Chapter 10 ----
;-- of The Little Schemer/LISPer ("shortened" to improve readability) --
;----------------------------------------------------------------------

;Uncomment the following for an interpreter different from MIT Scheme
;(define first car)
;(define second cadr)
;(define third caddr)
;(define fourth cadddr)

;------------------------Symbol Table/Activation Record-------------------

(define (initial-table name)
     (case  name
       ( (t )  #t)
       ( (nil) #f)
       ( else  (list 'primitive name )) ))

(define (lookup-in-entry  name  entry  entry-f)
        (lookup-in-entry-help
                  name (first entry) (second entry) entry-f)  )

(define (lookup-in-entry-help  name  names  values  entry-f)
     (cond
        ( (null? names) (entry-f name) )
        ( (eq? name (car names)) (car values))          
        (else (lookup-in-entry-help 
                  name (cdr names) (cdr values) entry-f ) ) ))

(define (lookup-in-table name table table-f)
     ( if (null? table) (table-f name)
         (lookup-in-entry 
              name (car table) (lambda (name)
                                       (lookup-in-table
                                           name (cdr table) table-f))) ))

;-------Interpreter Top-level : Parser -> Abstract code-generator-----------

(define (value e) (meaning e '()) )

(define (meaning  e table)
      ( cond 
         ((number? e)    (*self-evaluating  e table))
         ((symbol? e)    (*identifier       e table))
         (else 
          (case (car e) 
             ( (quote)   (*quote            e table) )
             ( (lambda)  (*lambda           e table) )
             ( (cond)    (*cond             e table) )
             (  else     (*application      e table) )))
      ))


;;;; -----------expression_to_action absorbed--------------

(define (*self-evaluating e table) e)

(define (*identifier e table)
     (lookup-in-table e table initial-table))

(define (*quote e table) (second e) )     

(define (*lambda e table)
      (list 'non-primitive (cons table (cdr e))) )

;;;; ------closure created: [CREATION-ENV-TABLE, FORMALS, BODY]----

(define question-of first)
(define answer-of   second)

(define (evcon lines table)
        (if (meaning (question-of (car lines))   table)
            (meaning (answer-of   (car lines))   table)
            (evcon  (cdr lines)   table) ))

;;;;------ conditions must be exhaustive -------

(define cond-lines cdr)

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

(define (evlis args table)
        (if (null? args) 
            ()
            (cons (meaning (car args) table) (evlis (cdr args) table)) ))

(define function-of car) 
(define arguments-of cdr)

(define (*application e table)
        (apply  (meaning (function-of e) table)
                (evlis (arguments-of e) table) ))

(define (primitive? l)      (eq? (first l) 'primitive) )

(define (non-primitive? l)  (eq? (first l) 'non-primitive) )

(define (apply fun vals)
       (cond
          ( (primitive? fun)     (apply-primitive (second fun) vals))
          ( (non-primitive? fun) (apply-closure   (second fun) vals))
       ) )


(define (atom? a) (or (number? a) (symbol? a))) 

(define (apply-primitive name vals)
        (case  name
           ( (car)     (car     (first vals)))
           ( (cdr)     (cdr     (first vals)))
           ( (cons)    (cons    (first vals) (second vals)))
           ( (eq?)     (eq?     (first vals) (second vals)))
           ( (atom?)   (atom?   (first vals)))
           ( (not)     (not     (first vals)))
           ( (null?)   (null?   (first vals)))
           ( (number?) (number? (first vals)))
           ( (zero?)   (zero?   (first vals)))
           ( (add1)    (+       (first vals)     1))
           ( (sub1)    (-       (first vals)     1))
        ))

(define new-entry list)
(define extend-table cons)

(define table-of   first)
(define formals-of second)
(define body-of    third)

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


;;;;;;;;;;;;;;;;;;;;;;;;;;TEST CASES;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define test0 
           '((lambda (x) 
                    ((lambda (x) (add1 x)) 
                         (add1 4))) 
                  6))

(value test0)

(define check0 
           ((lambda (x) 
                    ((lambda (x) (+ 1 x)) 
                         (+ 1 4))) 
                  6))

(define test1 
           '((lambda (x) 
                (cond  
                     ((atom? x) (quote done))
                     ((null? x) (quote almost))
                     (t         (quote never))
                ) )
              (quote ())
             ))

(value test1)

(define check1
            ((lambda (x) 
                (cond  
                     ((atom? x) (quote done))
                     ((null? x) (quote almost))
                     (else      (quote never))
                ) )
              ()
             ))


(value '( ( (lambda (x y)   (lambda () (cond (t x))))
                     7 0)))

(define test2
           '((lambda (x y)  (lambda (u) (cond (u x) (t y))))
                      7 0 ))


(value test2)

(value (list test2 't))

(value (list test2 'nil))

(define check2
           ((lambda (x y) (lambda (u) (if u  x y)) )
                     7 0 ))

(check2  #t)

(check2  #f)

(define test3
           '((lambda (x y) (cond (u x) (t y)))
                     (quote a)  nil ))

(value test3)

;(value '())      ;;; ILLEGAL INPUT PROGRAM/EXPRESSION BY DESIGN ;;;