Add exercise 4.30

We can pass 'lazy or 'lazy-memo along with parameters to specify lazy
evaluation with or without memoization.

mceval/4-29.rkt

@@ -0,0 +1,60 @@
+#lang sicp
+
+(#%require "leval.rkt")
+(#%require "test-eval.rkt")
+
+(define (program delay)
+  `((define count 0)
+    (define (id ,(qualify-arg 'x delay))
+      (set! count (+ count 1)) x)
+    (define (square ,(qualify-arg 'x delay))
+      (* x x))
+    (square (id 10))
+    count))
+
+(define (input-sequence val count)
+  (cons 'list
+        (let loop ((n count))
+          (if (= n 0) '()
+              (cons val (loop (- n 1)))))))
+
+(define (map-program length delay)
+  `((define (f ,(qualify-arg 'x delay))
+      (+ x (sqrt x)))
+    (define input
+      ,(input-sequence 5 length))
+    (define (map ,(qualify-arg 'f delay)
+                 ,(qualify-arg 'x delay))
+      (if (null? x) '()
+          (cons (f (car x))
+                (map f (cdr x)))))
+    (map f input)))
+
+
+(#%require (only racket/base module+))
+(#%require rackunit)  
+
+(module+ test
+  ;; With the normal lazy evaluator, square evaluates id twice
+  (check-equal? (lazy-eval-program (program 'lazy)) 2)
+  ;; With the memoizing evaluator, the first call to id is memoized,
+  ;; so another call is not needed.
+  (check-equal? (lazy-eval-program (program 'lazy-memo)) 1))
+
+(module+ timing
+
+  ;; Map needs to re-evaluate the procedure f for each element of the
+  ;; input for lazy evaluation.  If memoized, this is only evaluated once.
+  (define lazy-map (time-proc 100 (lambda () (lazy-eval-program
+                                              (map-program 100 'lazy)))))
+  (define lazy-memo-map (time-proc 100 (lambda () (lazy-eval-program
+                                                   (map-program 100 'lazy-memo)))))
+  (display `("Map: lazy " ,lazy-map " lazy-memo " ,lazy-memo-map " speed-up "
+                          ,(/ lazy-map lazy-memo-map)))
+
+  ;; Gives ~16x speedup.
+)
+
+;; In general, performance for the memoizing evaluator should be
+;; much better when multiple references are made to the result of
+;; evaluating a procedure.

mceval/4-30.rkt

@@ -0,0 +1,95 @@
+;; for-each is defined:
+;; (define (for-each (proc lazy) (items lazy))
+;;   (if (null? items)
+;;       'done
+;;       (begin (proc (car items))
+;;              (for-each proc (cdr items)))))
+
+
+;; Part a: using the eval-sequence from leval handles sequenced side
+;; effects in for-each correctly.  The example evaluates as follows:
+;; (for-each (lambda (x) (newline) (display x))
+;;           (list 57 321 88))
+
+;; (begin ((lambda (x) (newline) (display x)) 57)
+;;        (begin ((lambda (x) (newline) (display x)) 321)
+;;               (begin ((lambda (x) (newline) (display x)) 88))))
+
+;; The first begin evaluates the first argument, which is an
+;; application, so it forces the procedure and delays its argument.
+;; Thus we have:
+
+;; ((lambda (x) (newline) (display x)) '(thunk 57))
+
+;; newline and display are both native procedures, so their arguments
+;; are forced, and 57 is displayed.  The rest of the values follow
+;; similarly.  The reason the normal-eval sequence works is that the
+;; procedure being applied for its side effect calls a primitive
+;; procedure.
+
+;; Part b:
+
+;; Define p1 and p2
+
+;; (define (p1 (x lazy))
+;;   (set! x (cons x '(2)))
+;;   x)
+
+;; (define (p2 (x lazy))
+;;   (define (p (e lazy))
+;;     e
+;;     x)
+;;   (p (set! x (cons x '(2)))))
+
+;; Using the original evaluator:
+
+;; (p1 1)
+;; -> (set! x (cons 1 '(2))) x
+;; ->(1 2)
+
+;; because cons is primitive, so x is forced
+
+;; (p2 1)
+;; -> (p '(thunk set! x (cons x '(2))) 1)
+;; -> 1
+
+;; because nothing ever uses the argument to p, it is never forced.
+
+;; An alternative eval-sequence that forces all expressions other than
+;; the last one to ensure all side effects are carried out.
+;; (define (eval-sequence* exps env)
+;;   (cond ((last-exp? exps) (eval (first-exp exps) env))
+;;         (else (actual-value (first-exp exps) env)
+;;               (eval-sequence* (rest-exps exps) env))))
+
+;; Using this:
+;; (p1 1)
+;; -> (1 2)
+
+;; as before
+
+;; (p2 1)
+;; -> (p '(thunk set! x (cons x '(2))))
+;; -> (actual-value '(thunk set! x (cons x '(2)))) (actual-value x)
+;; -> (1 2)
+
+
+;; Part c:
+
+;; Using eval-sequence*
+
+;; (for-each (lambda (x) (newline) (display x))
+;;           (list 57 321 88))
+
+;; -> (begin ((lambda (x) (newline) (display x)) 57)
+;;        (begin ((lambda (x) (newline) (display x)) 321)
+;;               (begin ((lambda (x) (newline) (display x)) 88))))
+
+;; This evaluates as for eval-sequence because the procedure only has
+;; native procedures which are forced anyway, so there is no
+;; difference between the two options.
+
+;; Part d: I prefer eval-sequence*, Cy's approach, as sequences are
+;; used for side effects (since only the value of the final
+;; expression is returned).  So ensuring that side-effects are handled
+;; correctly seems like a better option.

mceval/environment.rkt

@@ -166,6 +166,7 @@
         (list '/ /)
         (list '< <)
         (list '> >)
+        (list 'sqrt sqrt)
         (list 'newline newline)
         (list 'display display)
         ))

mceval/leval.rkt

@@ -5,6 +5,11 @@
 
 ;;;; OMP: modified to work with racket and to fit with existing code
 
+;;;; This evaluator uses the modifications of exercise 4.31: arguments
+;;;; can be strict, lazy or lazy with memoization.  To specify a
+;;;; procedure, strict in x, lazy in y and lazy with memoization in z:
+;;;; (define (f x (y 'lazy) (z 'lazy-memo))).
+
 (#%require racket/trace)
 (#%require "syntax.rkt")
 (#%require "environment.rkt")
@@ -52,7 +57,10 @@
           (procedure-body procedure)
           (extend-environment
            (procedure-parameters procedure)
-           (list-of-delayed-args arguments env) ; changed
+           (list-of-qualified-args
+            arguments
+            (procedure-delays procedure)
+            env) ; changed
            (procedure-environment procedure))
           lazy-eval))
         (else
@@ -66,12 +74,18 @@
             (list-of-arg-values (rest-operands exps)
                                 env))))
 
-(define (list-of-delayed-args exps env)
+(define (list-of-qualified-args exps delays env)
   (if (no-operands? exps)
       '()
-      (cons (delay-it (first-operand exps) env)
-            (list-of-delayed-args (rest-operands exps)
-                                  env))))
+      (cons
+       (let ((delay (first-delay delays)))
+         (if (eq? delay 'strict)
+           (lazy-eval (first-operand exps) env)
+           (delay-it (first-operand exps) env delay)))
+       (list-of-qualified-args
+        (rest-operands exps)
+        (rest-delays delays)
+        env))))
 
 (define (lazy-eval-if exp env)
   (if (true? (actual-value (if-predicate exp) env))
@@ -98,20 +112,17 @@
 
 ;;; 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 (delay-it exp env method)
+  (cond ((eq? method 'lazy-memo)
+         (make-memo-thunk exp env))
+        ((eq? method 'lazy)
+         (make-thunk exp env))
+        (else
+         (error ("Unknown delay type -- DELAY-IT" method)))))
 
+;; memo-thunks created by are memoized on forcing. thunks are not.
 (define (force-it obj)
-  (cond ((thunk? obj)
+  (cond ((memo-thunk? obj)
          (let ((result (actual-value
                         (thunk-exp obj)
                         (thunk-env obj))))
@@ -121,7 +132,17 @@
            result))
         ((evaluated-thunk? obj)
          (thunk-value obj))
+        ((thunk? obj)
+         (actual-value
+          (thunk-exp obj)
+          (thunk-env obj)))
         (else obj)))
 
+(#%require (only racket/base module+))
+(module+ test
+  (#%require rackunit)
+  (define env (setup-environment))
+  (check-equal? (force-it (delay-it '(+ 1 1) env 'lazy)) 2)
+  (check-equal? (force-it (delay-it '(+ 1 1) env 'lazy-memo)) 2))
 
 'LAZY-EVALUATOR-LOADED

mceval/syntax.rkt

@@ -1,5 +1,7 @@
 #lang sicp
 
+(#%require racket/trace)
+
 (#%provide (all-defined))
 
 (define (self-evaluating? exp)
@@ -90,6 +92,11 @@
 (define (rest-operands ops) (cdr ops))
 (define (last-operand? ops) (null? (rest-operands ops)))
 
+(define (no-delays? ops) (null? ops))
+(define (first-delay ops) (car ops))
+(define (rest-delays ops) (cdr ops))
+(define (last-delay? ops) (null? (rest-delays ops)))
+
 ;; cond (including recipient clause for exercise 4.5)
 (define (cond? exp) (tagged-list? exp 'cond))
 (define (cond-clauses exp) (cdr exp))
@@ -318,16 +325,31 @@
            (unless-consequent exp)
            (unless-alternative exp)))
 
-(define (make-procedure parameters body env)
-  (list 'procedure parameters body env))
+;; Exercise 4.31: procedure parameters can be qualified by 'lazy or
+;; 'lazy-memo.  In either case, the parameter will be a 2-element list
+;; with the parameter name first and the delay second. Normal
+;; single-element parameters are taken to be strictly evaluated.
+(define (make-procedure qualified-parameters body env)
+  (define (parameter qualified-parameter)
+    (if (pair? qualified-parameter)
+        (car qualified-parameter)
+        qualified-parameter))
+  (define (delay qualified-parameter)
+    (if (pair? qualified-parameter)
+        (cadr qualified-parameter)
+        'strict))
+  (list 'procedure
+        (map parameter qualified-parameters)
+        (map delay qualified-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 (procedure-delays p) (caddr p))
+(define (procedure-body p) (cadddr p))
+(define (procedure-environment p) (car (cddddr p)))
 
 ;; Exercise 4.16: transform the body to scan out internal
 ;; definitions.  Variables will be created unassigned by a let and
@@ -382,13 +404,19 @@
 
 (define (make-thunk exp env)
   (list 'thunk exp env))
-
 (define (thunk? obj)
   (tagged-list? obj 'thunk))
-
 (define (thunk-exp thunk) (cadr thunk))
 (define (thunk-env thunk) (caddr thunk))
 
+;; thunk that should be memoized when forced
+(define (make-memo-thunk exp env)
+  (list 'memo-thunk exp env))
+(define (memo-thunk? obj)
+  (tagged-list? obj 'memo-thunk))
+(define memo-thunk-exp thunk-exp)
+(define memo-thunk-env thunk-env)
+
 ;; "thunk" that has been forced and is storing its (memoized) value
 (define (evaluated-thunk? obj)
   (tagged-list? obj 'evaluated-thunk))

mceval/test-eval.rkt

@@ -7,6 +7,9 @@
            "analyzing-mceval.rkt"
            "leval.rkt")
 
+(#%provide qualify-arg
+           time-proc)
+
 (#%require (only racket current-process-milliseconds))
 (#%require (only racket/base module+))
 
@@ -31,8 +34,16 @@
           (* n (fact (- n 1)))))
     (fact ,x)))
 
-(define (fib-program x)
-  `((define (fib n)
+
+(define (qualify-arg arg delay)
+  (cond ((eq? delay 'strict) arg)
+        ((eq? delay 'lazy) `(,arg lazy))
+        ((eq? delay 'lazy-memo) `(,arg lazy-memo))
+        (else (error "Unknown delay" delay))))
+
+(define (fib-program x delay)
+  `((define (fib
+             ,(qualify-arg 'n delay))
       (cond ((= n 0) 0)
             ((= n 1) 1)
             (else
@@ -40,8 +51,9 @@
                 (fib (- n 1))))))
     (fib ,x)))
 
-(define lazy-test-program
-  '((define (try a b)
+(define (lazy-test-program delay)
+  `((define (try a
+                 ,(qualify-arg 'b delay))
       (if (= a 0) 1 b))
     (try 0 (/ 1 0))))
 
@@ -56,21 +68,41 @@
   (check-equal? (lazy-eval-program (fact-program 5)) 120)
   (check-equal? (dd-eval-program (fact-program 10))
                 (analyzing-eval-program (fact-program 10)))
-  (check-equal? (dd-eval-program (fib-program 5))
-                (analyzing-eval-program (fib-program 5)))
-  (check-equal? (dd-eval-program (fib-program 5))
-                (lazy-eval-program (fib-program 5)))
-  (check-equal? (lazy-eval-program lazy-test-program) 1))
+  (check-equal? (dd-eval-program (fib-program 5 'strict))
+                (analyzing-eval-program (fib-program 5 'strict)))
+  (check-equal? (dd-eval-program (fib-program 5 'strict))
+                (lazy-eval-program (fib-program 5 'strict)))
+  (check-equal? (lazy-eval-program (fib-program 5 'strict))
+                (lazy-eval-program (fib-program 5 'lazy)))
+  (check-equal? (lazy-eval-program (fib-program 5 'strict))
+                (lazy-eval-program (fib-program 5 'lazy-memo)))
+  (check-equal? (lazy-eval-program (lazy-test-program 'lazy)) 1)
+  (check-equal? (lazy-eval-program (lazy-test-program 'lazy-memo)) 1))
 
 (module+ timing
-  (define dd-fib (time-proc 100 (lambda () (dd-eval-program (fib-program 10)))))
-  (define analyzing-fib (time-proc 100 (lambda () (analyzing-eval-program (fib-program 10)))))
-  (define dd-fact (time-proc 100 (lambda () (dd-eval-program (fact-program 50)))))
-  (define analyzing-fact (time-proc 100 (lambda () (analyzing-eval-program (fact-program 50)))))
+  (define dd-fib (time-proc 100 (lambda () (dd-eval-program
+                                            (fib-program 10 'strict)))))
+  (define analyzing-fib (time-proc 100 (lambda () (analyzing-eval-program
+                                                   (fib-program 10 'strict)))))
+  (define dd-fact (time-proc 100 (lambda () (dd-eval-program
+                                             (fact-program 50)))))
+  (define analyzing-fact (time-proc 100 (lambda () (analyzing-eval-program
+                                                    (fact-program 50)))))
 
-  (display `("Fib: dd " ,dd-fib " analyzing " ,analyzing-fib " speed-up " ,(/ dd-fib analyzing-fib)))
+  (define lazy-fib (time-proc 100 (lambda () (lazy-eval-program
+                                              (fib-program 10 'lazy)))))
+  (define lazy-memo-fib (time-proc 100 (lambda () (lazy-eval-program
+                                                   (fib-program 10 'lazy-memo)))))
+
+  (display `("Fib: dd " ,dd-fib " analyzing " ,analyzing-fib " speed-up "
+                        ,(/ dd-fib analyzing-fib)))
   (newline)
-  (display `("Fact: dd " ,dd-fact " analyzing " ,analyzing-fact " speed-up " ,(/ dd-fib analyzing-fact))))
+  (display `("Fact: dd " ,dd-fact " analyzing " ,analyzing-fact " speed-up "
+                         ,(/ dd-fib analyzing-fact)))
+  (newline)
+  (display `("Fib: lazy " ,lazy-fib " memoizing " ,lazy-memo-fib " speed-up "
+                          ,(/ lazy-fib lazy-memo-fib))))
+
 
 ;; Test results
 ;; test-eval.rkt> (time-proc 100 eval-program fib-program mce-eval mce-user-print)