SICP 3.5.3

3.63

もとのsqrt-stream

(define (sqrt-stream x)
  (define guesses
    (cons-stream 1.0
                 (stream-map
                   (lambda (guess)
                           (sqrt-improve guess x))
                   guesses)))
  guesses)

Louisのsqrt-stream

(define (sqrt-stream x)
  (cons-stream 1.0
               (stream-map
                 (lambda (guess)
                         (sqrt-improve guess x))
                 (sqrt-stream x))))

差分は stream-map の第2引数だが、これを局所変数にしない場合、毎回ストリームを生成することになり、非効率。

delay が memo-procによる最適化を行っていない場合、遅延評価も毎回演算をやり直すことになるので、 両者の差分は無くなる。(どちらも同じぐらい非効率になる)

3.64

(define-syntax cons-stream
  (syntax-rules ()
    ((_ a b) (strm:stream-cons a b))))
(define stream-car strm:stream-first)
(define stream-cdr strm:stream-rest)
(define stream-null? strm:stream-empty?)
(define the-empty-stream strm:empty-stream)

(define  (stream-limit stream tolerance)
  (let ((stream1 (stream-car stream))
        (stream2 (stream-car (stream-cdr stream))))
    (if (<(abs (- stream1 stream2)) tolerance)
        stream2
        (stream-limit (stream-cdr stream) tolerance))))

ちなみにテスト結果

(sqrt 2 0.01)
(sqrt 2 0.00001)
(sqrt 3 0.01)
(sqrt 3 0.00001)

1.4142156862745097
1.4142135623746899
1.7320508100147274
1.7320508075688772

収束が早いので、あらい精度だとテストできない模様

3.65

(define (log-summands n)
  (cons-stream (/ 1.0 n)
               (stream-map - (log-summands (+ n 1)))))

(define log-stream
  (partial-sums (log-summands 1)))

テスト結果

#lang racket

(require (prefix-in strm: racket/stream))

;helper
(define-syntax cons-stream
  (syntax-rules ()
    ((_ a b) (strm:stream-cons a b))))
(define stream-car strm:stream-first)
(define stream-cdr strm:stream-rest)
(define stream-null? strm:stream-empty?)
(define the-empty-stream strm:empty-stream)
(define (display-stream s) (stream-for-each display-line s))
(define (add-streams s1 s2) (stream-map + s1 s2))
(define (stream-map proc . argstreams)
  (if (stream-null? (car argstreams))
      the-empty-stream
      (cons-stream
       (apply proc (map stream-car argstreams))
       (apply stream-map
              (cons proc (map stream-cdr argstreams))))))

(define (display-stream-head s n)
  (define (iter s n)
    (if (<= n 0)
      'done
      (begin
        (display (stream-car s))
        (newline)
        (iter (stream-cdr s) (- n 1)))))
  (iter s n))

(define (display-line x)
  (newline)
  (display x))

(define (euler-transform s)
  (let ((s0 (stream-ref s 0))           ; Sn-1
        (s1 (stream-ref s 1))           ; Sn
        (s2 (stream-ref s 2)))          ; Sn+1
    (cons-stream (- s2 (/ (square (- s2 s1))
                          (+ s0 (* -2 s1) s2)))
                 (euler-transform (stream-cdr s)))))

(define (make-tableau transform s)
  (cons-stream s
               (make-tableau transform
                             (transform s))))

(define (accelerated-sequence transform s)
  (stream-map stream-car
              (make-tableau transform s)))

(define (partial-sums S)
  (cons-stream
    (stream-car S)
    (add-streams (partial-sums S) (stream-cdr S))))

(define (square x) (* x x))

(define (log-summands n)
  (cons-stream (/ 1.0 n)
               (stream-map - (log-summands (+ n 1)))))

(define log-stream
  (partial-sums (log-summands 1)))

;test
(display-stream-head log-stream 10)
(display-stream-head (euler-transform log-stream) 10)
(display-stream-head (accelerated-sequence euler-transform log-stream) 10)

1.0
0.5
0.8333333333333333
0.5833333333333333
0.7833333333333332
0.6166666666666666
0.7595238095238095
0.6345238095238095
0.7456349206349207
0.6456349206349207
'done

0.7
0.6904761904761905
0.6944444444444444
0.6924242424242424
0.6935897435897436
0.6928571428571428
0.6933473389355742
0.6930033416875522
0.6932539682539683
0.6930657506744464
'done

1.0
0.7
0.6932773109243697
0.6931488693329254
0.6931471960735491
0.6931471806635636
0.6931471805604039
0.6931471805599445
0.6931471805599427
0.6931471805599454
'done

明らかにタブローが早い

3.66

とりあえず実行

(display-stream-head (pairs integers integers) 20)

結果

(1 1)
(1 2)
(2 2)
(1 3)
(2 3)
(1 4)
(3 3)
(1 5)
(2 4)
(1 6)
(3 4)
(1 7)
(2 5)
(1 8)
(4 4)
(1 9)
(2 6)
(1 10)
(3 5)
(1 11)
(2 7)
(1 12)
(4 5)
(1 13)
(2 8)
(1 14)
(3 6)
(1 15)
(2 9)
(1 16)
(5 5)
(1 17)
(2 10)
(1 18)
(3 7)
(1 19)
(2 11)
(1 20)
(4 6)
(1 21)
(2 12)
(1 22)
(3 8)
(1 23)
(2 13)
(1 24)
(5 6)
(1 25)
(2 14)
(1 26)
(3 9)
(1 27)
(2 15)
(1 28)
(4 7)
(1 29)
(2 16)
(1 30)
(3 10)
(1 31)
(2 17)
(1 32)
(6 6)
(1 33)
(2 18)
(1 34)
(3 11)
(1 35)
(2 19)
(1 36)
(4 8)
(1 37)
(2 20)
(1 38)
(3 12)
(1 39)
(2 21)
(1 40)
(5 7)
(1 41)
(2 22)
(1 42)
(3 13)
(1 43)
(2 23)
(1 44)
(4 9)
(1 45)
(2 24)
(1 46)
(3 14)
(1 47)
(2 25)
(1 48)
(6 7)
(1 49)
(2 26)
(1 50)
(3 15)
(1 51)
'done

序盤は例外があるが、

  • (1,x) が1要素おきに出現。
  • (2,x) は3要素おきに出現。
  • (3,x) は8要素おきに出現。
  • (4,x) は15要素おきに出現。

と、法則性がありそう。

しかしここから数学的な法則を見つけ出す事が出来なかったのでカンニング

http://uents.hatenablog.com/entry/sicp/038-ch3.5.3.md

わかんねーなこれは、と思った。

3.67

分からなかったのでカンニング

もとの pairs

(define (pairs s t)
  (cons-stream
   (list (stream-car s) (stream-car t))
   (interleave
    (stream-map (lambda (x) (list (stream-car s) x))
                (stream-cdr t))
    (pairs (stream-cdr s) (stream-cdr t)))))

修正後

(define (pairs-ex s t)
  (cons-stream
   (list (stream-car s) (stream-car t))
   (interleave
    (interleave
     (stream-map (lambda (x) (list (stream-car s) x))
                 (stream-cdr t))
     (stream-map (lambda (x) (list x (stream-car t)))
                 (stream-cdr s)))
    (pairs (stream-cdr s) (stream-cdr t)))))

要は、横だけで無く縦にも成長する無限リストを作り、 そいつらを interleaveすることで、 横にも縦にも成長する無限リストをつくる

ということらしい

3.68

(define (pairs s t)
  (interleave
   (stream-map (lambda (x) (list (stream-car s) x))
               t)
   (pairs (stream-cdr s) (stream-cdr t))))

interleaveが無限にリストを返すので、これだと処理が終わらない。 ( 有限リストと cons する処理が無いので、終わらせる契機が無い)

3.69

(define (triples s t u)
  (cons-stream
    (list (stream-car s) (stream-car t) (stream-car u))
    (interleave
      (stream-map (lambda (x) (cons (stream-car s) x))
                  (pairs (stream-cdr t) (stream-cdr u)))
      (triples (stream-cdr s) (stream-cdr t) (stream-cdr u)))))
display-stream-head (triples integers integers integers) 10)

(1 1 1)
(1 2 2)
(2 2 2)
(1 2 3)
(2 3 3)
(1 3 3)
(3 3 3)
(1 2 4)
(2 3 4)
(1 3 4)
'done
(display-stream-head
   (stream-filter
     (lambda (t) (= (+ (square (car t)) (square (cadr t))) (square (caddr t))))
     (triples integers integers integers))
   6)

結果

(3 4 5)
(6 8 10)
(5 12 13)
(9 12 15)
(8 15 17)
(12 16 20)
'done

7以降は見つかるのに時間がかかりそうだった。

3.70

(define (merge-weighted s1 s2 weight)
  (cond ((stream-null? s1) s2)
        ((stream-null? s2) s1)
        (else
         (let ((s1car (stream-car s1))
               (s2car (stream-car s2)))
           (cond ((< (weight s1car) (weight s2car))
                  (cons-stream s1car (merge-weighted (stream-cdr s1) s2 weight)))
                 ((> (weight s1car) (weight s2car))
                  (cons-stream s2car (merge-weighted s1 (stream-cdr s2) weight)))
                 (else
                  (cons-stream s1car
                               (merge-weighted
                                  (stream-cdr s1)
                                  (stream-cdr s2)
                                  weight))))))))

(define (weighted-pairs s t weight)
  (cons-stream
   (list (stream-car s) (stream-car t))
   (merge-weighted
    (stream-map (lambda (x) (list (stream-car s) x))
                (stream-cdr t))
    (weighted-pairs (stream-cdr s) (stream-cdr t) weight)
    weight)))

(display-stream-head
  (weighted-pairs integers integers (lambda (p) (+ (car p) (cadr p))))
  10)

(define filtered-integers
  (stream-filter
    (lambda (x)
      (not (or (= 0 (remainder x 2))
               (= 0 (remainder x 3))
               (= 0 (remainder x 5)))))
    integers))

(display-stream-head
 (weighted-pairs filtered-integers filtered-integers
                 (lambda (p) (* 2 (car p))+(* 3 (cadr p)) + (* 5 (car p) (cadr p))))
 10)

結果

(1 1)
(1 2)
(1 3)
(1 4)
(1 5)
(1 6)
(1 7)
(1 8)
(1 9)
(1 10)
'done

(1 1)
(1 7)
(1 11)
(1 13)
(1 17)
(1 19)
(1 23)
(1 29)
(1 31)
(1 37)
'done

3.71

いつまで実行しても結果が出てこないので、なにか間違っている気がする。。。

(define (cube x) (* x x x))
(define (add-cube p)
  (+ (cube (car p)) (cube (cadr p))))

(define (ramanujan s)
  (let ((s1 (stream-car s))
        (s2 (stream-car (stream-cdr s))))
    (if (= (add-cube s1) (add-cube s2))
        (cons-stream s1 (ramanujan (stream-cdr s)))
        (ramanujan (stream-cdr s)))))

(display-stream-head
  (ramanujan (weighted-pairs integers integers add-cube))
  10)

3.72

(define (ramanujan3 s)
  (let ((s1 (stream-car s))
        (s2 (stream-car (stream-cdr s)))
        (s3 (stream-car (stream-cdr (stream-cdr s)))))
    (if (= (add-cube s1) (add-cube s2) (add-cube s3))
        (cons-stream s1 (ramanujan (stream-cdr s)))
        (ramanujan (stream-cdr s)))))

3.73

(define (RC R C dt)
  (lambda (rc i v0)
    (add-streams
     (scale-stream i R)
     (integral (scale-stream i (/ 1.0 C)) v0 dt))))

3.74

先頭と2番目の要素を比べるので、 last-data として、頭に0をつけて1つずらしたstreamを渡す

(define zero-crossings
  (stream-map sign-change-detector sense-data (cons-stream 0 sense-data)))

3.75

平均値をlast-valueとして渡しているので、2項目以降の計算結果がおかしい。

平均値は平均値、last-valueはlast-valueとして渡すよう修正。

(define (make-zero-crossings input-stream last-value last-avpt)
  (let ((avpt (/ (+ (stream-car input-stream) last-value) 2)))
    (cons-stream (sign-change-detector avpt last-value)
                 (make-zero-crossings (stream-cdr input-stream)
                                      (stream-car input-stream) avpt))))

3.76

(define (smooth s)
  (let ((s1 (stream-car s))
        (s2 (stream-car (stream-cdr s))))
    (cons-stream (/ (+ s1 s2) 2)
                 (smooth (stream-cdr s)))))

あるいは

(define (smooth s)
  (stream-map s (lambda (x y) (/ (+ x y) 2)) s (stream-cdr s)))

使い方は

(define zero-crossings
  (let ((smoothed-data (smooth sense-data)))
    (stream-map sign-change-detector smoothed-data (cons-stream 0 smoothed-data))))