sicp-ex-4.31



<< Previous exercise (4.30) | Index | Next exercise (4.32) >>


woofy

  
  
  
 (define (apply procedure arguments env) 
     (cond ((primitive-procedure? procedure) 
            (apply-primitive-procedure  
             procedure 
             (list-of-arg-values arguments env))) 
           ((compound-procedure? procedure) 
            (eval-sequence 
              (procedure-body procedure) 
              (extend-environment 
                 (procedure-parameter-names procedure) 
                 (compound-procedure-args procedure arguments env) 
                 (procedure-environment procedure)))) 
           (else 
             (error "Unknown procedure type -- APPLY" procedure)))) 
  
 (define (lazy-param? param) (eq? 'lazy (cadr param))) 
 (define (lazy-memo-param? param) (eq? 'lazy-memo (cadr param))) 
 (define (eager-param? param) (symbol? param)) 
  
 (define (compound-procedure-args procedure arguments caller-env) 
     (define (build-list params arg-exps) 
         (define (build param exp) 
             (cond ((eager-param? param) (actual-value exp caller-env)) 
                   ((lazy-param? param) (delay-it exp caller-env)) 
                   ((lazy-memo-param? param) (delay-it-memo exp caller-env)) 
                   (else (error "Invalid paramemeter specification -- COMPOUND-PROCEDURE-ARGS" param)))) 
         (map build params arg-exps)) 
     (build-list (procedure-parameters procedure) arguments)) 
  
 (define (actual-value exp env) 
     (force-it (eval exp env))) 
  
 (define (delay-it exp env) (list 'thunk exp env)) 
 (define (delay-it-memo exp env) (list 'thunk-memo exp env)) 
 (define (thunk? obj) (tagged-list? obj 'thunk)) 
 (define (thunk-memo? obj) (tagged-list? obj 'thunk-memo)) 
 (define (thunk-exp thunk) (cadr thunk)) 
 (define (thunk-env thunk) (caddr thunk)) 
 (define (evaluated-thunk? obj) (tagged-list? obj 'evaluated-thunk)) 
 (define (thunk-value evaluated-thunk) (cadr evaluated-thunk)) 
  
 (define (force-it obj) 
     (cond ((thunk? obj) (actual-value (thunk-exp obj) (thunk-env obj))) 
           ((thunk-memo? obj) 
            (let ((result (actual-value (thunk-exp obj) (thunk-env obj)))) 
             (set-car! obj 'evaluated-thunk) 
             (set-car! (cdr obj) result) 
             (set-cdr! (cdr obj) '()) 
             result)) 
           ((evaluated-thunk? obj) 
            (thunk-value obj)) 
           (else obj))) 
  
 (define (procedure-parameter-names p) 
     (map (lambda (x) (if (pair? x) (car x) x)) (procedure-parameters p))) 
  

Felix021

  
  
  
 (include "4.2.2.scm") ;;comment (driver-loop) in 4.2.2.scm 
  
 ;; omit the "lazy-memo" requirement for simplicity... 
  
 (define (apply procedure arguments env) 
     (cond 
         ((primitive-procedure? procedure) 
             (apply-primitive-procedure 
                 procedure 
                 (list-of-arg-values arguments env))) 
         ((compound-procedure? procedure) 
             (eval-compound-procedure procedure arguments env)) 
         (else 
             (error "Unknown procedure type -- APPLY" procedure)))) 
  
 (define (eval-compound-procedure procedure arguments env) 
     (define (iter-args formal-args actual-args) 
         (if (null? formal-args) 
             '() 
             (cons 
                 (let ((this-arg (car formal-args))) 
                     (if (and (pair? this-arg) 
                              (pair? (cdr this-arg)) ; avoid error if arg is  
                                                     ; 1 element list. 
                              (eq? (cadr this-arg) 'lazy)) 
                         (delay-it (car actual-args) env) 
                          ;force the argument if it is not lazy.  
                         (actual-value (car actual-args) env))) 
                 (iter-args (cdr formal-args) (cdr actual-args))))) 
  
     (define (procedure-arg-names parameters) 
         (map (lambda (x) (if (pair? x) (car x) x)) parameters)) 
  
     (eval-sequence 
         (procedure-body procedure) 
         (extend-environment 
             (procedure-arg-names (procedure-parameters procedure)) 
             (iter-args  
                 (procedure-parameters procedure) 
                 arguments) 
             (procedure-environment procedure)))) 
  
 (driver-loop) 
  
 ;; test ;; 
  
 ; 
 ; M-Eval input:  
 ;(define x 1) 
 ; 
 ; M-Eval value:  
 ;ok 
 ; 
 ; M-Eval input:  
 ;(define (p (e lazy)) e x) 
 ; 
 ; M-Eval value:  
 ;ok 
 ; 
 ; M-Eval input:  
 ;(p (set! x (cons x '(2)))) 
 ; 
 ; M-Eval value:  
 ;1 
 ; 
 ; M-Eval input:  
 ;(exit) 
 ; 

atupal

 ; start Exercise 4.31 
 (define (procedure-parameters-ex4.31 p) 
   (define (name parameter) 
     (if (pair? parameter) 
       (car parameter) 
       parameter)) 
   (define (parameter-names parameters) 
     (if (null? parameters) 
       '() 
       (cons (name (car parameters)) 
             (parameter-names (cdr parameters))))) 
   (parameter-names (cadr p))) 
 (define (procedure-raw-parameters p) (cadr p)) 
  
 (define (apply-ex4.31 procedure arguments env) 
   (cond [(primitive-procedure? procedure) 
          (apply-primitive-procedure 
            procedure 
            (list-of-arg-values arguments env))]                   ; changed 
         ((compound-procedure? procedure) 
          (eval-sequence 
            (procedure-body procedure) 
            (extend-environment 
              (procedure-parameters procedure) 
              (list-of-delayed-args (procedure-raw-parameters procedure) arguments env) 
              (procedure-environment procedure))))                 ; changed 
         (else (error "Unknow procedure type: APPLY" 
                      procedure)))) 
  
 (define (list-of-delayed-args-ex4.31 raw_parameters exps env) 
   (define (arg-value raw_parameter exp) 
     (if (pair? raw_parameter) 
       (cond ((eq? (cadr raw_parameter) 'lazy) 
              (delay-it-no-memo exp env)) 
             ((eq? (cadr raw_parameter) 'lazy-memo) 
              (delay-it exp env)) 
             (else (error "Unknow parameter type LIST-OF-DELAYED-ARGS:" (cadr raw_parameter)))) 
       (actual-value exp env))) 
   (if (no-operands? exps) 
     '() 
     (cons (arg-value (car raw_parameters) 
                      (first-operand exps)) 
           (list-of-delayed-args-ex4.31 (cdr raw_parameters) 
                                 (rest-operands exps) 
                                 env)))) 
  
 (define (delay-it-no-memo exp env) 
   (list 'thunk-no-memo exp env)) 
 (define (thunk-no-memo? obj) 
   (tagged-list? obj 'thunk-no-memo)) 
  
 (define (force-it-ex4.31 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) 
                      '()) 
            result)) 
         ((evaluated-thunk? obj) (thunk-value obj)) 
         ((thunk-no-memo? obj) (actual-value (thunk-exp obj) 
                                             (thunk-env obj))) 
         (else obj)))       ; forget unneeded env 
  
  
 (define apply apply-ex4.31) 
 (define force-it force-it-ex4.31) 
 (define procedure-parameters procedure-parameters-ex4.31) 
 (define list-of-delayed-args list-of-delayed-args-ex4.31) 
  
 ;(define (id x) 
 ;  (set! count (+ count 1)) x) 
 ; 
 ; (define count 0) 
 ; 
 ; (define (square x) (* x x)) 
 ; 
 ; (square (id 10)) 
 ; 
 ; count ; 1 
 ; 
 ; (define count 0) 
 ; 
 ; (define (square (x lazy)) (* x x)) 
 ; 
 ; (square (id 10)) 
 ; 
 ; count ; 2 
 ; 
 ; (define count 0) 
 ; 
 ; (define (square (x lazy-memo)) (* x x)) 
 ; 
 ; (square (id 10)) 
 ; 
 ; count ; 1 
 ; end exercise 4.31 
  

poly

I prefer to implement the lazy and lazy-memo as expressions, and the thunk selection funtions still work because the lazy and lazy-memo are still thunk, which I just change its tag.

 ;; the expression of lazy and lazy-memo 
 (define (lazy-parameter? p) 
   (and (pair? p) (eq? (cadr p) 'lazy) (null? (cddr p)))) 
  
 (define (lazy-memo-parameter? p) 
   (and (pair? p) (eq? (cadr p) 'lazy-memo) (null? (cddr p)))) 
  
 (define (lazy? obj) 
   (tagged-list? obj 'lazy)) 
  
 (define (lazy-memo? obj) 
   (tagged-list? obj 'lazy-memo)) 
  
 (define (eval-lazy-memo? obj) 
   (tagged-list? obj 'eval-lazy-memo)) 
  
 (define (delay-lazy exp env) 
   (list 'lazy exp env)) 
  
 (define (delay-lazy-memo exp env) 
   (list 'lazy-memo exp env)) 
  
 (define (force-it obj) 
   (cond ((lazy? obj) 
          (actual-value (thunk-exp obj) (thunk-env obj))) 
         ((lazy-memo? obj) 
          (let ((result (actual-value (thunk-exp obj) 
                                      (thunk-env obj)))) 
            (set-car! obj 'eval-lazy-memo) 
            (set-car! (cdr obj) result) 
            (set-cdr! (cdr obj) '()) 
            result)) 
         ((eval-lazy-memo? obj) 
          (thunk-value obj)) 
         (else obj))) 
  
 (define (actual-value exp env) 
   (force-it (eval exp env))) 
  
 ;; change some details 
 (define (apply procedure arguments env) 
   (cond ((primitive-procedure? procedure) 
          (apply-primitive-procedure 
           procedure 
           (list-of-arg-values arguments env))) 
         ((compound-procedure? procedure) 
          (let ((parameters (procedure-parameters procedure))) 
            (eval-sequence 
             (procedure-body procedure) 
             (extend-environment 
              (rib-statements parameters)                     ; changed 
              (list-of-delayed-args parameters arguments env) ; 
              (procedure-environment procedure))))) 
         (else 
          (error "Unknown procedure type -- APPLY" procedure)))) 
  
 (define (rib-statements parameters) 
   (if (null? parameters) 
       '() 
       (let ((first (car parameters)) (rest (cdr parameters))) 
         (cond ((or (lazy-parameter? first) 
                    (lazy-memo-parameter? first)) 
                (cons (car first) (rib-statements rest))) 
               ((variable? first) 
                (cons first (rib-statements rest))) 
               (else 
                (error "Bad Syntax" first)))))) 
  
 (define (list-of-delayed-args paras exps env)                ; changed 
   (if (no-operands? exps) 
       '() 
       (cons (cond ((lazy-parameter? (car paras)) 
                    (delay-lazy (first-operand exps) env)) 
                   ((lazy-memo-parameter? (car paras)) 
                    (delay-lazy-memo (first-operand exps) env)) 
                   (else 
                    (eval (first-operand exps) env))) 
             (list-of-delayed-args (cdr paras) (rest-operands exps) env)))) 

the other things remain the same.


revc

mceval.scm and leval.scm can be downloaded from "Complete Code from SICP 2/e"

The following procedures were written by modifying existing procedures or adding new procedures. I will mark it (modified? or added?) with comments.

  
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
 ;;;;;; for mceval.scm;;;;;;; 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
 (define (procedure-parameters p) (map (lambda (x) (if (pair? x) (car x) x)) (cadr p))) ;;; modified  
  
 ;;; return a list of keywords consisting of three elements(active, lazy or lazy-memo) 
 (define (procedure-keywords p) (map (lambda (x) (if (pair? x) (cadr x) 'active)) (cadr p))) ;;; added 
  
 ;;;;;;;;;;;;;;;;;;;;;;;;;;; 
 ;;;;;; for leval.scm;;;;;;; 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;; 
 (define (apply procedure operands env) 
   (cond ((primitive-procedure? procedure) 
          (apply-primitive-procedure 
           procedure 
           (list-of-arg-values operands env))) 
         ((compound-procedure? procedure) 
          (eval-sequence 
           (procedure-body procedure) 
           (extend-environment 
            (procedure-parameters procedure) 
            (list-of-keyworded-args procedure operands env) ; changed 
            (procedure-environment procedure)))) 
         (else 
          (error 
           "Unknown procedure type -- APPLY" procedure)))) ;; modified 
  
  
 ;;; return a list of arguments in which the operation to an operand depends on its corresponding keyword, which is either transforming it into a thunk or evaluating its value directly. 
  
 (define (list-of-keyworded-args procedure exps env) 
   (let loop ([keywords (procedure-keywords procedure)] 
              [operands exps] 
              [reversed-keyworded-args '()]) 
     (cond [(null? keywords) (reverse reversed-keyworded-args)] 
           [(eq? (car keywords) 'lazy) (loop (cdr keywords) 
                                             (cdr operands) 
                                             (cons (delay-it-nonmemo (first-operand operands) env) 
                                                        reversed-keyworded-args))] 
           [(eq? (car keywords) 'lazy-memo) (loop (cdr keywords) 
                                                  (cdr operands) 
                                                  (cons (delay-it-memo (first-operand operands) env) 
                                                        reversed-keyworded-args))] 
           [(eq? (car keywords) 'active) (loop (cdr keywords) 
                                               (cdr operands) 
                                               (cons (actual-value (first-operand operands) env) 
                                                     reversed-keyworded-args))] 
           [else (error "Unknown keyword" (car keywords))]))) ;; added 
  
  
 ;;; Representing thunks 
  
 ;; non-memoizing version of force-it 
  
 (define (force-it-nonmemo obj) 
   (actual-value (thunk-exp obj) (thunk-env obj))) ;; added 
  
 ;; memoizing version of force-it 
 (define (force-it-memo 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)) ;; added 
 ;; thunks 
  
 (define (delay-it-memo exp env) 
   (list 'thunk-memo exp env)) ;; added 
  
 (define (delay-it-nonmemo exp env) 
   (list 'thunk-nonmemo exp env)) ;; added 
  
 (define (thunk-memo? obj) 
   (tagged-list? obj 'thunk-memo)) ;; added 
  
 (define (thunk-nonmemo? obj) 
   (tagged-list? obj 'thunk-nonmemo)) ;; added 
  
  
 ;; generalized version of force-it 
  
 (define (force-it obj) 
   (cond ((thunk-memo? obj) (force-it-memo obj)) 
         ((thunk-nonmemo? obj) (force-it-nonmemo obj)) 
         ((evaluated-thunk? obj) (thunk-value obj)) 
         (else obj))) 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
 ;;;;;;;;;;;;;; test;;;;;;;;;;;;; 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
  
 ;;;;;;;;;;;; 
 ;;;;lazy;;;; 
 ;;;;;;;;;;;; 
  
 ;;; L-Eval input: 
 (define (try a (b lazy)) (if (= a 0) 1 b)) 
  
 ;;; L-Eval value: 
 ok 
  
 ;;; L-Eval input: 
 (try 0 1) 
  
 ;;; L-Eval value: 
 1 
  
 ;;; L-Eval input: 
 (try 0 (/ 1 0)) 
  
 ;;; L-Eval value: 
 1 
  
 ;;;;;;;;;;;;;;;; 
 ;;; lazy-memo;;; 
 ;;;;;;;;;;;;;;;; 
  
 ;;; L-Eval input: 
 (define (try a (b lazy-memo)) (if (= a 0) 1 b)) 
  
 ;;; L-Eval value: 
 ok 
  
 ;;; L-Eval input: 
 (try 0 (/ 1 0)) 
  
 ;;; L-Eval value: 
 1 
  
 ;;;;;;;;;;;;;;;; 
 ;;; non-lazy;;;; 
 ;;;;;;;;;;;;;;;; 
  
 ;;; L-Eval input: 
 (define (try a b) (if (= a 0) 1 b)) 
  
 ;;; L-Eval value: 
 ok 
  
 ;;; L-Eval input: 
 (try 0 (/ 1 0)) 
 Exception in /: undefined for 0 
  

Sphinxsky

Modification based on 4.2.2 in the book

  
  
  
  
 (define normal 'normal) 
 (define lazy 'lazy) 
 (define lazy-memo 'lazy-memo) 
  
  
 (define (is-lazy-memo? thunk) 
     (tagged-list? thunk lazy-memo)) 
  
  
 (define (is-lazy? thunk) 
     (tagged-list? thunk lazy)) 
  
  
 (define (type-arg arg) 
     (if (pair? arg) 
         (let ((type (cadr arg))) 
             (cond ((eq? type lazy) lazy) 
                 ((eq? type lazy-memo) lazy-memo) 
                 (else (error "Unknown parameter type -- TYPE-ARG" type)))) 
         normal)) 
  
  
 (define (get-arg arg) 
     (if (pair? arg) 
         (car arg) 
         arg)) 
  
  
  
 (define (list-of-delayed-args types exps env) 
     (if (no-operands? exps) 
         '() 
         (let ((first (first-operand exps)) 
               (type (car types))) 
             (cons 
                 (if (eq? normal type) 
                     (eval- first env) 
                     (cons type (delay-it first env))) 
                 (list-of-delayed-args (cdr types) (rest-operands exps) env))))) 
  
  
  
 (define (apply- procedure arguments env)    
     (cond ((primitive-procedure? procedure) 
             (apply-primitive-procedure 
                 procedure 
                 (list-of-arg-values arguments env))) 
         ((compound-procedure? procedure) 
             (eval-sequence 
                 (procedure-body procedure) 
                 (extend-environment 
                     (map get-arg (procedure-parameters procedure)) 
                     (list-of-delayed-args 
                         (map type-arg (procedure-parameters procedure)) 
                         arguments 
                         env) 
                     (procedure-environment procedure)))) 
         (else (error "Unknown procedure type -- APPLY" procedure)))) 
  
 (define (force-it-memo obj) 
     (cond ((thunk? obj) 
             (let ((result (actual-value 
                                 (thunk-exp obj) 
                                 (thunk-env obj)))) 
                 (set-car! obj 'evaluated-thunk) 
                 (set-car! (cdr obj) result) 
                 (set-cdr! (cdr obj) '()) 
                 result)) 
         ((evaluated-thunk? obj) 
             (thunk-value obj)) 
         (else obj))) 
  
 (define (actual-value exp- env) 
     (let ((result (eval- exp- env))) 
         (cond ((is-lazy-memo? result) 
                 (force-it-memo (cdr result))) 
             ((is-lazy? result) 
                 (force-it (cdr result))) 
             (else result))))