sicp-ex-4.34



<< Previous exercise (4.33) | Index | Next exercise (4.35) >>


Felix021

  
  
  
 ;; based on 4-33 
  
 (map (lambda (name obj) 
         (define-variable!  name (list 'primitive obj) the-global-environment)) 
     (list 'raw-cons 'raw-car 'raw-cdr) 
     (list cons car cdr)) 
  
 (actual-value 
     '(begin 
  
         (define (cons x y) 
             (raw-cons 'cons (lambda (m) (m x y)))) 
  
         (define (car z) 
             ((raw-cdr z) (lambda (p q) p))) 
  
         (define (cdr z) 
             ((raw-cdr z) (lambda (p q) q))) 
     ) 
     the-global-environment) 
  
 (define (disp-cons obj depth) 
     (letrec ((user-car (lambda (z) 
                 (force-it (lookup-variable-value 'x (procedure-environment (cdr z)))))) 
              (user-cdr (lambda (z) 
                 (force-it (lookup-variable-value 'y (procedure-environment (cdr z))))))) 
         (cond 
             ((>= depth 10) 
                 (display "... )")) 
             ((null? obj) 
                 (display "")) 
             (else 
                 (let ((cdr-value (user-cdr obj))) 
                     (display "(") 
                     (display (user-car obj)) 
                     (if (tagged-list? cdr-value 'cons) 
                         (begin 
                             (display " ") 
                             (disp-cons cdr-value (+ depth 1))) 
                         (begin 
                             (display " . ") 
                             (display cdr-value))) 
                     (display ")")))))) 
  
 (define (user-print object) 
     (if (compound-procedure? object) 
         (display 
             (list 'compound-procedure 
                 (procedure-parameters object) 
                 (procedure-body object) 
                 '<procedure-env>)) 
         (if (tagged-list? object 'cons) 
             (disp-cons object 0) 
             (display object)))) 
  
 (driver-loop) 

awkravchuk

Arguably a bit more elegant solution:

  
 (define (setup-environment) 
     (let ((initial-env 
            (extend-environment (primitive-procedure-names) 
                                (primitive-procedure-objects) 
                                the-empty-environment))) 
         (define-variable! 'true true initial-env) 
         (define-variable! 'false false initial-env) 
         (eval 
          '(begin 
               (define (cons cons-first cons-rest) 
                   (lambda (m) (m cons-first cons-rest))) 
               (define (car z) 
                   (z (lambda (p q) p))) 
               (define (cdr z) 
                   (z (lambda (p q) q))) 
               (define (null? c) 
                   (equal? c '()))) 
          initial-env) 
         initial-env)) 
  
  
 (define (lookup-variable-value* var env) 
     (define (env-loop env) 
         (define (scan vars vals) 
             (cond ((null? vars) 
                    (env-loop (enclosing-environment env))) 
                   ((eq? var (car vars)) 
                    (car vals)) 
                   (else (scan (cdr vars) (cdr vals))))) 
         (if (eq? env the-empty-environment) 
             '() 
             (let ((frame (first-frame env))) 
                 (scan (frame-variables frame) 
                       (frame-values frame))))) 
     (env-loop env)) 
  
 (define (lazy-cons? procedure) 
     (let ((env (procedure-environment procedure))) 
         (and (not (null? (lookup-variable-value* 'cons-first env))) 
              (not (null? (lookup-variable-value* 'cons-rest env)))))) 
  
 (define (lazy-cons-print object) 
     (define (lazy-cons-print-internal object n) 
         (if (not (null? object)) 
             (let* ((env (procedure-environment object)) 
                    (first (lookup-variable-value* 'cons-first env)) 
                    (rest (lookup-variable-value* 'cons-rest env))) 
                 (if (> n 10) 
                     (display "...") 
                     (begin 
                         (let ((first-forced (force-it first))) 
                             (if (and (compound-procedure? first-forced) 
                                      (lazy-cons? first-forced)) 
                                 (lazy-cons-print first-forced) 
                                 (display first-forced))) 
                         (display " ") 
                         (lazy-cons-print-internal 
                          (force-it rest) 
                          (+ n 1))))))) 
     (display "(") 
     (lazy-cons-print-internal object 0) 
     (display ")")) 
  
 (define (user-print object) 
     (if (compound-procedure? object) 
         (if (lazy-cons? object) 
             (lazy-cons-print object) 
             (display (list 'compound-procedure 
                            (procedure-parameters object) 
                            (procedure-body object) 
                            '<procedure-env>))) 
         (display object))) 
  
 ;; To test: 
 ;; '(a b (c d)) 
 ;; (define ones (cons 1 ones)) 
 ;; ones 
  

Just to pose the question, wouldn't this implementation regard any procedure with an environment containing 'cons-first and 'cons-rest as a cons'ed value, as illustrated below?

  
 (define (make-fake-cons)  
   (define cons-first 1)  
   (define cons-rest 2)   
   (lambda (m) 'fooled-you)) 
  
 (define a-fake-cons (make-fake-cons)) 
  
 (lazy-cons? a-fake-cons) ; true, even though it really isn't 
  

Perhaps the interpreter can be meaningfully adapted to handle this situation.



davl

Less nesting

  
  
  
 (define (serialize-lazy-pairs object depth) 
   (if (<= depth 9) ;; THRESHOLD HERE 
     (list 'lazy-pair 
           (serialize-object (actual-value 'x (procedure-environment object)) (+ depth 1)) 
           '. 
           (serialize-object (actual-value 'y (procedure-environment object)) (+ depth 1))) 
     (list 'lazy-pair "..."))) 
  
 (define (serialize-compound-procedure object) 
   (if (compound-procedure? object) 
     (list 'compound-procedure 
           (procedure-parameters object) 
           (procedure-body object) 
           '<procedure-env>) 
     object)) 
  
 (define (lazy-pair? object) 
   '*varies*) 
  
 (define (serialize-object object depth) 
   (if (compound-procedure? object) 
     (if (lazy-pair? object) 
       (serialize-lazy-pairs object (+ 1 depth)) 
       (serialize-compound-procedure object)) 
     object)) 
  
 (define (user-print object) 
   (newline) 
   (display (serialize-object object 0))) 
  

revc

Print cyclic or infinite list in some reasonable way —— with tag replacements.

  
 ;; Exercise 4.34 
  
 (define primitive-procedures 
   (list (list 'car-in-underly-scheme car)   ; preserved but renamed 
         (list 'cdr-in-underly-scheme cdr)   ; preserved but renamed 
         (list 'cons-in-underly-scheme cons) ; preserved but renamed 
         (list 'null? null?) 
         (list 'list list) 
         (list '+ +) 
         (list '- -) 
         (list '* *) 
         (list '/ /) 
         (list '= =) 
         (list 'newline newline) 
         (list 'display display) 
 ;;      more primitives 
         )) 
  
 (define the-global-environment (setup-environment)) 
  
 ;;; represent pair of META-CIRCULAR as pair of SCHEME which is composed of a tag 'cons 
 ;;; and a lexical closure(i.e. a procedure of META-CIRCULAR). 
 (eval '(define (cons x y) 
          (cons-in-underly-scheme 'pair? (lambda (m) (m x y)))) the-global-environment) 
  
 (eval '(define (car z) 
          ((cdr-in-underly-scheme z) (lambda (p q) p))) the-global-environment) 
  
 (eval '(define (cdr z) 
          ((cdr-in-underly-scheme z) (lambda (p q) q))) the-global-environment) 
  
 ;;; predicate that check if an object is a pair of META-CIRCULAR 
 (define (meta-pair? object) 
   (tagged-list? object 'pair?)) 
  
 ;;; print pair of META-CIRCULAR 
 (define (print-pair object) 
  
   (define counter 0)                    ; the number of pairs which were revisited 
  
   ;; use a pair as key and the correspoding number of revisited times as value 
   ;; when the recursion to CAR and CDR of some pair ends, check if VALUE > 0, 
   ;; change VALUE to counter, and then increment counter by 1 
   ;; NOTE: We do not add things which are not pair into hashtable 
   (define visited (make-hash-table)) 
  
   (define (put k v) (put-hash-table! visited k v))   ; an interface to visited for convenience 
   (define (get k) (get-hash-table visited k #f))     ; an interface to visited for convenience 
   (define (remove k) (remove-hash-table! visited k)) ; an interface to visited for convenience 
  
   ;; convert pair of META-CIRCULAR into pair of SCHEME for which we can handle more conveniently. 
   ;; The struct of converted pair is as follows: 
  
   ;;========================================================================== 
  
   ;; Printable-pair ::= ('be-referred-as Pair-of-META-CIRCULAR X Y)) 
   ;;                ||  ('refer-to Pair-of-META-CIRCULAR '*CAR* '*CDR*) 
   ;;                ||  ('just-pair Pair-of-META-CIRCULAR X Y) 
   ;;                ||  Not-pair 
  
   ;; X ::= #<Thunk CAR> 
   ;;   ||  Printable-pair 
  
   ;; Y ::= #<Thunk CDR> 
   ;;   ||  Printable-pair 
  
   ;;========================================================================== 
  
   (define (convert-printable-pair object) 
  
     ;; if object is evaluated-thunk, then return its value, otherwise return a tag like #<Thunk {alternative}> 
     (define (thunk-or-value object alternative) 
       (if (evaluated-thunk? object) 
           (convert-printable-pair (thunk-value object)) 
           (string-append "#<thunk " alternative ">"))) 
  
     ;; we visit some pair in visited table again, so change the its value to the desired string 
     (define (visit-again! object) 
       (put object (+ 1 (get object))) 
       (list 'refer-to object '*CAR* '*CDR*)) 
  
     (if (meta-pair? object) 
         (cond [(get object) (visit-again! object)]      ; visit again! return a string like "#{counter}" 
               [else 
                (put object 0)                           ; the first visit! 
                (let ([x (thunk-or-value (eval 'x (procedure-environment (cdr object))) "CAR")] 
                      [y (thunk-or-value (eval 'y (procedure-environment (cdr object))) "CDR")]) 
                  (if (zero? (get object))                       ; no inner elements refer to it 
                      (begin 
                        (remove object)                          ; no tagging required 
                        (list 'just-pair object x y)) 
  
                      (begin 
                        (put object counter) 
                        (set! counter (+ counter 1))             ; increment counter 
                        (list 'be-referred-as object x y))))])   ; return the processed pair 
         object))                                                ; not pair, return directly 
  
   (define (be-referred? object) 
     (tagged-list? object 'be-referred-as)) 
  
   (define (referer? object) 
     (tagged-list? object 'refer-to)) 
  
   ;; print printable pair 
   ;; We need consider three cases: 
   ;; 1. a pair refers to its outer list, which will be printed as #{counter} where counter is the corresponding 
   ;; serial number of its outer list. 
   ;; 2. a pair is referenced by its inner elements, which will be printed as #{counter}=(X . Y) where counter is 
   ;; its serial number 
   ;; 3. a normal pair which does not refer to another pair and is not referenced by others, that will be printed 
   ;; as (X . Y) 
   ;; NOTE: if Y is a pair, then print-pair won't print the preceding ". "  and the parentheses enclosing it. 
  
   (define (print-pair pair with-paren) 
     (let* ([left (if with-paren "(" "")] 
            [right (if with-paren ")" "")] 
            [val (get (cadr pair))] 
            [x (list-ref pair 2)] 
            [y (list-ref pair 3)] 
            [tag (if val (string-append "#" (number->string val)) val)] 
            [middle (if (null? y) "" " ")]) 
  
       (cond [(be-referred? pair) (display tag) (display "=") (display left)] 
             [(referer? pair) (display tag) (display "#")] 
             [else (display left)]) 
  
       (cond [(not (referer? pair)) 
               (cond [(pair? x) (print-pair x #t)] 
                     [else (display x)]) 
  
               (display middle) 
  
               (cond [(be-referred? y) (print-pair y #t)] 
                     [(referer? y) (display ". ") (print-pair y #f)] 
                     [(pair? y) (print-pair y #f)] 
                     [(null? y) (display "")] 
                     [else y (display ". ") (display y)]) 
  
               (display right)] 
           ))) 
  
   (print-pair (convert-printable-pair object) #t)) 
  
 (define (user-print object) 
   (cond [(meta-pair? object) (print-pair object)] ; the clause for pair of META-CIRCULAR 
         [(compound-procedure? object) 
          (display (list 'compound-procedure 
                         (procedure-parameters object) 
                         (procedure-body object) 
                         '<procedure-env>))] 
         [else (display object)])) 
  
 ;;; Exercise 4.34 additional procedures 
 (eval '(define (list-ref items n) 
          (if (= n 0) 
              (car items) 
              (list-ref (cdr items) (- n 1)))) the-global-environment) 
  
 (eval '(define (map proc items) 
          (if (null? items) 
              '() 
              (cons (proc (car items)) 
                    (map proc (cdr items))))) the-global-environment) 
  
 (eval '(define (scale-list items factor) 
          (map (lambda (x) (* x factor)) 
               items)) the-global-environment) 
  
 (eval '(define (add-lists list1 list2) 
          (cond ((null? list1) list2) 
                ((null? list2) list1) 
                (else (cons (+ (car list1) (car list2)) 
                            (add-lists (cdr list1) (cdr list2)))))) the-global-environment) 
  
 (eval '(define ones (cons 1 ones)) the-global-environment) 
  
 (eval '(define integers (cons 1 (add-lists ones integers))) the-global-environment) 
  
 (eval '(define (for-each proc items) 
          (if (null? items) 
              'done 
              (begin (proc (car items)) 
                     (for-each proc (cdr items))))) the-global-environment) 
  
  
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
 ;;;;;;;;;;; test ;;;;;;;;;;;;;;; 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
  
 ;;;;;;;;;;;;;; 
 ;;; ones ;;;;; 
 ;;;;;;;;;;;;;; 
  
 ;;; L-Eval input: 
 ones 
  
 ;;; L-Eval value: 
 (#<thunk CAR> . #<thunk CDR>) 
  
 ;;; L-Eval input: 
 (car ones) 
  
 ;;; L-Eval value: 
 1 
  
 ;;; L-Eval input: 
 ones 
  
 ;;; L-Eval value: 
 (1 . #<thunk CDR>) 
  
 ;;; L-Eval input: 
 (cdr ones) 
  
 ;;; L-Eval value: 
 #0=(1 . #0#) 
  
  
 ;;;;;;;;;;;;;;;;;; 
 ;;; integers ;;;;; 
 ;;;;;;;;;;;;;;;;;; 
  
 ;;; L-Eval input: 
 (list-ref integers 3) 
  
 ;;; L-Eval value: 
 4 
  
 ;;; L-Eval input: 
 integers 
  
 ;;; L-Eval value: 
 (1 2 3 4 . #<thunk CDR>) 
  
 ;;; L-Eval input: 
 (list-ref integers 20) 
  
 ;;; L-Eval value: 
 21 
  
 ;;; L-Eval input: 
 integers 
  
 ;;; L-Eval value: 
 (1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 . #<thunk CDR>) 
  
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
 ;;;;  not cyclic but referenced ;;;;;; 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
 ;;; L-Eval input: 
 (define s (cons 1 2)) 
  
 ;;; L-Eval value: 
 ok 
  
 ;;; L-Eval input: 
 (define w (cons s s)) 
  
 ;;; L-Eval value: 
 ok 
  
 ;;; L-Eval input: 
 (car s) 
  
 ;;; L-Eval value: 
 1 
  
 ;;; L-Eval input: 
 (cdr s) 
  
 ;;; L-Eval value: 
 2 
  
 ;;; L-Eval input: 
 (car w) 
  
 ;;; L-Eval value: 
 (1 . 2) 
  
 ;;; L-Eval input: 
 (cdr w) 
  
 ;;; L-Eval value: 
 (1 . 2) 
  
 ;;; L-Eval input: 
 w 
  
 ;;; L-Eval value: 
 ((1 . 2) 1 . 2) 
  
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
 ;;;; list: special pair ;;;; 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
  
 ;;; L-Eval input: 
 (define lst '(1 2 3 4)) 
  
 ;;; L-Eval value: 
 ok 
  
 ;;; L-Eval input: 
 (for-each (lambda (x) (display x)) lst) 
 1234 
 ;;; L-Eval value: 
 done 
  
 ;;; L-Eval input: 
 lst 
  
 ;;; L-Eval value: 
 (1 2 3 4) 
  
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
 ;;; Multiplex cycle ;;;;;;;;;;;;; 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
  
                                                    
                             e3                     
                      +-------|-------+             
                      |       |       |             
 +------------------> |   +   |   +---------------+ 
 |                    |   |   |       |           | 
 |                    +---|---|-------+           | 
 |                        |                       | 
 |                        v                       v 
 |              +-------|-------+                 3 
 |           e2 |       |       |                   
 |          +-> |   +   |   +-------------+         
 |          |   |   |   |       |         |         
 |          |   +---|---|-------+         |         
 |          |       |                     |         
 |          |  e1   v                     |         
 |      +---|---|-------+                 |         
 |      |   |   |       |                 v         
 |      |   +   |   +   |                 2         
 |      |       |   |   |                           
 |      +-------|---|---+                           
 |                  |                               
 |                  |                               
 |                  |                               
 |                  |                               
 +------------------+                               
  
 ;;; L-Eval input: 
 (define c1 (cons 1 1)) 
  
 ;;; L-Eval value: 
 ok 
  
 ;;; L-Eval input: 
 (define c2 (cons c1 2)) 
  
 ;;; L-Eval value: 
 ok 
  
 ;;; L-Eval input: 
 (define c3 (cons c2 3)) 
  
 ;;; L-Eval value: 
 ok 
  
 ;;; L-Eval input: 
 (define c1 (cons c2 c3)) 
  
 ;;;;;; 
 Skip the access section 
 ;;;;;; 
  
 ;;; L-Eval input: 
 c1 
  
 ;;; L-Eval value: 
 #0=((#0# . 2) (#0# . 2) . 3) 
  
 ;;; L-Eval input: 
 c3 
  
 ;;; L-Eval value: 
 #1=(#0=((#0# . #1#) . 2) . 3) 

Sphinxsky

a simpler implementation it is modified on the basis of 4.33

  
  
  
  
  
  
 ; add primitive procedure identity 
 (define primitive-procedures 
     (list 
         (list 'null?- null?) 
         (list 'display- display) 
         (list 'newline- newline) 
         (list '= =) 
         (list '/ /) 
         (list '- -) 
         (list '* *) 
         (list '+ +) 
         (list 'identity (lambda (x) x)))) 
  
  
  
 ; define list expression 
 ; ======================================================================= 
 (define (is-list? exp-) 
     (tagged-list? exp- 'list-)) 
  
 (define (is-empty-list? exp-) 
     (null? exp-)) 
  
 (define (get-list-items exp-) 
     (cdr exp-)) 
  
 (define (make-cons exp-car exp-cdr) 
     (list 'cons- exp-car exp-cdr)) 
  
 (define (make-list items) 
     (if (null? items) 
         items 
         (make-cons 
             (car items) 
             (make-list (cdr items))))) 
 ; ======================================================================= 
  
 ; add list operation 
 ; ======================================================================= 
 (define list-operation-exp-1 
     '(define- (cons- x y) 
         (define- x-Evaluated? false-) 
         (define- y-Evaluated? false-)         
         (define- x-Evaluated '()) 
         (define- y-Evaluated '()) 
         (lambda- (__cons-signal__) 
             (cond- ((= __cons-signal__ 0) 
                     (if- x-Evaluated? 
                         x-Evaluated 
                         (begin- 
                             (set!- x-Evaluated (identity x)) 
                             (set!- x-Evaluated? true-) 
                             x-Evaluated))) 
                 ((= __cons-signal__ 1) 
                     (if- y-Evaluated? 
                         y-Evaluated 
                         (begin- 
                             (set!- y-Evaluated (identity y)) 
                             (set!- y-Evaluated? true-) 
                             y-Evaluated))) 
                 ((= __cons-signal__ 2) 
                     (if- x-Evaluated? 
                         x-Evaluated 
                         'promise-head)) 
                 ((= __cons-signal__ 3) 
                     (if- y-Evaluated? 
                         y-Evaluated 
                         'promise-tail)))))) 
  
 (define list-operation-exp-2 
     '(define- (car- z) (z 0))) 
  
 (define list-operation-exp-3 
     '(define- (cdr- z) (z 1))) 
  
 (define list-operation-exp-4 
     '(define- (list-ref- items n) 
         (if- (= n 0) 
             (car- items) 
             (list-ref- (cdr- items) (- n 1))))) 
              
 (define list-operation-exp-5 
     '(define- (map- proc items) 
         (if- (null?- items) 
             items 
             (cons- 
                 (proc (car- items)) 
                 (map- proc (cdr- items)))))) 
  
 (define list-operation-exp-6 
     '(define- (scale-list items factor) 
         (map- 
             (lambda- (x) (* x factor)) 
             items))) 
  
 (define list-operation-exp-7 
     '(define- (add-lists list1 list2) 
         (cond- ((null?- list1) list2) 
             ((null?- list2) list1) 
             (else- 
                 (cons- 
                     (+ (car- list1) (car- list2)) 
                     (add-lists (cdr- list1) (cdr- list2))))))) 
  
 (define list-operation-exp-8 
     '(define- (matrix-ref matrix x y) 
         (list-ref- (list-ref- matrix x) y))) 
  
 (define list-operation-exp-9 
     '(define- (append- x y) 
         (if- (null?- x) 
             y 
             (cons- (car- x) 
                    (append- (cdr- x) y))))) 
  
 ; import interpreter 
 (for-each 
     (lambda (exp-) 
         (actual-value exp- the-global-environment)) 
     (list 
         list-operation-exp-1 
         list-operation-exp-2 
         list-operation-exp-3 
         list-operation-exp-4 
         list-operation-exp-5 
         list-operation-exp-6 
         list-operation-exp-7 
         list-operation-exp-8 
         list-operation-exp-9)) 
 ; ======================================================================= 
  
  
  
 ; predicate to add an empty list 
 (define (eval- exp- env) 
     (cond ((self-evaluating? exp-) exp-) 
         ((variable? exp-) (lookup-variable-value exp- env)) 
         ((quoted? exp-) (eval-quotation exp- env)) 
         ((is-empty-list? exp-) '()) 
         ((is-list? exp-) (eval- (make-list (get-list-items exp-)) env)) 
         ((assignment? exp-) (eval-assignment exp- env)) 
         ((definition? exp-) (eval-definition exp- env)) 
         ((if? exp-) (eval-if exp- env)) 
         ((lambda? exp-) 
             (make-procedure 
                 (lambda-parameters exp-) 
                 (lambda-body exp-) 
                 env)) 
         ((begin? exp-) (eval-sequence (begin-actions exp-) env)) 
         ((cond? exp-) (eval- (cond->if exp-) env)) 
         ((application? exp-) 
             (apply- 
                 (actual-value (operator exp-) env) 
                 (operands exp-) 
                 env)) 
         (else (error "Unknown expression type -- EVAL" exp-)))) 
  
  
  
 ; printing result processing 
 ; ======================================================================= 
 (define (make-compound-procedure-show cp) 
     (list 
         'compound-procedure 
         (procedure-parameters cp) 
         (procedure-body cp) 
         '<procedure-env>)) 
  
 (define (is-cons? object) 
     (if (compound-procedure? object) 
         (let ((parameters (procedure-parameters object))) 
             (equal? parameters (list '__cons-signal__))) 
         false)) 
  
 (define (make-cons-show c) c) 
  
 (define (make-show object) 
     (cond ((is-cons? object) 
             (make-cons-show object)) 
         ((compound-procedure? object) 
             (make-compound-procedure-show object)) 
         (else object))) 
  
 (define (make-cons-show c) 
     (let* ((cons-env (procedure-environment c)) 
            (cons-head (apply- c (list 2) cons-env)) 
            (cons-tail (apply- c (list 3) cons-env)))  
         (list 
             (make-show cons-head) 
             (make-show cons-tail)))) 
  
 (define (user-print object) 
     (display (make-show object))) 
 ; =======================================================================