exercise 4.18

続き

ex4.18

やってみる前に解答。
4.18の例だと、dyの定義時にyが*unassigned*でエラー。
ようするに、この例だと、内部定義を相互に行えないというかなんというか。

まぁということで実行してみるか。
まず、delayとかの準備

(define (delay-exp exp) (cadr exp))
;;メモ化無しver
;;(define (delay->lambda exp) (make-lambda '() (list (delay-exp exp))))
(define (delay->memo-lambda exp)
  (list 'memo-proc (make-lambda '() (list (delay-exp exp)))))
(put 'eval 'delay (lambda (exp env)
                    (eval (delay->memo-lambda exp) env)))
                    
(define (cons-stream->combination exp)
  (list 'cons (cadr exp) (list 'delay (caddr exp))))
(put 'eval 'cons-stream
     (lambda (exp env)
       (eval (cons-stream->combination exp) env)))

で、こんどは以下のコードを(driver-loop)のあとに読みこませる。
読みこませるのはEmacsで、C-x h で選択後、C-c C-rとやればおk。
(・・・でいいよね)

(define (memo-proc proc)
  (let ((already-run false) (result false))
    (lambda ()
      (if (not already-run)
          (begin (set! result (proc))
                 (set! already-run true)
                 result)
          result))))


(define the-empty-stream '())

(define (stream-null? s)
  (eq? s the-empty-stream))

(define (stream-car stream) (car stream))
(define (stream-cdr stream) (force (cdr stream)))

(define (force delayed-object)
  (delayed-object))

(define (stream-map proc s)
  (if (stream-null? s)
      the-empty-stream
      (cons-stream (proc (stream-car s))
                   (stream-map proc (stream-cdr s)))))

(define (stream-map2 proc s1 s2)
  (if (stream-null? s1)
      the-empty-stream
      (cons-stream (proc (stream-car s1)(stream-car s2))
                   (stream-map2 proc (stream-cdr s1)(stream-cdr s2)))))

(define (stream-ref s n)
  (if (= n 0)
      (stream-car s)
      (stream-ref (stream-cdr s) (- n 1))))

(define (scale-stream stream factor)
  (stream-map (lambda (x) (* x factor)) stream))

(define (add-streams s1 s2)
  (stream-map2 + s1 s2))


(define (integral delayed-integrand initial-value dt)
  (define int
    (cons-stream initial-value
                 (let ((integrand (force delayed-integrand)))
                   (add-streams (scale-stream integrand dt)
                                int))))
  int)

(define (solve f y0 dt)
  (define y (integral (delay dy) y0 dt))
  (define dy (stream-map f y))
  y)

;;変更後のlet

(define alphabets-list '(a b c d e f g h i j k l m n))
(define (scan-out-defines body)
  (define (iter vars vals alphabets body-remainig alphabets-remaining)
    (let ((first (first-exp body-remainig)))
      (if (or (not (pair? first)) (not (eq? 'define (car first))))
          (if (null? vars)
              body-remainig
              (let ((vars (reverse vars))
                    (vals (reverse vals))
                    (alphabets (reverse alphabets)))
                (list
                 (make-let
                  (map (lambda (var) (list var ''*unassigned*)) vars)
                  (append
                   (list
                   (make-let
                    (map (lambda (alp val) (list alp val)) alphabets vals)
                    (map (lambda (var alp) (list 'set! var alp)) vars alphabets)))
                   body-remainig)))))
          (iter (cons (definition-variable first) vars)
                (cons (definition-value first) vals)
                (cons (car alphabets-remaining) alphabets)
                (rest-exps body-remainig)
                (cdr alphabets-remaining)))))
    (iter '() '() '() body alphabets-list))

もうなんかスゲー適当感がただようぜ・・・
以下は scan-out-defines の例

> (scan-out-defines '((define u e1) (define v e2) e3))
((let ((u (quote *unassigned*)) (v (quote *unassigned*))) (let ((a e1) (b e2)) (set! u a) (set! v b)) e3))

で、結果。（let変更なし）

;;; M-Eval input:
(stream-ref (solve (lambda (y) y) 1 0.01) 100)

;;; M-Eval value:
2.704813829421526

;;; M-Eval input:
(stream-ref (solve (lambda (y) y) 1 0.001) 1000)

;;; M-Eval value:
2.716923932235896

という風に一応最初の例では動いてますな。
なんかちょっと感動した。
ちなみに実家で使っていたEeePCくんではメモ化ありだとエラーがでました。
引数がながすぎると怒られた気がする。

ちなみにletをいじくった場合は以下

;;; M-Eval input:
(stream-ref (solve (lambda (y) y) 1 0.01) 100)
Unbound variable y

とまぁ予想どおり