Ленивый вычислитель и мемоизация thunk

(begin
  (define (tagged-list? expression tag)
    (and (pair? expression) (eq? (car expression) tag)))
  (define (self-evaluating? expression)
    (or (number? expression)
        (string? expression)
        (boolean? expression)))
  (define (quoted? expression) (tagged-list? expression 'quote))
  (define (if? expression) (tagged-list? expression 'if))
  (define (lambda? expression) (tagged-list? expression 'lambda))
  (define (begin? expression) (tagged-list? expression 'begin))
  (define (definition? expression) (tagged-list? expression 'define))

  (define (text-of-quotation expression) (cadr expression))
  (define (if-predicate expression) (cadr expression))
  (define (if-consequent expression) (caddr expression))
  (define (if-alternative expression) (cadddr expression))
  (define (lambda-parameters expression) (cadr expression))
  (define (lambda-body expression) (cddr expression))
  (define (begin-actions expression) (cdr expression))
  (define (definition-variable expression)
    (if (symbol? (cadr expression))
        (cadr expression)
        (car (cadr expression))))
  (define (definition-value expression)
    (if (symbol? (cadr expression))
        (caddr expression)
        (cons 'lambda
              (cons (cdr (cadr expression))
                    (cddr expression)))))
  (define (operator expression) (car expression))
  (define (operands expression) (cdr expression))

  (define (pair-bindings variables values)
    (cond ((and (null? variables) (null? values)) '())
          ((null? variables) (error "too many guest arguments"))
          ((null? values) (error "too few guest arguments"))
          (else
           (cons (cons (car variables) (car values))
                 (pair-bindings (cdr variables) (cdr values))))))
  (define (make-frame variables values)
    (cons '*frame* (pair-bindings variables values)))
  (define (first-frame environment) (car environment))
  (define (frame-bindings frame) (cdr frame))
  (define (extend-environment variables values base)
    (cons (make-frame variables values) base))
  (define (lookup-variable-value variable environment)
    (if (null? environment)
        (error "unbound lazy guest variable" variable)
        (let ((record
               (assoc variable
                      (frame-bindings (first-frame environment)))))
          (if record
              (cdr record)
              (lookup-variable-value variable (cdr environment))))))
  (define (define-variable! variable value environment)
    (let* ((frame (first-frame environment))
           (record (assoc variable (frame-bindings frame))))
      (if record
          (set-cdr! record value)
          (set-cdr! frame
                    (cons (cons variable value)
                          (frame-bindings frame)))))
    (list 'defined variable))

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

  (define (delay-it expression environment)
    (list 'thunk expression environment))
  (define (thunk? object) (tagged-list? object 'thunk))
  (define (evaluated-thunk? object)
    (tagged-list? object 'evaluated-thunk))
  (define (force-it object)
    (cond ((thunk? object)
           (let ((result
                  (actual-value (cadr object) (caddr object))))
             (set-car! object 'evaluated-thunk)
             (set-car! (cdr object) result)
             (set-cdr! (cdr object) '())
             result))
          ((evaluated-thunk? object) (cadr object))
          (else object)))
  (define (actual-value expression environment)
    (force-it (lazy-eval expression environment)))

  (define (true? value) (not (eq? value #f)))
  (define (eval-if expression environment)
    (if (true? (actual-value (if-predicate expression) environment))
        (lazy-eval (if-consequent expression) environment)
        (lazy-eval (if-alternative expression) environment)))
  (define (eval-sequence expressions environment)
    (cond ((null? expressions) 'ok)
          ((null? (cdr expressions))
           (lazy-eval (car expressions) environment))
          (else
           (actual-value (car expressions) environment)
           (eval-sequence (cdr expressions) environment))))
  (define (eval-definition expression environment)
    (define-variable!
      (definition-variable expression)
      (actual-value (definition-value expression) environment)
      environment))

  (define (list-of-arg-values expressions environment)
    (if (null? expressions)
        '()
        (cons (actual-value (car expressions) environment)
              (list-of-arg-values (cdr expressions) environment))))
  (define (list-of-delayed-args expressions environment)
    (if (null? expressions)
        '()
        (cons (delay-it (car expressions) environment)
              (list-of-delayed-args (cdr expressions) environment))))
  (define (apply-lazy procedure argument-expressions calling-environment)
    (cond ((procedure? procedure)
           (apply procedure
                  (list-of-arg-values
                    argument-expressions
                    calling-environment)))
          ((compound-procedure? procedure)
           (eval-sequence
             (procedure-body procedure)
             (extend-environment
               (procedure-parameters procedure)
               (list-of-delayed-args
                 argument-expressions
                 calling-environment)
               (procedure-environment procedure))))
          (else
           (error "not a lazy guest procedure" procedure))))

  (define (lazy-eval expression environment)
    (cond ((self-evaluating? expression) expression)
          ((symbol? expression)
           (lookup-variable-value expression environment))
          ((quoted? expression)
           (text-of-quotation expression))
          ((if? expression)
           (eval-if expression environment))
          ((lambda? expression)
           (make-procedure
             (lambda-parameters expression)
             (lambda-body expression)
             environment))
          ((begin? expression)
           (eval-sequence (begin-actions expression) environment))
          ((definition? expression)
           (eval-definition expression environment))
          ((pair? expression)
           (apply-lazy
             (actual-value (operator expression) environment)
             (operands expression)
             environment))
          (else
           (error "unknown lazy guest expression" expression))))

  (define probes 0)
  (define (probe value)
    (set! probes (+ probes 1))
    value)
  (define primitive-bindings
    (list (cons '+ +) (cons '- -) (cons '* *) (cons '/ /)
          (cons '= =) (cons '< <) (cons '> >)
          (cons 'list list) (cons 'cons cons)
          (cons 'car car) (cons 'cdr cdr)
          (cons 'null? null?) (cons 'pair? pair?)
          (cons 'probe probe)))
  (define global-environment
    (list (cons '*frame* primitive-bindings)))
  (define unused
    '((lambda (x) 1) (probe 10)))
  (define duplicated
    '((lambda (x) (+ x x)) (probe 10)))
  (define selected-branch
    '(if #t (quote safe) (probe 99)))
  (set! probes 0)
  (define unused-value
    (actual-value unused global-environment))
  (define unused-probes probes)
  (set! probes 0)
  (define duplicated-value
    (actual-value duplicated global-environment))
  (define duplicated-probes probes)
  (set! probes 0)
  (define branch-value
    (actual-value selected-branch global-environment))
  (list (list 'unused unused-value unused-probes)
        (list 'duplicated duplicated-value duplicated-probes)
        (list 'branch branch-value probes))
)