<< Previous exercise (4.33) | Index | Next exercise (4.35) >>
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.
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)))
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)
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))) ; =======================================================================
Felix021