sicp/mceval/leval.rkt

#lang sicp

;;;;LAZY EVALUATOR FROM SECTION 4.2 OF
;;;; STRUCTURE AND INTERPRETATION OF COMPUTER PROGRAMS

;;;; OMP: modified to work with racket and to fit with existing code

(#%require racket/trace)
(#%require "syntax.rkt")
(#%require "environment.rkt")
(#%require "common.rkt")
(#%require "special-forms.rkt")
(#%require "lazy-list.rkt")

(#%provide lazy-driver-loop
           lazy-eval-program)

;;;SECTION 4.2.2

;;; Modifying the evaluator

(define (lazy-eval exp env)
  (cond ((self-evaluating? exp) exp)
        ((lazy-pair? exp) exp)
        ((variable? exp) (lookup-variable-value exp env))
        ((quoted? exp) (let ((text (text-of-quotation exp)))
                         (if (pair? text)
                             (lazy-eval (quoted-exp->cons-quoted text)
                                        env)
                             text)))
        ((assignment? exp) (eval-assignment exp env lazy-eval))
        ((definition? exp) (eval-definition exp env lazy-eval))
        ((if? exp) (lazy-eval-if exp env))
        ((lambda? exp)
         (make-procedure (lambda-parameters exp)
                         (lambda-body exp)
                         env))
        ((lazy-pair-lambda? exp)
         (make-lazy-pair-procedure (lambda-parameters exp)
                                   (lambda-body exp)
                                   env))
        ((begin? exp) 
         (eval-sequence (begin-actions exp) env lazy-eval))
        ((cond? exp) (lazy-eval (cond->if exp) env))
        ((application? exp)             ; clause from book
         (lazy-apply (actual-value (operator exp) env)
                     (operands exp)
                     env))
        (else
         (error "Unknown expression type -- LAZY-EVAL" exp))))

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

(define (lazy-apply procedure arguments env)
  (cond ((primitive-procedure? procedure)
         (apply-primitive-procedure
          procedure
          (list-of-arg-values arguments env))) ; changed
        ((lazy-pair? procedure)
         ;; Skip over the lazy-pair tag if we have a lazy-pair as a procedure
         (lazy-apply (lazy-pair-proc procedure)
                     arguments env))
        ((compound-procedure? procedure)
         (eval-sequence
          (procedure-body procedure)
          (extend-environment
           (procedure-parameters procedure)
           (list-of-delayed-args arguments env) ; changed
           (procedure-environment procedure))
          lazy-eval))
        (else
         (error
          "Unknown procedure type -- APPLY" procedure))))

(define (list-of-arg-values exps env)
  (if (no-operands? exps)
      '()
      (cons (actual-value (first-operand exps) env)
            (list-of-arg-values (rest-operands exps)
                                env))))

(define (list-of-delayed-args exps env)
  (if (no-operands? exps)
      '()
      (cons (delay-it (first-operand exps) env)
            (list-of-delayed-args (rest-operands exps)
                                  env))))

(define (lazy-eval-if exp env)
  (if (true? (actual-value (if-predicate exp) env))
      (lazy-eval (if-consequent exp) env)
      (lazy-eval (if-alternative exp) env)))

(define input-prompt ";;; L-Eval input:")
(define output-prompt ";;; L-Eval value:")


(define (user-print object env)
  (cond ((lazy-pair? object) (display (print-lazy-pair object env)))
        ((compound-procedure? object)
         (display (list 'compound-procedure
                        (procedure-parameters object)
                        (procedure-body object)
                        '<procedure-env>)))
        (else (display object))))

(define (print-lazy-pair lazy-pair env)
  (let loop ((lp lazy-pair) (i 0))
    (cond ((= i 16) '(...))
          ((null? lp) '())
          ((pair? lp)
           (cons (actual-value `(car ,lp) env)
                 (loop
                  (actual-value `(cdr ,lp) env)
                  (+ i 1))))
          (else lp))))

(define (lazy-driver-loop)
  (define env (setup-environment))
  ;; Read in code to implement lazy lists
  (eval-program lazy-lists-program lazy-eval user-print env)
  (define (driver-loop)
    (prompt-for-input input-prompt)
    (let ((input (read)))
      (let ((output (actual-value input env)))
        (announce-output output-prompt)
        (user-print output env))
      (driver-loop)))
  (driver-loop))

(define (lazy-eval-program program)
  (define env (setup-environment))
  (eval-program lazy-lists-program lazy-eval user-print env)
  (eval-program program actual-value user-print env))

;;; Representing thunks

;; non-memoizing version of force-it

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

(define (delay-it exp env)
  (make-thunk exp env))

;; memoizing version of force-it

(define (force-it obj)
  (cond ((thunk? obj)
         (let ((result (actual-value
                        (thunk-exp obj)
                        (thunk-env obj))))
           (set-car! obj 'evaluated-thunk)
           (set-car! (cdr obj) result)  ; replace exp with its value
           (set-cdr! (cdr obj) '())     ; forget unneeded env
           result))
        ((evaluated-thunk? obj)
         (thunk-value obj))
        (else obj)))


'LAZY-EVALUATOR-LOADED