;;  (April 5, 2000, Lecture 17 Evaluator revised by ARM to run itself)

;;META-CIRCULAR EVALUATOR

(define (m-eval expr env)
  (cond ((self-evaluating? expr) expr)
        ((variable? expr) (lookup-variable-value expr env))    
        ((quoted? expr) (text-of-quotation expr))
        ((assignment? expr) (eval-assignment expr env))
        ((definition? expr) (eval-definition expr env))
        ((if? expr) (eval-if expr env))
        ((lambda? expr)
         (make-procedure (lambda-parameters expr) (lambda-body expr) env))
        ((begin? expr) (eval-sequence (begin-actions expr) env))
        ((cond? expr) (m-eval (cond->if expr) env))
	((let? expr) (m-eval (let->combination expr) env))
        ((application? expr)
         (m-apply (m-eval (operator expr) env)
                (list-of-values (operands expr) env)))
        (else (error "Unknown expression type -- M-EVAL" expr))))

(define (m-apply procedure arguments)
  (cond ((primitive-procedure? procedure)
         (apply-primitive-procedure procedure arguments))
        ((compound-procedure? procedure)
         (eval-sequence
          (procedure-body procedure)
          (extend-environment (procedure-parameters procedure)
                              arguments
                              (procedure-environment procedure))))
        (else (error "Unknown procedure type -- APPLY" procedure))))

(define (list-of-values rands env)
  (cond ((no-operands? rands) '())
        (else (cons (m-eval (first-operand rands) env)
                    (list-of-values (rest-operands rands) env)))))

(define (eval-if expr env)
  (if (m-eval (if-predicate expr) env)
      (m-eval (if-consequent expr) env)
      (m-eval (if-alternative expr) env)))

(define (eval-sequence exprs env)
  (cond ((last-expr? exprs) (m-eval (first-expr exprs) env))
        (else (m-eval (first-expr exprs) env)
              (eval-sequence (rest-exprs exprs) env))))

(define (eval-assignment expr env)
  (set-variable-value! (assignment-variable expr)
                       (m-eval (assignment-value expr) expr)
                       env))

(define (eval-definition expr env)
  (define-variable! (definition-variable expr)
                    (m-eval (definition-value expr) env)
                    env))


;;COMPOUND PROCEDURE ADT

(define (make-procedure parameters body env)
  (list procedure-tag parameters body env))
(define procedure-tag (list 'procedure)) ;REVISED FROM LECTURE
(define (compound-procedure? expr)
  (tagged-list? expr procedure-tag))
(define (procedure-parameters p) (list-ref p 1))
(define (procedure-body p) (list-ref p 2))
(define (procedure-environment p) (list-ref p 3))


;;ENVIRONMENTS

;; Implement environments as a list of frames; parent environment is
;; the cdr of the list.  Each frame will be implemented as a list
;; of variables and a list of corresponding values.
(define (enclosing-environment env) (cdr env))
(define (first-frame env) (car env))
(define the-empty-environment '())

(define (make-frame variables values) (cons variables values))
(define (frame-variables frame) (car frame))
(define (frame-values frame) (cdr frame))
(define (add-binding-to-frame! var val frame)
  (set-car! frame (cons var (car frame)))
  (set-cdr! frame (cons val (cdr frame))))

(define (extend-environment vars vals base-env)
  (if (= (length vars) (length vals))
      (cons (make-frame vars vals) base-env)
      (if (< (length vars) (length vals))
          (error "Too many args supplied" vars vals)
          (error "Too few args supplied" vars vals))))

(define (lookup-variable-value var env)
  (define (env-loop env)
    (define (scan vars vals)
      (cond ((null? vars) (env-loop (enclosing-environment env)))
            ((eq? var (car vars)) (car vals))
            (else (scan (cdr vars) (cdr vals)))))
    (if (eq? env the-empty-environment)
        (error "Unbound variable -- LOOKUP" var)
        (let ((frame (first-frame env)))
          (scan (frame-variables frame) (frame-values frame)))))
  (env-loop env))

(define (set-variable-value! var val env)
  (define (env-loop env)
    (define (scan vars vals)
      (cond ((null? vars) (env-loop (enclosing-environment env)))
            ((eq? var (car vars))
             (set-car! vals val))        ; Same as lookup except for this
            (else (scan (cdr vars) (cdr vals)))))
    (if (eq? env the-empty-environment)
        (error "Unbound variable -- SET!" var)
        (let ((frame (first-frame env)))
          (scan (frame-variables frame) (frame-values frame)))))
  (env-loop env))

(define (define-variable! var val env)
  (let ((frame (first-frame env)))
    (define (scan vars vals)
      (cond ((null? vars) (add-binding-to-frame! var val frame))
            ((eq? var (car vars)) (set-car! vals val))
            (else (scan (cdr vars) (cdr vals)))))
    (scan (frame-variables frame)
          (frame-values frame))))


;;THE INITIAL ENVIRONMENT

(define (setup-environment)
  (let ((initial-env (extend-environment (primitive-procedure-names)
                                         (primitive-procedure-objects)
                                         the-empty-environment)))
    (define-variable! 'true #t initial-env)
    (define-variable! 'false #f initial-env)
    initial-env))

(define primitive-procedures
  (list
   (list 'apply m-apply)		;APPLY IS A SPECIAL PRIMITIVE
   (list 'pair?				;SO IS PAIR?
	 (lambda (x)
	   (if (pair? x)
	       (if (not (eq? (car x) primitive-tag))
		   (not (eq? (car x) procedure-tag))
		   #f) #f)))
   (list 'car car)
   (list 'cdr cdr)
   (list 'cons cons)
   (list 'null? null?)
   (list 'list list)
   (list 'length length)
   (list 'list-ref list-ref)
   (list 'eq? eq?)
   (list 'caar caar)
   (list 'cadr cadr)
   (list 'cdar cdar)
   (list 'cddr cddr)
   (list 'set-car! set-car!)
   (list 'set-cdr! set-cdr!)
   (list 'boolean? boolean?)
   (list 'not not)
   (list 'number? number?)
   (list 'string? string?)
   (list 'symbol? symbol?)
   (list '> >)
   (list '< <)
   (list '= =)
   (list '+ +)
   (list '- -)
   (list '* *)
   (list 'error error)
   (list 'caadr caadr)
   (list 'caddr caddr)
   (list 'cdadr cdadr)
   (list 'cdddr cdddr)
   (list 'cadddr cadddr)
   (list 'read read)
   (list 'newline newline)
   (list 'display display)
; 					; ... more primitives
   ))

(define (primitive-procedure-names) (map car primitive-procedures))
(define primitive-tag (list 'primitive)) ;REVISED FROM LECTURE
(define (primitive-procedure-objects)
  (map (lambda (proc) (list primitive-tag (cadr proc))) primitive-procedures))
(define (apply-primitive-procedure proc args)
  (apply (primitive-implementation proc) args)) ;SCHEME'S APPLY, NOT M-APPLY

(define (primitive-implementation proc) (cadr proc))
(define (primitive-procedure? proc) (tagged-list? proc primitive-tag))

#|   ;DEFINE MAP TO RUN M-EVAL IN ITSELF:
(define (map f l)
  (if (null? l)
      '()
      (cons (f (car l))
	    (map f (cdr l)))))
|#


;(define the-global-environment (setup-environment))


;;THE READ-EVAL-PRINT LOOP

(define (driver-loop)
  (prompt-for-input input-prompt)
  (let ((input (read)))
    (let ((output (m-eval input the-global-environment)))
      (announce-output output-prompt)
      (display output)))        
  (driver-loop))

(define (prompt-for-input string)
  (newline) (newline) (display string) (newline))
(define (announce-output string)
  (newline) (display string) (newline))

(define input-prompt ";;; M-Eval2 input:")
(define output-prompt ";;; M-Eval2 value:")
;Eval2

;;SYNTAX
(define (tagged-list? expr tag)
  (if (pair? expr) (eq? (car expr) tag) #f))
;  (and (pair? expr) (eq? (car expr) tag)))

(define (self-evaluating? expr)
  (cond ((number? expr) #t)
	((string? expr) #t)
	(else (boolean? expr))))
;  (or (number? expr) (string? expr) (boolean? expr)))

(define (quoted? expr) (tagged-list? expr 'quote))
(define (text-of-quotation expr) (cadr expr))

(define (variable? expr) (symbol? expr))
(define (assignment? expr) (tagged-list? expr 'set!))
(define (assignment-variable expr) (cadr expr))
(define (assignment-value expr) (caddr expr))

(define (definition? expr) (tagged-list? expr 'define))
(define (definition-variable expr)
  (if (symbol? (cadr expr))
      (cadr expr)
      (caadr expr)))
(define (definition-value expr)
  (if (symbol? (cadr expr))
      (caddr expr)
      (make-lambda (cdadr expr) (cddr expr))))  ; formal params, body

(define (lambda? expr) (tagged-list? expr 'lambda))
(define (lambda-parameters lambda-expr) (cadr lambda-expr))
(define (lambda-body lambda-expr) (cddr lambda-expr))
(define (make-lambda parms body) (cons 'lambda (cons parms body)))

(define (if? expr) (tagged-list? expr 'if))
(define (if-predicate expr) (cadr expr)) 
(define (if-consequent expr) (caddr expr)) 
(define (if-alternative expr)
  (if (not (null? (cdddr expr))) (cadddr expr) 'false))
(define (make-if pred conseq alt) (list 'if pred conseq alt))

(define (begin? expr) (tagged-list? expr 'begin))
(define (begin-actions begin-expr) (cdr begin-expr))
(define (last-expr? seq) (null? (cdr seq)))
(define (first-expr seq) (car seq))
(define (rest-exprs seq) (cdr seq))
(define (sequence->expr seq)
  (cond ((null? seq) (error "empty sequence")) ;REVISED BY ARM
        ((last-expr? seq) (first-expr seq))
        (else (make-begin seq))))
(define (make-begin exprs) (cons 'begin exprs))

(define (cond? expr) (tagged-list? expr 'cond))
(define (cond-clauses expr) (cdr expr))
(define (clause-predicate clause) (car clause))
(define (clause-expr clause) (sequence->expr (cdr clause)))
(define (make-cond clauses)
  (cons 'cond clauses))

(define (let? expr) (tagged-list? expr 'let))
(define (let-bound-variables expr) (map car (cadr expr)))
(define (let-values expr) (map cadr (cadr expr)))
(define (let-body expr) (cddr expr))	;DIFFERS FROM LECTURE
(define (make-let bindings body)
  (cons 'let (cons bindings body)))

(define (let->combination expr)
  (let ((names (let-bound-variables expr))
	(inits (let-values expr))
	(body (let-body expr)))
    (make-application			;DIFFERS FROM LECTURE
     (make-lambda names body)
     inits)))

(define (application? expr) (pair? expr))
(define (operator app) (car app))
(define (operands app) (cdr app))
(define (no-operands? rands) (null? rands))
(define (first-operand rands) (car rands))
(define (rest-operands rands) (cdr rands))
(define (make-application rator rands)
  (cons rator rands))


;;(set! *unparser-list-depth-limit* 7)
;;(set! *unparser-list-breadth-limit* 10)