path: root/sicp/chapter4.scm

; 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 anal-table (make-table))
(define (get-analyzer exp)
  (if (list? exp)
      ((anal-table 'lookup-proc) (car exp))
      #f))
(define (analyze exp)
  (cond ((get-analyzer exp) => (lambda (analyzer) (analyzer exp)))
        ((or (number? exp) (string? exp)) (lambda (env) exp))
        ((symbol? exp) (lambda (env) (lookup-variable-value exp env)))
        ((pair? exp) (analyze-application (cons 'call exp)))
        (else (error "Unknown expression type: ANALYZE" exp))))

(define (definition? exp) (and (list? exp) (eq? (car 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 (analyze-definition exp)
  (let ((var (definition-variable exp))
        (vproc (analyze (definition-value exp))))
    (lambda (env)
      (define-variable! var (vproc env) env)
      'ok)))

(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))
; Exercise 4.16
(define (define->set! exp)
  (if (definition? exp)
      (list 'set! (definition-variable exp) (definition-value exp))
      exp))
(define (analyze-sequence exps)
  (let ((vars (map definition-variable (filter definition? exps))))
    (if (null? vars)
        (let ((procs (map analyze exps)))
          (if (null? procs)
              (error "Empty sequence: ANALYZE")
              (let loop ((first-proc (car procs))
                         (rest-procs (cdr procs)))
                (if (null? rest-procs)
                    first-proc
                    (loop (lambda (env) (first-proc env) ((car rest-procs) env))
                          (cdr rest-procs))))))
        (analyze (list* (list* 'lambda vars (map define->set! exps))
                        (map (lambda (var) ''*unassigned*) vars))))))
(define (analyze-begin exp) (analyze-sequence (begin-actions exp)))

(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))
(define (procedure-body p) (caddr p))
(define (procedure-environment p) (cadddr p))

(define (execute-application proc args)
  (cond ((primitive-procedure? proc)
         (apply (primitive-implementation proc) args))
        ((compound-procedure? proc)
         ((procedure-body proc)
          (extend-environment (map cons (procedure-parameters proc) args)
                              (procedure-environment proc))))
        (else (error "Unknown procedure type: EXECUTE-APPLICATION" proc))))

(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 (analyze-application exp)
  (let ((fproc (analyze (operator exp)))
        (aprocs (map analyze (operands exp))))
    (lambda (env)
      (execute-application (fproc env)
                           (map (lambda (aproc) (aproc env)) aprocs)))))

(define (analyze-quoted exp)
  (let ((qval (cadr exp)))
    (lambda (env) qval)))

(define (assignment-variable exp) (cadr exp))
(define (assignment-value exp) (caddr exp))
(define (analyze-assignment exp)
  (let ((var (assignment-variable exp))
        (vproc (analyze (assignment-value exp))))
    (lambda (env)
      (set-variable-value! var (vproc 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 (analyze-lambda exp)
  (let ((vars (lambda-parameters exp))
        (bproc (analyze-sequence (lambda-body exp))))
    (lambda (env) (make-procedure vars bproc env))))

(define analyzed-true (lambda (env) (lookup-variable-value 'true env)))
(define analyzed-false (lambda (env) (lookup-variable-value 'false env)))
(define (false? evaluated-exp env) (eq? evaluated-exp (analyzed-false env)))
(define (true? evaluated-exp env) (not (false? evaluated-exp env)))
(define (if-predicate exp) (cadr exp))
(define (if-consequent exp) (caddr exp))
(define (if-alternative exp)
  (if (null? (cdddr exp))
      'false
      (cadddr exp)))
(define (analyze-if exp)
  (let ((pproc (analyze (if-predicate exp)))
        (cproc (analyze (if-consequent exp)))
        (aproc (analyze (if-alternative exp))))
    (lambda (env) ((if (true? (pproc env) env) cproc aproc) env))))

; Exercise 4.4
(define (analyze-and exp)
  (let loop ((first-exp analyzed-true)
             (rest-exps (map analyze (cdr exp))))
    (if (null? rest-exps)
        first-exp
        (loop (lambda (env)
                (let ((pred (first-exp env)))
                  (if (false? pred env) pred ((car rest-exps) env))))
              (cdr rest-exps)))))
(define (analyze-or-exps analyzed-exps)
  (let loop ((first-exp analyzed-false) (rest-exps analyzed-exps))
    (if (null? rest-exps)
        first-exp
        (loop (lambda (env)
                (let ((pred (first-exp env)))
                  (if (false? pred env) ((car rest-exps) env) pred)))
              (cdr rest-exps)))))
(define (analyze-or exp) (analyze-or-exps (map analyze (cdr exp))))

; Exercise 4.5
(define (cond-clauses exp) (cdr exp))
(define (cond-predicate clause) (car clause))
(define (cond-actions clause) (cdr clause))
(define (analyze-cond-clause clause)
  (let ((pproc (analyze (cond-predicate clause)))
        (bproc (let ((actions (cond-actions clause)))
                 (cond ((null? actions) (lambda (pred env) pred))
                       ((eq? (car actions) '=>)
                        (let ((fproc (analyze (cadr actions))))
                          (lambda (pred env)
                            (execute-application (fproc env) (list pred)))))
                       (else (let ((consequences (analyze-sequence actions)))
                               (lambda (pred env) (consequences env))))))))
    (lambda (env)
      (let ((pred (pproc env)))
        (if (true? pred env) (bproc pred env) (analyzed-false env))))))
(define (analyze-cond exp)
  (analyze-or-exps (map analyze-cond-clause (cond-clauses exp))))

; 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
        `((lambda (,ad)
            (set! ,ad (lambda ,(map car (car dd)) ,@(cdr dd)))
            (,ad ,@(map cadr (car dd))))
          '*unassigned*))))
; Exercise 4.22
(define (analyze-let exp) (analyze (let->combination exp)))

; 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 (analyze-let* exp) (analyze (let*->nested-lets exp)))

; Exercise 4.9
(define (analyze-while exp) ; (while pred body)
  (let ((pproc (analyze (cadr exp)))
        (bproc (analyze-sequence (cddr exp))))
    (lambda (env)
      (let loop ((pred (pproc env)))
        (if (true? pred env)
            (begin (bproc env)
                   (loop (pproc env))))))))
(define (analyze-for exp) ; (for init pred body)
  (analyze (list 'let (cadr exp) (cons 'while (cddr exp)))))

; Exercise 4.2
(define (add-analyzer! tag analyzer)
  ((anal-table 'insert-proc!) tag analyzer))
(add-analyzer! 'call analyze-application)
(add-analyzer! 'quote analyze-quoted)
(add-analyzer! 'set! analyze-assignment)
(add-analyzer! 'define analyze-definition)
(add-analyzer! 'if analyze-if)
(add-analyzer! 'lambda analyze-lambda)
(add-analyzer! 'begin analyze-begin)
(add-analyzer! 'cond analyze-cond)
(add-analyzer! 'and analyze-and)
(add-analyzer! 'or analyze-or)
(add-analyzer! 'let analyze-let)
(add-analyzer! 'let* analyze-let*)
(add-analyzer! 'while analyze-while)
(add-analyzer! 'for analyze-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 (mk-init-env)
  (make-environment primitive-procedures
                    (list (cons 'false #f) (cons 'true #t) (cons 'else #t))))

(define (evaluator-loop)
  (let loop ((environment (mk-init-env)))
    (display "> ")
    (let ((input (read)))
      (if (not (eq? input 'quit))
          (let ((output ((analyze 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))))))