; Exercise 4.11
(define (make-frame bindings) (cons '*frame* bindings))
(define (lookup-within-frame var frame) (assoc var (cdr frame)))
(define (add-binding-to-frame! var val frame)
  (set-cdr! frame (cons (cons var val) (cdr frame))))

(define the-empty-environment '())
(define (extend-environment bindings base-env)
  (cons (make-frame bindings) base-env))
(define (enclosing-environment env) (cdr env))
(define (first-frame env) (car env))

(define (define-variable! var val env)
  (let* ((frame (first-frame env))
         (binding (lookup-within-frame var frame)))
    (if binding
        (set-cdr! binding val)
        (add-binding-to-frame! var val frame))))
; Exercise 4.12
(define (lookup-binding variable environment)
  (let loop ((env environment))
    (if (eq? env the-empty-environment)
        #f
        (cond ((lookup-within-frame variable (first-frame env)))
              (else (loop (enclosing-environment env)))))))
(define (set-variable-value! var val env)
  (cond ((lookup-binding var env) => (lambda (b) (set-cdr! b val)))
        (else (error "Unbound variable: SET!" var))))
; Exercise 4.16.a
(define (lookup-variable-value var env)
  (let ((value (cond ((lookup-binding var env) => cdr)
                     (else '*unassigned*))))
    (if (eq? value '*unassigned*)
        (error "Unbound variable" var)
        value)))

; Exercise 4.3
(define (make-table)
  (let ((local-table (list '*table*)))
    (define (lookup key)
      (let ((record (assoc key (cdr local-table))))
        (if record (cdr record) #f)))
    (define (insert! key value)
      (let ((record (assoc key (cdr local-table))))
        (if record
            (set-cdr! record value)
            (set-cdr! (let tail ((table local-table))
                        (if (null? (cdr table)) table (tail (cdr table))))
                      (list (cons key value)))))
      'ok)
    (define (dispatch m)
      (cond ((eq? m 'lookup-proc) lookup)
            ((eq? m 'insert-proc!) insert!)
            (else (error "Unknown operation: TABLE" m))))
    dispatch))
(define evaluation-table (make-table))
(define (get-evaluator exp)
  (if (pair? exp)
      ((evaluation-table 'lookup-proc) (car exp))
      #f))
(define (evaluate exp env)
  (cond ((get-evaluator exp) => (lambda (evaluator) (evaluator exp env)))
        ((or (number? exp) (string? exp)) exp)
        ((symbol? exp) (lookup-variable-value exp env))
        ((pair? exp) (eval-application (cons 'call exp) env))
        (else (error "Unknown expression type: EVAL" exp))))

(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 (eval-sequence exps env)
  (let ((first-value (evaluate (first-exp exps) env)))
    (if (last-exp? exps)
        first-value
        (eval-sequence (rest-exps exps) env))))
(define (eval-begin exp env) (eval-sequence (begin-actions exp) env))

(define (primitive-procedure? p) (and (pair? p) (eq? (car p) 'primitive)))
(define (primitive-implementation p) (cadr p))

(define (make-procedure parameters body env)
  (list 'procedure parameters body env))
(define (compound-procedure? p) (and (pair? p) (eq? (car p) 'procedure)))
(define (procedure-parameters p) (cadr p))
; Exercise 4.16.c
(define (procedure-body p) (scan-out-defines (caddr p)))
(define (procedure-environment p) (cadddr p))

(define (evaluator-apply procedure arguments)
  (cond ((primitive-procedure? procedure)
         (apply (primitive-implementation procedure) arguments))
        ((compound-procedure? procedure)
         (eval-sequence
          (procedure-body procedure)
          (extend-environment
           (map cons (procedure-parameters procedure) arguments)
           (procedure-environment procedure))))))

(define (operator exp) (cadr exp))
(define (operands exp) (cddr exp))
(define (no-operands? ops) (null? ops))
(define (first-operand ops) (car ops))
(define (rest-operands ops) (cdr ops))
(define (list-of-values exps env)
  (if (no-operands? exps)
      '()
      (cons (evaluate (first-operand exps) env)
            (list-of-values (rest-operands exps) env))))
(define (eval-application exp env)
  (evaluator-apply (evaluate (operator exp) env)
         (list-of-values (operands exp) env)))

(define (eval-quote exp env) (cadr exp))

(define (assignment-variable exp) (cadr exp))
(define (assignment-value exp) (caddr exp))
(define (eval-assignment exp env)
  (set-variable-value! (assignment-variable exp)
                       (evaluate (assignment-value exp) env)
                       env)
  'ok)

(define (make-lambda parameters body)
  (cons 'lambda (cons parameters body)))
(define (lambda-parameters exp) (cadr exp))
(define (lambda-body exp) (cddr exp))
(define (eval-lambda exp env)
  (make-procedure (lambda-parameters exp)
                  (lambda-body exp)
                  env))

(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 (eval-definition exp env)
  (define-variable! (definition-variable exp)
                    (evaluate (definition-value exp) env)
                    env)
  'ok)

; Exercise 4.16.b
(define (scan-out-defines body)
  (let* ((definitions (filter (lambda (exp) (eq? (car exp) 'define)) body))
         (vars (map definition-variable definitions))
         (vals (map definition-value definitions))
         (assignments (map (lambda (var val) (list 'set! var val)) vars vals))
         (rest (filter (lambda (exp) (not (eq? (car exp) 'define))) body))
         (place-holders (let loop ((n (length vals)))
                          (if (> n 0) (cons '*unassigned* (loop (1- n))) '()))))
    (list (list* 'lambda vars (append assignments rest)) place-holders)))

(define (false? x) (eq? x #f))
(define (true? x) (not (false? x)))
(define (if-predicate exp) (cadr exp))
(define (if-consequent exp) (caddr exp))
(define (if-alternative exp)
  (if (null? (cdddr exp))
      'false
      (cadddr exp)))
(define (eval-if exp env)
  (if (true? (evaluate (if-predicate exp) env))
      (evaluate (if-consequent exp) env)
      (evaluate (if-alternative exp) env)))

; Exercise 4.5
(define (cond-clauses exp) (cdr exp))
(define (cond-predicate clause) (car clause))
(define (cond-actions clause) (cdr clause))
(define (eval-cond exp env)
  (let loop ((clauses (cond-clauses exp)))
    (if (null? clauses)
        'false
        (let* ((first (car clauses))
               (rest (cdr clauses))
               (pred (evaluate (cond-predicate first) env))
               (actions (cond-actions first)))
          (cond ((false? pred) (loop rest))
                ((null? actions) pred)
                ((eq? (car actions) '=>)
                 (evaluator-apply (evaluate (cadr actions) env)
                                  (list pred)))
                (else (eval-sequence actions env)))))))

; Exercise 4.4
(define (eval-and exp env)
  (let loop ((expressions (cdr exp)))
    (cond ((null? expressions) 'true)
          ((last-exp? expressions) (evaluate (car expressions) env))
          ((evaluate (car expressions) env) (loop (cdr expressions)))
          (else 'false))))
(define (eval-or exp env) (eval-cond (map list exp) env))

; Exercise 4.6
(define (let->combination exp)
  (let ((ad (cadr exp))
        (dd (cddr exp)))
    (if (list? ad)
        (list* (list* 'lambda (map car ad) dd)
               (map cadr ad))
        ; Exercise 4.8
        (list 'begin
              (list* 'define (list* ad (map car (car dd))) (cdr dd))
              (list* ad (map cadr (car dd)))))))
(define (eval-let exp env) (evaluate (let->combination exp) env))

; Exercise 4.7
(define (let*->nested-lets exp)
  (let ((body (cddr exp)))
    (let loop ((bindings (cadr exp)))
      (if (or (null? bindings) (last-exp? bindings))
          (list* 'let bindings body)
          (list 'let (list (car bindings)) (loop (cdr bindings)))))))
(define (eval-let* exp env) (evaluate (let*->nested-lets exp) env))

; Exercise 4.9
(define (eval-while exp env) ; (while pred body)
  (let ((pred (cadr exp))
        (body (cddr exp)))
    (let loop ((keep-going (evaluate pred env)))
      (if (true? keep-going)
          (begin (eval-sequence body env)
                 (loop (evaluate pred env)))))))
(define (eval-for exp env) ; (for init pred body)
  (evaluate (list 'let (cadr exp)
                  (list* 'while (caddr exp) (cdddr exp)))
            env))

; Exercise 4.2
(define (add-evaluator! tag evaluator)
  ((evaluation-table 'insert-proc!) tag evaluator))
(add-evaluator! 'call eval-application)
(add-evaluator! 'quote eval-quote)
(add-evaluator! 'set! eval-assignment)
(add-evaluator! 'define eval-definition)
(add-evaluator! 'if eval-if)
(add-evaluator! 'lambda eval-lambda)
(add-evaluator! 'begin eval-begin)
(add-evaluator! 'cond eval-cond)
(add-evaluator! 'and eval-and)
(add-evaluator! 'or eval-or)
(add-evaluator! 'let eval-let)
(add-evaluator! 'let* eval-let*)
(add-evaluator! 'while eval-while)
(add-evaluator! 'for eval-for)

(define primitive-procedures
  (let ((procedures (list (cons 'first car)
                          (cons 'rest cdr)
                          (cons 'cons cons)
                          (cons 'null? null?)
                          (cons 'assoc assoc)
                          (cons 'display display)
                          (cons 'newline newline)
                          (cons '= =)
                          (cons '< <)
                          (cons '> >)
                          (cons '+ +)
                          (cons '- -)
                          (cons '* *)
                          (cons '/ /))))
    (map (lambda (p) (cons (car p) (list 'primitive (cdr p)))) procedures)))
(define (make-environment . environments)
  (if (null? environments)
      the-empty-environment
      (extend-environment (car environments)
                          (apply make-environment (cdr environments)))))

(define (evaluator-loop)
  (let loop ((environment (make-environment primitive-procedures
                                            (list (cons 'false #f)
                                                  (cons 'true #t)
                                                  (cons 'else #t)))))
    (display "> ")
    (let ((input (read)))
      (if (not (eq? input 'quit))
          (let ((output (evaluate input environment)))
            (display output)
            (newline)
            (loop environment))))))

; Exercise 4.21
(define (factorial n)
  ((lambda (fact) (fact fact n))
   (lambda (ft k) (if (= k 1) 1 (* k (ft ft (1- k)))))))
(define (fibonacci n)
  ((lambda (fib) (fib fib n))
   (lambda (f k)
     (if (or (= k 0) (= k 1))
         k
         (+ (f f (1- k))
            (f f (- k 2)))))))
(define (f x)
  ((lambda (even? odd?) (even? even? odd? x))
   (lambda (ev? od? n) (if (= n 0) #t (od? ev? od? (1- n))))
   (lambda (ev? od? n) (if (= n 0) #f (ev? ev? od? (1- n))))))