;;; Lazy evaluator

(define (eval-scheme exp env)
  (cond ((number? exp)      exp)
        ((symbol? exp)      (lookup exp env))
        ((quoted? exp)      (text-of-quotation exp))
        ((definition? exp)  (eval-definition exp env))
        ((if? exp)          (eval-if exp env))
        ((lambda? exp)      (make-procedure (lambda-parameters exp)
                                            (lambda-body exp) 
                                            env))
        ((begin? exp)       
         (eval-sequence (begin-actions exp) env))
        ((application? exp)
         (apply-scheme (actual-value (operator exp) env)
                       (operands exp)
                       env))))

(define (actual-value exp env)
  (force-it (eval-scheme exp env)))

(define (apply-scheme procedure arguments env)
  (cond ((primitive-procedure? procedure)
         (apply-primitive-procedure
          procedure
          (list-of-values arguments env)))
        ((compound-procedure? procedure)
         (eval-sequence
          (procedure-body procedure)
          (extend-environment
           (procedure-parameters procedure)
           (list-of-delayed-args arguments env)
           (procedure-environment procedure))))))

(define (list-of-values exps env)
  (map (lambda (exp) (actual-value exp env)) exps))

(define (list-of-delayed-args exps env)
  (map (lambda (exp) (delay-it exp env)) exps))

(define (eval-if exp env)
  (if (actual-value (if-predicate exp) env)
      (eval-scheme (if-consequent exp) env)
      (eval-scheme (if-alternative exp) env)))

(define (eval-sequence exps env)
  (cond ((last-exp? exps) (eval-scheme (first-exp exps) env))
        (else (eval-scheme (first-exp exps) env)
              (eval-sequence (rest-exps exps) env))))

(define (eval-definition exp env)
  (define-variable! (definition-variable exp)
                    (eval-scheme (definition-value exp) env)
                    env))

;;; Expression Types

(define (self-evaluating? exp) (number? exp))

(define (tagged-list? exp tag)
  (and (pair? exp) (eq? (car exp) tag)))

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

(define (definition? exp) (tagged-list? exp 'define))
(define (definition-variable exp)
  (if (symbol? (cadr exp))
      (cadr exp)
      (caadr exp)))
(define (definition-value exp)
  (if (symbol? (cadr exp))
      (caddr exp)
      (make-lambda (cdadr exp)
                   (cddr exp))))

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

(define (if? exp) (tagged-list? exp 'if))
(define (if-predicate exp) (cadr exp))
(define (if-consequent exp) (caddr exp))
(define (if-alternative exp)
  (if (not (null? (cdddr exp)))
      (cadddr exp)
      'false))

(define (begin? exp) (tagged-list? exp 'begin))
(define (begin-actions exp) (cdr exp))
(define (last-exp? seq) (null? (cdr seq)))
(define (first-exp seq) (car seq))
(define (rest-exps seq) (cdr seq))

(define (application? exp) (pair? exp))
(define (operator exp) (car exp))
(define (operands exp) (cdr exp))

;;; Environments

(define (make-procedure parameters body env)
  (list 'procedure parameters body env))
(define (compound-procedure? p)
  (tagged-list? p 'procedure))
(define (procedure-parameters p) (cadr p))
(define (procedure-body p) (caddr p))
(define (procedure-environment p) (cadddr p))

(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 (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 arguments supplied" vars vals)
          (error "Too few arguments supplied" vars vals))))

(define (lookup 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" var)
        (let ((frame (first-frame env)))
          (scan (frame-variables frame)
                (frame-values frame)))))
  (env-loop env))

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

(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))))

;;; Primitives

(define (init)
  (let ((initial-env
         (extend-environment (primitive-procedure-names)
                             (primitive-procedure-objects)
                             the-empty-environment)))
    (define-variable! 'true true initial-env)
    (define-variable! 'false false initial-env)
    (eval-definition '(define (cons a b) (lambda (m) (m a b))) initial-env)
    (eval-definition '(define (car s) (s (lambda (a b) a))) initial-env)
    (eval-definition '(define (cdr s) (s (lambda (a b) b))) initial-env)
    initial-env))

(define (primitive-procedure? proc) (tagged-list? proc 'primitive))
(define (primitive-implementation proc) (cadr proc))
(define primitive-procedures
  (list (list '+ +)
        (list '- -)
        (list '* *)
        (list '/ /)
        (list '= =)
        ))
(define (primitive-procedure-names)
  (map car
       primitive-procedures))
(define (primitive-procedure-objects)
  (map (lambda (proc) (list 'primitive (cadr proc)))
       primitive-procedures))
(define (apply-primitive-procedure proc args)
  (apply (primitive-implementation proc) args))

;;; Utilities

;; Return a copy of s with elements in reverse order.
(define (reverse s)
  (define (reverse-iter s r)
    (if (null? s) r
      (reverse-iter (cdr s)
                    (cons (car s) r))))
  (reverse-iter s nil))

;; Map procedure over s.
(define (map procedure s)
  (define (map-reverse s m)
    (if (null? s) m
      (map-reverse (cdr s)
                   (cons (procedure (car s)) m))))
  (reverse (map-reverse s nil)))

(define (cadr s) (car (cdr s)))
(define (cddr s) (cdr (cdr s)))
(define (caadr s) (car (car (cdr s))))
(define (caddr s) (car (cdr (cdr s))))
(define (cdadr s) (cdr (car (cdr s))))
(define (cdddr s) (cdr (cdr (cdr s))))
(define (cadddr s) (car (cdr (cdr (cdr s)))))

;;; Representing thunks

(define (delay-it exp env)
  (list 'thunk exp env))

(define (force-it obj)
  (if (thunk? obj)
      (actual-value (thunk-exp obj) (thunk-env obj))
      obj))

(define (thunk? obj)
  (tagged-list? obj 'thunk))

(define (thunk-exp thunk) (cadr thunk))
(define (thunk-env thunk) (caddr thunk))