naga:4-25 > 4-34

naga

Todo

4.26
4.30
4.32

Exercise 4.25

;; applicative-order では (factorial 5) の評価時に unless の３つの引数
;; (= n 1) (* n (factorial (- n 1))) 1 を予め評価しようとし、2番目の引数
;; の評価のために再度 (factorial 4) を評価するというループに入り、 n が
;; 負となっても評価のループをし続ける。
;; normal-order では (= n 1) の結果により (* n (factorial (- n 1))) を評価
;; するかどうか決めるので、期待通りに動作する。

Exercise 4.27

;;;L-Eval input:
(define count 0)
;;;L-Eval value:
ok
;;;L-Eval input:
(define (id x) (set! count (+ count 1)) x)
;;;L-Eval value:
ok
;;;L-Eval input:
(define w (id (id 10)))
;; ここで、 外側の id の実行で x に '(thunk (id 10) env) が対応付けられ、
;; count に 1 が格納され、
;; id の値として x の値が返されるので、
;; w に '(thunk (id 10) env) が格納される。
;;;L-Eval value:
ok
;;;L-Eval input:
count
;;;L-Eval value:
1
;;;L-Eval input:
w
;; ここで、w の値の評価で
;; count に 2 が格納され、
;; 10 が返される。
;;;L-Eval value:
10
;;;L-Eval input:
count
;;;L-Eval value:
2

Exercise 4.28

;;;;;L-Eval input:
;;(define (calc f m n)
;;  (f m n))
;;;;;L-Eval value:
;;ok
;;;;;L-Eval input:
;;(calc + 4 6)              ;f - (thunk + env)  m - (thunk 4 env)  n - (thunk 6 env)
;;;;;L-Eval value:          ;と格納されるので actual-value を使って
;;10                        ;operator を得る必要がある。

Exercise 4.29

;;gosh> (Lscheme)
;;memoization on
;;;;;L-Eval input:
;;(load "id")
;;;;;L-Eval value:
;;ok
;;;;;L-Eval input:
;;(define (square x) (* x x))
;;;;;L-Eval value:
;;ok
;;;;;L-Eval input:
;;(square (id 10))        ;x に '(thunk id 10) が格納され、 (* x x) の評価が始まり、
;;;;;L-Eval value:        ;x の actual-value を得る段階で count が 1 になる。
;;100                     ;memoization が on の時は、もう1つの x の値は今求めた値を
;;;;;L-Eval input:        ;使うので、 count は 1 のまま。
;;count                   ;memoization が off の時は、再度 x の actual-value を求める
;;;;;L-Eval value:        ;ので count が 2 となる。 
;;1
;;;;;L-Eval input:
;;(exit)
;;bye
;;gosh> (Lscheme 'without-memo)
;;memoization off
;;;;;L-Eval input:
;;(load "id")
;;;;;L-Eval value:
;;ok
;;;;;L-Eval input:
;;(define (square x) (* x x))
;;;;;L-Eval value:
;;ok
;;;;;L-Eval input:
;;(square (id 10))
;;;;;L-Eval value:
;;100
;;;;;L-Eval input:
;;count
;;;;;L-Eval value:
;;2

Exercise 4.30

Exercise 4.31

;; 方針
;; 1. define は変更しない。lazy、lazy-memo のパラメータオプションはそのまま
;;    仮引数の中に入れたままで procedure に記憶する。
;; 2. Apply の 環境の拡張時に パラメータの有無にしたがって、delay / actual-
;;    value を実引数に作用させてから拡張を行う。
;; 3. Lazy Evaluation で行った変更はすべて採用し、それに以下を追加する。 
;; 4. force-it で memo 化をおこなう。
;; thunk は (lazy exp env) (lazy-memo exp env) (evaluated-thunk exp-value '())
;; の 3 種類。

;; Eval の application? を変更
;;((application? exp)
;; (Apply (actuall-value (operator exp) env)
;;       (operands exp)
;;       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-with-delay
           (procedure-parameters procedure)
           arguments 
           (procedure-environment procedure))))
        (else
         (Error
          "Unknown procedure type -- APPLY" procedure))))
(define (extend-environment-with-delay vars vals env)
  (define (iter vars vals rvars rvals)
    (if (null? vars)
        (cons (make-frame (reverse rvars) (reverse rvals)) env)
        (iter (cdr vars)
              (cdr vals)
              (cons (if (not (pair? (car vars)))
                        (car vars)
                        (caar vars))
                    rvars)
              (cons (delay-or-actual-value (car vars) (car vals) env)
                    rvals))))
;
  (if (not (= (length vars) (length vals)))
      (if (< (length vars) (length vals))
          (Error "Too many arguments supplied" vars vals)
          (Error "Too few arguments supplied" vars vals)))
  (iter vars vals '() '()))
(define (delay-or-actual-value var val env)
  (cond ((not (pair? var)) (actual-value val env))
        ((or (eq? (cadr var) 'lazy) (eq? (cadr var) 'lazy-memo))
         (list (cadr var) val env))
         (else (Error "Unknown parameter option" (cadr var)))))
;driver-loop のactual-value
(define (lazy-memo? obj) (tagged-list? obj 'lazy-memo))
(define (lazy? obj) (tagged-list obj? 'lazy))
(define (force-it obj)
  (cond ((lazy-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) '())               ; forget unneeded env
           result))
         ((evaluated-thunk? obj) (thunk-value obj))
         ((lazy? obj) (actual-value (thunk-exp obj) (thunk-env obj)))
         (else obj)))
;;;;;M-Eval input:
;;(define (square (x lazy)) (* x x ))
;;;;;M-Eval value:
;;ok
;;;;;M-Eval input:
;;(square (id 10))
;;;;;M-Eval value:
;;100
;;;;;M-Eval input:
;;count
;;;;;M-Eval value:
;;2
;;;;;M-Eval input:
;;(set! count 0)
;;;;;M-Eval value:
;;ok
;;;;;M-Eval input:
;;(define (square (x lazy-memo)) (* x x ))
;;;;;M-Eval value:
;;ok
;;;;;M-Eval input:
;;(square (id 10))
;;;;;M-Eval value:
;;100
;;;;;M-Eval input:
;;count
;;;;;M-Eval value:
;;1

Exercise 4.32

Exercise 4.33

(define (Cons x y)
  (lambda (m) (m x y)))
(define (Car z)
  (if (Pair? z)
      (z (lambda (p q) p))
      (Error "pair required, but got " z)))
(define (Cdr z)
  (if (Pair? z)
      (z (lambda (p q) q))
      (Error "pair required, but got " z)))
;; ex4_33 ->
;; LazyList用の car、cdr、cons をそれぞれ Car、Cdr、Cons としてLazy Evaluatorの
;; 手続きとして実装したので、list から lazylist への変換も手続きとして用意する。
(define (list->lazylist exp)
  (define (make-lazylist l)
    (if (null? l)
        '()
        (Cons (car l)
              (make-lazylist (cdr l)))))
  (if (not (pair? exp))
      exp
      (make-lazylist exp)))
;; <- ex4_33
;;;;;L-Eval input:
;;(define nums (list->lazylist '(2 4 6)))
;;;;;L-Eval value:
;;ok
;;;;;L-Eval input:
;;(Car nums)
;;;;;L-Eval value:
;;2
;;;;;L-Eval input:
;;(Car (Cdr nums))
;;;;;L-Eval value:
;;4

Exercise 4.34

(define (Cons x y)
  (lambda (m) (m x y)))
(define (Car z)
  (if (Pair? z)
      (z (lambda (p q) p))
      (Error "pair required, but got " z)))
(define (Cdr z)
  (if (Pair? z)
      (z (lambda (p q) q))
      (Error "pair required, but got " z)))
(define Pair (Cons x y))
(define (Pair? p)
  (and (pair? p)
       (> (length p) 3)
       (equal? (car p) (car Pair))
       (equal? (cadr p) (cadr Pair))
       (equal? (caddr p) (caddr Pair))))
;; ex4_34 ->
;; display-lazylist を Lazy Evaluator の手続きとして用意する。 
;; lazylist は Cons によってしか作成できないという制限を付加する。つまり、
;; Cons の定義が (define (Cons x y) (lambda (m) (m x y))) で仮引数が x と y
;; であることとを利用する。
(define (display-lazylist exp)
  (define refs '())
  (define (ref? pair) (if (memq pair refs)
                          (- (length (memq pair refs)) 1) #f))
  (define (ref! pair) (set! refs (cons pair refs)))
  (define refeds '())
  (define (refed? pair) (if (memq pair refeds)
                            (length refs) #f))
  (define (refed! pair) (set! refeds (cons pair refeds)))
  (define marks '())
  (define (mark? pair) (memq pair marks))
  (define (mark! pair) (set! marks (cons pair marks)))
;
; リスト中の多重参照されているセルを refeds に登録  
  (define (recm l)
    (cond ((not (Pair? l)) 'end)
          ((mark? l) (refed! l) 'end)
          (else
           (mark! l)
           (recm (Car l))
           (recm (Cdr l)))))
;
; セルが多重参照されているかどうかを refeds で確認し、参照されている
; なら参照可（#n=）としセルを refs に登録。セルの car、cdr が多重参照
; を参照しているかを ref で確認し、参照しているなら参照 (#n#) とする。
  (define (recd l pf)
    (cond ((not (Pair? l)) (display l))
          (else
           (let ((n (refed? l)))
             (cond (n (cond ((not pf) (display " . ") (set! pf #t)))
                      (display "#") (display n) (display "=") (display "(")
                      (ref! l))
                   (else (if pf
                             (display "(")
                             (display " "))))
             (let ((ncar (ref? (Car l)))
                   (ncdr (ref? (Cdr l))))
               (cond (ncar (display "#") (display ncar) (display "#"))
                     (else (recd (Car l) #t)))
               (cond (ncdr (display " . #") (display ncdr) (display "#"))
                     ((null? (Cdr l)) (display ""))
                     ((Pair? (Cdr l)) (recd (Cdr l) #f))
                     (else (display " . ") (recd (Cdr l) #f))))
             (if pf (display ")"))))))
;
  (recm exp)
  (recd exp #t))
;; <- ex4_34
;;(define a (Cons 1 b))
;;(define b (Cons d c))
;;(define c (Cons a '()))
;;(define d (Cons b c))
;;;;;L-Eval input:
;;(display-lazylist a)
;;#0=(1 . #1=((#1# . #2=(#0#)) . #2#));;;L-Eval value:
;;#<undef>