SICPゼミ第35回

練習問題2.82

例えば引数が長方形と菱形と正方形であるときを考えると、全ての引数を平行四辺形に強制型変換しなければならないが、各引数の型へと変換しようとする限り、平行四辺形にはたどり着かない。つまり、型の関係において分岐が生じており、その分岐の葉にあたる型のみが引数として与えられたときにうまく動かないと考えられる。
by tube

練習問題2.83

(define (integer->rational n)
  (make-rational (contents n) 1))

(define (rational->scheme-number n)
  (let ((nu (car (contents n)))
        (de (cdr (contents n))))
    (make-scheme-number (/ nu de))))

(define (scheme-number->complex n)
  (make-complex-from-real-imag (contents n) 0))

ジェネリックなraiseは適当にputして適当にgetすればいい。

練習問題2.84

一つ目の型をraiseを使ってあげていく。二つ目の型と一致したらOK。一致するまえに一番上に行く（raiseがエラーを返す）ときは、二つ目の型をあげていく。

練習問題2.85

一度projectをしてからraiseをして、元の値と比較することで、情報落ちがないかを確認するというdropの手続きを実装せよという問題だが、端的に言ってこの問題で要求されている処理には無駄が大きいと言わざるを得ない。
projectの実装は当然project前後の型に依存しており、projectの動作を記述する際に、projectによって情報落ちが発生するかの判定を組み込むことは容易に可能である。
これにも関わらず、projectの段階で情報落ちの判定をせずに、dropの処理の段階に情報落ちの判定を分割することは明らかに無駄であり、不要な処理を記述することになってしまう。
以上より、dropの実装は省略する。

練習問題2.86

複素数パッケージの内部手続きの演算(+とか*とか)をジェネリック演算にする。
sine、cosineは実数に型変換してつっこむ。

SICPゼミ第34回

2章に帰ってきました。

put, get など

(define (key-compare a b) 0)
(define (make-table)
  (let (( local-table (list '*table* )))
    (define (lookup key-1 key-2)
      (let (( subtable
              (assoc key-1 (cdr local-table ))))
        (if subtable
            (let (( record
                    (assoc key-2 (cdr subtable ))))
              (if record (cdr record) false ))
            false )))
    (define (insert! key-1 key-2 value)
      (let (( subtable
              (assoc key-1 (cdr local-table ))))
        (if subtable
            (let (( record
                    (assoc key-2 (cdr subtable ))))
              (if record
                  (set-cdr! record value)
                  (set-cdr! subtable
                            (cons (cons key-2 value)
                                  (cdr subtable )))))
            (set-cdr! local-table
                      (cons (list key-1 (cons key-2 value ))
                            (cdr local-table )))))
      'ok)
    (define (dispatch m)
      (cond ((eq? m 'lookup-proc) lookup)
            ((eq? m 'insert-proc!) insert!)
            (else (error "Unknown operation: TABLE" m))))
    dispatch ))

(define operation-table (make-table ))
(define get (operation-table 'lookup-proc ))
(define put (operation-table 'insert-proc! ))

(define (attach-tag type-tag contents)
  (cons type-tag contents ))

(define (type-tag datum)
  (if (pair? datum)
      (car datum)
      (error "Bad tagged datum: TYPE-TAG" datum )))

(define (contents datum)
  (if (pair? datum)
      (cdr datum)
      (error "Bad tagged datum: CONTENTS" datum )))


(define (apply-generic op . args)
  (let (( type-tags (map type-tag args )))
    (let ((proc (get op type-tags )))
      (if proc
          (apply proc (map contents args))
          (error
           "No method for these types: APPLY-GENERIC"
           (list op type-tags ))))))

(define (add x y) (apply-generic 'add x y))
(define (sub x y) (apply-generic 'sub x y))
(define (mul x y) (apply-generic 'mul x y))
(define (div x y) (apply-generic 'div x y))

(define (install-scheme-number-package)
  (define (tag x) (attach-tag 'scheme-number x))
  (put 'add '(scheme-number scheme-number)
       (lambda (x y) (tag (+ x y))))
  (put 'sub '(scheme-number scheme-number)
       (lambda (x y) (tag (- x y))))
  (put 'mul '(scheme-number scheme-number)
       (lambda (x y) (tag (* x y))))
  (put 'div '(scheme-number scheme-number)
       (lambda (x y) (tag (/ x y))))
  (put 'make 'scheme-number (lambda (x) (tag x)))
  'done)

(define (install-rational-package)
  ;; 内部手続き
  (define (numer x) (car x))
  (define (denom x) (cdr x))
  (define (make-rat n d)
    (let ((g (gcd n d)))
      (cons (/ n g) (/ d g))))
  (define (add-rat x y)
    (make-rat (+ (* (numer x) (denom y))
                 (* (numer y) (denom x)))
              (* (denom x) (denom y))))
  (define (sub-rat x y)
    (make-rat (- (* (numer x) (denom y))
                 (* (numer y) (denom x)))
              (* (denom x) (denom y))))
  (define (mul-rat x y)
    (make-rat (* (numer x) (numer y))
              (* (denom x) (denom y))))
  (define (div-rat x y)
    (make-rat (* (numer x) (denom y))
              (* (denom x) (numer y))))
  ;; システムのほかの部分とのインターフェイス
  (define (tag x) (attach-tag 'rational x))
  (put 'add '(rational rational)
       (lambda (x y) (tag (add-rat x y))))
  (put 'sub '(rational rational)
       (lambda (x y) (tag (sub-rat x y))))
  (put 'mul '(rational rational)
       (lambda (x y) (tag (mul-rat x y))))
  (put 'div '(rational rational)
       (lambda (x y) (tag (div-rat x y))))
  (put 'make 'rational
       (lambda (n d) (tag (make-rat n d))))
  'done)
(define (make-rational n d)
  ((get 'make 'rational) n d))



(define (install-complex-package)
  ;; 直交形式パッケージと極形式パッケージからインポートした手続き
  (define (make-from-real-imag x y)
    204
    ((get 'make-from-real-imag 'rectangular) x y))
  (define (make-from-mag-ang r a)
    ((get 'make-from-mag-ang 'polar) r a))
  ;; 内部手続き
  (define (add-complex z1 z2)
    (make-from-real-imag (+ (real-part z1) (real-part z2))
                         (+ (imag-part z1) (imag-part z2))))
  (define (sub-complex z1 z2)
    (make-from-real-imag (- (real-part z1) (real-part z2))
                         (- (imag-part z1) (imag-part z2))))
  (define (mul-complex z1 z2)
    (make-from-mag-ang (* (magnitude z1) (magnitude z2))
                       (+ (angle z1) (angle z2))))
  (define (div-complex z1 z2)
    (make-from-mag-ang (/ (magnitude z1) (magnitude z2))
                       (- (angle z1) (angle z2))))
  ;; システムのほかの部分とのインターフェイス
  (define (tag z) (attach-tag 'complex z))
  (put 'add '(complex complex)
       (lambda (z1 z2) (tag (add-complex z1 z2))))
  (put 'sub '(complex complex)
       (lambda (z1 z2) (tag (sub-complex z1 z2))))
  (put 'mul '(complex complex)
       (lambda (z1 z2) (tag (mul-complex z1 z2))))
  (put 'div '(complex complex)
       (lambda (z1 z2) (tag (div-complex z1 z2))))
  (put 'make-from-real-imag 'complex
       (lambda (x y) (tag (make-from-real-imag x y))))
  (put 'make-from-mag-ang 'complex
       (lambda (r a) (tag (make-from-mag-ang r a))))
  'done)

by tube

練習問題2.81

ちなみに put-coercion, get-coercion は新しいテーブルを持てばいいので

(define coercion-table (make-table ))
(define get-coercion (coercion-table 'lookup-proc ))
(define put-coercion (coercion-table 'insert-proc! ))

a.
型変換メソッドが存在し続ける、つまり apply-generic 内にある cond 条件文の else 節に入らないため、無限ループがおきる。

b.
そのままで動く。

c.

(define (apply-generic op . args)
  (let (( type-tags (map type-tag args )))
    (let ((proc (get op type-tags )))
      (if proc
          (apply proc (map contents args))
          (if (= (length args) 2)
              (let (( type1 (car type-tags ))
                    (type2 (cadr type-tags ))
                    (a1 (car args ))
                    (a2 (cadr args )))
                (if (equal? type1 type2)
                    (error "No method for these types")
                (let (( t1->t2 (get-coercion type1 type2 ))
                      (t2->t1 (get-coercion type2 type1 )))
                  (cond (t1->t2
                         (apply-generic op (t1->t2 a1) a2))
                        (t2->t1
                         (apply-generic op a1 (t2->t1 a2)))
                        (else (error "No method for these types"
                                     (list op type-tags )))))))
              (error "No method for these types"
                     (list op type-tags )))))))

SICPゼミ第33回

練習問題4.1

左から右

(define (list-of-values exps env)
  (if (no-operands? exps)
      '()
      (let ((val (eval (first-operand exps) env)))
        (cons val
          (list-of-values (rest-operands exps) env)))))

右から左

(define (list-of-values exps env)
  (if (no-operands? exps)
      '()
      (let ((val (list-of-values (rest-operands exps) env)))
        (cons (eval (first-operand exps) env) val))))

by pine

SICPゼミ第32回

練習問題3.81

(define (rand-stream stream)
  (define (rand-stream-iter stream mt)
    (if (stream-null? stream)
        the-empty-stream
        (let ((message (stream-car stream)))
          (if (eq? message 'generate)
              (cons-stream (mt-random-integer mt 1000) (rand-stream-iter (stream-cdr stream) mt))
              (let ((new-mt (make <mersenne-twister> :seed message)))
                (cons-stream (mt-random-integer new-mt 1000) (rand-stream-iter (stream-cdr stream) new-mt)))))))
  (rand-stream-iter stream (make <mersenne-twister> :seed (sys-time))))

(define (rand-stream stream)
  (define (rand-stream-iter stream last)
    (if (stream-null? stream)
        the-empty-stream
        (let ((message (stream-car stream)))
          (if (eq? message 'generate)
              (let ((new-num (rand-update last)))
                (cons-stream new-num (rand-stream-iter (stream-cdr stream) new-num)))
              (cons-stream message (rand-stream-iter (stream-cdr stream) message))))))
  (rand-stream-iter stream (rand)))

by pine

練習問題3.82

racket だと (random) で 0~1 の乱数が出てくるので(0,0), (1,1) の長方形でやりました。

(define (estimate-integral P x1 x2 y1 y2)
  (define (estimate-integral-iter passed failed)
    (define (guessed-value passed failed)
      (let ((rectangle-area (* (- x2 x1) (- y2 y1))))
        (* 4 (* rectangle-area (/ (* passed 1.0) (+ passed failed))))))
    (define (next passed failed)
      (cons-stream
       (guessed-value passed failed)
       (estimate-integral-iter passed failed)))
    (let ((x (random))
          (y (random)))
      (if (P x y)
          (next (+ passed 1) failed)
          (next passed (+ failed 1)))))
  (estimate-integral-iter 0 0))
(define (P x y)
    (< (+ (* (- x 0.5) (- x 0.5)) (* (- y 0.5) (- y 0.5))) 0.25))

実行結果

by tube

SICPゼミ第31回

練習問題3.77

(define (integral delayed-integrand initial-value dt)
  (cons-stream
   initial-value
   (let ((integrand (force delayed-integrand)))
     (if (stream-null? integrand)
       the-empty-stream
       (integral (delay (stream-cdr integrand))
                 (+ (* dt (stream-car integrand))
                    initial-value)
                 dt)))))

by tube

練習問題3.78

(define (solve-2nd a b y0 dy0 dt)
  (define y (integral (delay dy) y0 dt))
  (define dy (integral (delay ddy) dy0 dt))
  (define ddy (add-streams (scale-stream dy a)
                          (scale-stream y b)))
  y)

下のコードで動かしてみた。cos になればOK

(display-stream-count (solve-2nd 0 -1 1 0 0.001) 10000)

結果

やったー！

by tube

練習問題3.79

(define (solve-2nd f y0 dy0 dt)
  (define y (integral (delay dy) y0 dt))
  (define dy (integral (delay ddy) dy0 dt))
  (define ddy (stream-map f y))
  y)

結果。sin になればOK

(display-stream-count (solve-2nd (lambda (y) (* y -1)) 0 1 0.001) 10000)

やったーー！
by tube

練習問題3.80

(define (solve-2-1st-ode f g s0 t0 dt)
  (define s (integral (delay ds) s0 dt))
  (define t (integral (delay dtt) t0 dt))
  (define ds (stream-map f s t))
  (define dtt (stream-map g s t))　　
  (cons s t)
)

(define (RLC R L C dt)
  (define (f v i) (- (/ i C)))
  (define (g v i)  (- (/ v L) (/ (* R i) L)))
  (define (return vc0 il0)
    (solve-2-1st-ode f g vc0 il0 dt)
    )
  return)

by dolicas

(display-stream-count ((RLC 1 1 0.2 0.1) 10 0) 500)

(define (rlc-circuit R L C dt)
  (define (get-initial Vc0 iL0)
    (define Vc (integral (delay dVc) Vc0 dt))
    (define dVc (scale-stream iL (- (/ 1 C))))
    (define diL (add-streams (scale-stream Vc (/ 1 L)) (scale-stream iL (- (/ R L))) ))
    (define iL (integral (delay diL) iL0 dt))
    (cons Vc iL))
  get-initial)

なぜか動かない。

SICPゼミ第30回

練習問題3.73

(define (RC R C dt)
  (define (calc i v0)
    (add-streams (scale-stream i R) (integral (scale-stream i (/ 1 C)) v0 dt)))
  calc)

民主主義しゅき〜〜（ドナルド・トランプ）

練習問題3.74

(define (sign-change-detector now last)
  (if (> (* now last) 0)
      0
      (if (= last 0)
          (if (>= now 0) 0 -1)
          (if (< last 0) 1 0))))
              

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

練習問題3.75

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

by dolicas

練習問題3.76

(define (smooth input-stream)
  (cons-stream (/ (+ (stream-car input-stream)
                     (stream-car (stream-cdr input-stream)))
                  2)
               (smooth (stream-cdr input-stream))))

SICPゼミ第29回

練習問題3.67

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

実行結果

> (display-stream-count (pairs integers integers) 10)

(1 1)
(1 2)
(2 2)
(2 1)
(2 3)
(1 3)
(3 3)
(3 1)
(3 2)
(1 4)

by tube

練習問題3.68

無限ループする。

関数呼び出しをするとまず引数が評価されるので、Reasonerの(pairs s t)をすると定義内のinterleaveの第2引数である(pairs (stream-cdr s) (stream-cdr t))が評価される。これはpairsの呼び出しの無限ループを引き起こす。

by dolicas

練習問題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)) (stream-cdr (pairs t u)))
      (triples (stream-cdr s) (stream-cdr t) (stream-cdr u))
      )
    )
  )

by dolicas

(define pythagoras
  (stream-filter
   (lambda (triple)
     (= (+ (square (car triple))
           (square (cadr triple)))
        (square (caddr triple))))
   (triples integers integers integers)))

実行結果

> (display-stream-count pythagoras 4)

(3 4 5)
(6 8 10)
(5 12 13)
(9 12 15)

by tube

練習問題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)))
            (if (weight s1car s2car)
                (cons-stream
                  s1car
                  (merge-weighted (stream-cdr s1) s2 weight))
                (cons-stream
                  s2car
                  (merge-weighted 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)))

(define (weight1 p1 p2)
  (let ((s1 (+ (car p1) (cadr p1)))
        (s2 (+ (car p2) (cadr p2))))
    (< s1 s2)))

(define (weight2 p1 p2)
  (let ((s1 (+ (* (car p1) 2) (* (cadr p1) 3) (* (car p1) (cadr p1) 5)))
        (s2 (+ (* (car p2) 2) (* (cadr p2) 3) (* (car p2) (cadr p2) 5))))
    (< s1 s2)))

(define a (weighted-pairs integers integers weight1))

(define b
  (stream-filter
    (lambda (x)
      (and (not (= (remainder (car x) 2) 0))
           (not (= (remainder (car x) 3) 0))
           (not (= (remainder (car x) 5) 0))
           (not (= (remainder (cadr x) 2) 0))
           (not (= (remainder (cadr x) 3) 0))
           (not (= (remainder (cadr x) 5) 0))))
    (weighted-pairs integers integers weight2)))

by pine

(define (merge-weighted weight s1 s2)
  (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 weight (stream-cdr s1) s2)))
                 ((> (weight s1car) (weight s2car))
                  (cons-stream
                   s2car
                   (merge-weighted weight s1 (stream-cdr s2)))))))))
(define (weighted-pairs weight s t)
  (cons-stream
   (list (stream-car s) (stream-car t))
   (merge-weighted
    weight
    (stream-map (lambda (x) (list (stream-car t) x))
                (stream-cdr s))
    (weighted-pairs weight (stream-cdr s) (stream-cdr t)))))

実際に問題解いた
a

> (display-stream-count
   (weighted-pairs
    (lambda (pair)
      (+ (car pair)
         (cadr pair)))
    integers integers) 10)

(1 1)
(1 2)
(1 3)
(2 2)
(1 4)
(2 3)
(1 5)
(2 4)
(3 3)
(1 6)

b

> (define s (stream-filter
             (lambda (x)
               (not (or (= (remainder x 2) 0)
                        (= (remainder x 3) 0)
                        (= (remainder x 5) 0)))) integers))
> (display-stream-count
   (weighted-pairs
    (lambda (pair)
      (+ (* 2(car pair))
         (* 3 (cadr pair))
         (* 5 (car pair) (cadr pair)))) s s) 10)

(1 1)
(1 7)
(1 11)
(1 13)
(1 17)
(1 19)
(1 23)
(1 29)
(1 31)
(7 7)

by tube

練習問題3.71

(define (weight1 p1)
  (+ (cube (car p1)) (cube (cadr p1))))

(define (cube x) (* x x x))

(define (ramanujan)
  (define (pair-cube l) (+ (cube (car l)) (cube (cadr l))))
  (define (ramanujan-iter stream)
    (let ((s1 (pair-cube (stream-car stream)))
      (s2 (pair-cube (stream-car (stream-cdr stream)))))
    (if (= s1 s2)
      (stream-cons s1 (ramanujan-iter (stream-cdr stream)))
      (ramanujan-iter (stream-cdr stream)))))
  (ramanujan-iter (weighted-pairs weight1 integers integers)))

実行結果

> (define x (ramanujan))
> (display-stream-count x 15)
1729
4104
13832
20683
32832
39312
40033
46683
64232
65728
110656
110808
134379
149389
165464

by dolicas

練習問題3.72

(define (pseudo-ramanujan)
  (define (pseudo-iter stream)
    (let ((s1 (pair-square (stream-car stream)))
          (s2 (pair-square (stream-car (stream-cdr stream))))
          (s3 (pair-square (stream-car (stream-cdr (stream-cdr stream))))))
      (if (and (= s1 s2) (= s2 s3))
          (cons-stream s1 (pseudo-iter (stream-cdr stream)))
          (pseudo-iter (stream-cdr stream)))))
  (pseudo-iter (weighted-pairs pair-square integers integers)))

> (display-stream-count (pseudo-ramanujan) 10)

325
425
650
725
845
850
925
1025
1105
1105

by tube