SICP 4.1.3-5

4.11

教科書の実装ではフレームは

 ((var1 var2 var3) (val1 val2 val3))

となっているのを

((var1 val1) (var2 val2) (var3 val3))

と実装し直す。

#lang racket

;変更なし
(define (enclosing-environment env) (cdr env))
(define (first-frame env) (car env))
(define the-empty-environment '())

;変更あり
(define (make-frame variables values)
  (map cons variables values))

(define (make-binding var val) (cons var val))
(define (add-binding-to-fram! var val frame)
  (set! frame (cons (make-binding var val) frame)))
(define (first-binding frame) (car frame))
(define (rest-bindings frame) (cdr frame))
(define (binding-var binding) (car binding))
(define (binding-val binding) (car binding))
(define (set-binding-val! binding val) (set-cdr! binding val))

;frame-vars と frame-vals を定義しても良いが、こっちの方が綺麗なので直す
(define (lookup-variable-value var env)
  (define (env-loop env)
    (define (scan frame)
      (if (null? frame)
          (env-loop (enclosing-environment env))
          (let ((binding (first-binding frame)))
              (if (eq? var (binding-var binding))
                  (binding-val binding)
                  (scan (rest-bindings frame))))))
    (if (eq? env the-empty-environment)
        (error "Unbound variable" var)
        (let ((frame (first-frame env)))
          (scan frame))))
  (env-loop env))

(define (set-variable-value! var val env)
  (define (env-loop env)
    (define (scan frame)
      (if (null? frame)
          (env-loop (enclosing-environment env))
          (let ((binding (first-binding frame)))
            (if (eq? var (binding-var binding))
                (set-binding-val! binding val)
                (scan (rest-bindings frame))))))
    (if (eq? env the-empty-environment)
        (error "Unbound variable -- SET!" var)
        (let ((frame (first-frame env)))
          (scan frame))))
  (env-loop env))

(define (define-variable! var val env)
  (let ((frame (first-frame env)))
    (define (scan frame)
      (if (null? frame)
          (add-binding-to-frame! var val frame)
          (let ((binding (first-binding frame)))
            (if (eq? var (binding-var binding))
                (set-binding-val! binding val)
                (scan (rest-bindings frame))))))
    (scan frame)))

4.12

scan と env-loop を抜き出す。

どちらも、対応する bindingを見つけたらそれを返す。 見つけられなかったら #f を返す。

教科書の実装と4.11の実装、両方に対応する抽象化をしたかったが断念。。。

(define (env-loop env var)
   (if (eq? env the-empty-environment)
        #f
        (let ((result (scan (first-frame env) var)))
          (if (result)
              result ;binding
              (env-loop (enclosing-environment env) var)))))

(define (scan frame var)
   (if (null? frame)
       #f
       (let ((binding (first-binding frame)))
         (if (eq? var (binding-var binding))
             binding
             (scan (rest-bindings frame))))))

(define (lookup-variable-value var env)
  (let ((result (env-loop env)))
     (if result
         (binding-val result)
         (error "Unbound variable" var))))

(define (set-variable-value! var val env)
  (let ((result (env-loop env var)))
     (if result
         (set-binding-val! result val)
         (error "Unbound variable -- SET " var))))

(define (define-variable! var val env)
  (let ((result (scan (first-frame env) var)))
    (if (result)
        (set-binding-val! result val)
        (add-binding-to-frame! var val (first-frame env)))))

4.13

仕様を以下のように定める - 4.11 の実装をベースに行う - 渡された環境のみを操作する(外側の環境の変数は別の環境が依存している可能性があるので危険)

(define (unbind! var frame)
  (define (scan-to-unbind frame)
    (if (null? frame)
        (error "Unbound variable -- UNBOUND " var)
        (let ((binding (first-binding frame)))
           (if (eq? var (binding-var binding))
               (rest-bindings frame)
               (cons (binding (scan-to-unbind (rest-bindings frame))))))))
  (set! frame (scan-to-unbind frame)))

4.14

Louis がやったこ

(define primitive-procedures
  (list (list 'car car)
        (list 'cdr cdr)
        (list 'cons cons)
        (list 'null? null?)
        (list 'map map) ;mapを基本手続きとして追加
        ))

mapの呼ばれ方は

(map proc args...)

だが、 procもargsも引数とリストとして受けとってしまうのでうまくいかない。

4.15

設問どおり、 halts? の存在を仮定して、以下の処理を考える。

; (define (halts? p a)
;    (if ((p a)が停止する)
;        #t
;        #f
(define (run-forever) (run-forever))

(define (try p)
  (if (halts? p p)
      (run-forever)
      'halted))

ここで、

(try try)

を評価すると、

  1. (try try) が停止する場合 -> (halts try try) は 真 -> run-forever が実行されるため、(try try)は停止しない

  2. (try try) が停止する場合 -> (halts try try) は 偽 -> 'halted が返却されるため、 (try try)は停止する

よって、矛盾が生じるため、背理法で hatls の存在は否定される。

SICP 4.1.1-2

4.1

もともとの list-of-values

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

cons の引数をあらかじめ評価してやれば良いので

左から右

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

右から左

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

4.2

もともとのeval

(define (eval exp env)
  (cond ((self-evaluating? exp) exp)
        ((variable? exp) (lookup-variable-value exp env))
        ((quoted? exp) (text-of-quotation exp))
        ((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 (eval (operator exp) env)
                (list-of-values (operands exp) env)))
        (else
         (error "Unknown expression type -- EVAL" exp))))

Louisが修正したeval

(application? が assignment?の前に来る)

(define (eval exp env)
  (cond ((self-evaluating? exp) exp)
        ((variable? exp) (lookup-variable-value exp env))
        ((quoted? exp) (text-of-quotation exp))
        ((application? exp)
         (apply (eval (operator exp) env)
                (list-of-values (operands 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))
        (else
         (error "Unknown expression type -- EVAL" exp))))

4.2a

(define x 3) に対する挙動

define を関数として認識してしまい、うまく動かないのではないか。

代入のシンボルをシンボルとして認識できず、関数として解釈してしまう。

4.2b

applicaiton で評価したいときは必ず call がつく、と前提できるので、applicationの処理を変える。

(define (application? exp)(tagged-list? exp 'call))

演算子についても callがつくので追従して直す。

具体的には、carにあるcallを無視するようにする。

(define (operator exp) (cadr exp))
(define (operands exp) (cddr exp))

4.3

パス

4.4

(define (eval-and exp env)
  (define (eval-and-iter exp result)
    (if (null? exp)
        result
        (let ((first-eval (eval (car exp) env)))
          (if (true? first-eval)
              (eval-and-iter (cdr exp) 'true)
              'false))))
  (eval-and-iter exp 'true))
(define (eval-or exp env)
  (if (null? exp)
      'false
      (let ((first-eval (eval (car exp) env)))
        (if (true? first-eval)
            'true
            (eval-or (cdr exp) env)))))

4.5

expand-clauses の if分作成前に => を含む構文を評価する

(define (expand-clauses clauses)
  (if (null? clauses)
      'false                          ; else節なし
      (let ((first (car clauses))
            (rest (cdr clauses)))
        (if (cond-else-clause? first)
            (if (null? rest)
                (sequence->exp (cond-actions first))
                (error "ELSE clause isn't last -- COND->IF"
                       clauses))
            (make-if (cond-predicate first)
                     (if (eq? (car (cond-actions first)) '=>)
                         (list (cadr (cond-actions first)) (cond-predicate first))
                         (sequence->exp (cond-actions first))
                     (expand-clauses rest))))))

4.6

#lang racket
(define (let? exp)
  (tagged-list? exp 'let))

;(let ((var1 exp1) (var2 exp2) ...) body)
(define (let-variables exp) (map car (cadr exp)))
(define (let-expressions exp) (map cdr (cadr exp)))
(define (let-body exp) (cddr exp))

;((lambda (var1 var2 ...) body) exp1 exp2 ...)
(define (let->combination exp)
   (if (null? (let-parameters exp))
       '()
       (cons
         (make-lambda (let-variables exp) (let-body))
         (let-expressions exp))))

4.7

(let* ((var1 exp1) (var2 exp2) ...) body)

(let ((var1 exp1))
  (let* ((var2 exp2) ...) body))

と展開できる。

よって

(define (let*->nested-lets exp)
  (define (iter params)
    (if (null? params)
        (let*-body exp)
        (make-let (car params) (iter (cdr params)))))
  (iter (let*->parameters exp)))

あるいは

(define (let*-parameters exp) (cadr exp))
(define (let*-body exp) (cddr exp))
(define (let*->nested-lets exp)
  (define (iter params result)
    (if (null? params)
        result
        (iter (cdr params)
              (make-let (list (car params)) result))))
  (iter (reverse (let*-parameters exp)) (let*-body exp)))

4.8

ギブ

4.9

ギブ

4.10

ギヴ

SICP 3.5.4 - 3.5.5

3.77

#lang racket
(define (integral delayed-integrand initial-value dt)
  (let ((integrand (froce delayed-integrand)))
    (cons-stream initial-value
      (if (stream-null? integrand)
          the-empty-stream
          (integral (stream-cdr integrand)
                    (+ (* dt (stream-car integrand))
                       initial-value)
                    dt)))))

3.78

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

3.79

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

3.80

(define (RLC R L C dt)
  (define (rlc vC0 iL0)
    (define vC (integral (delay dvC) vC0 dt))
    (define iL (integral (delay diL) iL0 dt))
    (define dvC (scale-stream iL (/ -1 C)))
    (define diL (add-streams
                  (scale-stream vC (/ 1 L))
                  (scale-stream iL (- (/ R L)))))
    (stream-map (lambda (x y) (cons x y)) vC iL))
  rlc)

(define RLC1 (RLC 1 1 0.2 0.1))

(display-stream-head (RLC1 10 0) 10)

結果

(10 . 0)
(10 . 1.0)
(9.5 . 1.9)
(8.55 . 2.66)
(7.220000000000001 . 3.249)
(5.5955 . 3.6461)
(3.77245 . 3.84104)
(1.8519299999999999 . 3.834181)
(-0.0651605000000004 . 3.6359559)
(-1.8831384500000004 . 3.2658442599999997)
'done

実行には以下のhelperを使う

#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 (scale-stream stream factor)
  (stream-map (lambda (x) (* x factor)) stream))
(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 (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)

3.81

入力として ‘generate が来たら乱数を生成。

数値が来たらその数値を使ってresetという動作。

3.6では代入で値を保持していたが、ストリームの中に閉じるので代入は不要になる。

ストリームの中で値を都度 last-value として次の処理に渡してやれば良い。

(define (rand-stream s seed)
  (define (generate last-val)
    ;lcdとか使うと乱数っぽくなるが、テストを楽にするために簡略化
    (+ last-val 1))
  (define (reset new-seed) new-seed)
  (define (dispatch req last-val)
    (cond ((eq? req 'generate) (generate last-val))
          ((number? req) (reset req))
          (else (error "unknown message" req))))
  (define (iter req-stream last-val)
    (let ((new-val (dispatch (car req-stream) last-val)))
      (cons-stream
        new-val
        (iter (stream-cdr req-stream) new-val))))
  (iter s seed))

;test
(define test-stream (list 'generate 5 'generate 'generate 10 20 'generate))

(display-stream-head (rand-stream test-stream 1) 7)

結果。(実行時は3.80と同じhelperを追加する)

2
5
6
7
10
20
21
'done

3.82

試行毎に乱数生成していたのを、あらかじめ乱数ストリームを渡すように改造する。

(define (estimate-integral p x1 x2 y1 y2 )
  (define x-stream (random-in-range-stream x1 x2))
  (define y-stream (random-in-range-stream y1 y2))
  (stream-map
   (lambda (p) (* (* (- x2 x1) (- y2 y1))p))
   (monte-carlo (stream-map p x-stream y-stream) 0 0)))


;単位円をテストする関数
(define (circle x y)
   (<= (+ (square x) (square y)) 1.0))

;中心 (50,50) 半径 50 の円
(define (circle2 x y)
  (<= (+ (square (- x 50.0)) (square (- y 50.0))) (square 50.0)))

; piの見積もり (pi=S/r^2)
; S 円の面積
; r 半径
(define (estimate-pi-stream S-stream r)
  (stream-map (lambda (s) (/ s (square r))) S-stream))

;test
(display-stream-head
 (estimate-pi-stream (estimate-integral circle -1 1 -1 1) 1.0) 100)

(display-stream-head
 (estimate-pi-stream (estimate-integral circle2 0 100 0 100) 50.0) 100)

実行結果(長いので最後の要素だけ)

;単位円
...
2.72
'done
;半径50の円
3.16
'done

精度がいまいちなのは乱数の質の問題?

なお、実行には以下のhelperを使う

#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 (scale-stream stream factor)
  (stream-map (lambda (x) (* x factor)) stream))
(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 ones (cons-stream 1.0 ones))
(define (square x) (* x x))
(define (random-in-range low high)
  (let ((range (- high low)))
    (+ low (random range))))
(define (random-in-range-stream low high)
  (stream-map
   (lambda (x) (random-in-range low high))
   ones))

(define (monte-carlo experiment-stream passed failed)
  (define (next passed failed)
    (cons-stream
     (/ passed (+ passed failed))
     (monte-carlo
      (stream-cdr experiment-stream) passed failed)))
  (if (stream-car experiment-stream)
      (next (+ passed 1) failed)
      (next passed (+ failed 1))))

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))))

SICP 3.5.1-3.5.2

3.50

脚注12

12 Schemeが標準的に用意しているmap手続きは, ここに述べたものより一般的である.
より一般的 mapは, n引数の手続きとn個のリストをとり,
手続きをリストのすべての第一要素に作用させ,
リストのすべての第二要素に作用させ,
等々させて, 結果のリストを返す.

例えば
(map + (list 1 2 3) (list 40 50 60) (list 700 800 900))
(741 852 963)

(map (lambda (x y) (+ x (* 2 y)))
     (list 1 2 3)
     (list 4 5 6))
(9 12 15)

元々のmap

(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-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))))))

ただし、argstreamsの長さが違うとおかしくなるかも? e.g. (stream-map some-proc (1 1 1) (2 2)) だと、(2 2)の第3要素が無いのでそこでおかしくなりそう

3.51

(define x (stream-map show (stream-enumerate-interval 0 10)))
0
=> x

(stream-ref x 5)
1
2
3
4
5
=> 5
(stream-ref x 7)
6
7
=> 7

3.52

(define sum 0)
; 0

(define (accum x)
  (set! sum (+ x sum))
  sum)
; 0

(define seq (stream-map accum (stream-enumerate-interval 1 20)))
; sumは1

(define y (stream-filter even? seq))
; even になるまで巡るので、 1, 3, 6 で 6
; sumは6

(define z (stream-filter (lambda (x) (= (remainder x 5) 0)) seq))
; 5の倍数になるまで巡るので 6, 10
; sumは10

(stream-ref y 7)
; yの7番目まで巡る
; yは  6 10 28 36 66 78 120 136 190 210
; sumは120

(display-stream z)
; zを最後まで巡る
; z は 10 15 45 55 120 190 210
; sumは210
; 印字は (10 15 45 55 120 190 210)

最適化を使わない場合、毎度計算(accum)がやり直されるので、どんどんsumの値が増える

; yまでは同じ
(define z (stream-filter (lambda (x) (= (remainder x 5) 0)) seq))
; 第1要素が6になる
; 6 + 2 + 3 + 4 = 15
(stream-ref y 7)
; 15 + (4 + 5 + ... + 17) = 162
(display-stream z)
; 162 + (5 + 6 + ... + 20) = 362

3.53

(define s (cons-stream 1 (add-streams s s)))

最後に出力された要素の2倍が次の要素。

1 2 4 8 …

よって n番目の要素は 2n-1

3.54

(define (mul-stream s1 s2)
  (stream-map * s1 s2))
(define factorials (cons-stream 1 (mul-streams factorials (stream-cdr integers))))

3.55

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

3.56

(define S (cons-stream 1 (merge ⟨scale-stream S 2⟩ ⟨merge (scale-stream S 3) (scale-stream S 5)⟩)))

3.57

fibs

(define fibs
  (cons-stream 0
    (cons-stream 1
      (add-streams (stream-cdr fibs) fibs))))

1番目 0 2番目 1 3番目 2 4番目 3 … n番目 n-1

メモかを使わない場合は、毎回計算がやり直されるので 1番目 0 2番目 1 3番目 3 4番目 7 … n番目 n-1の回数 + n

3.58

(define (expand num den radix)
  (cons-stream
   (quotient (* num radix) den)
   (expand (remainder (* num radix) den) den radix)))
(expand 1 7 10)
; (quotient 10 7)
; => 1
; (expand 3 7 10)
;   (quotient 30 7)
; => 4
; (expand 2 7 10)
;   (quotient 20 7)
; => 2
; (expand 6 7 10)
;   (quotient 60 7)
; => 8
; (expand 4 7 10)
;   (quotient 40 7)
; => 5
; (expand 5 7 10)
;   (quotient 50 7)
; => 7
; (expand 1 7 10)
; 以下循環
(expand 3 8 10)
; (quotien 30 8)
; => 3
; (expand 6 8 10)
; => 7
; (expand 4 8 10)
; => 5
; (expand 0 8 10)
; => 0
; (expand 0 8 10)
; 以下ずっと0

3.59

a

ストリームのn番目の要素を 1/n すれば良いので

(define (integrate-series s)
  (stream-map / s integers))

b

正弦の微分余弦 = 余弦積分が正弦

(define sine-series
  (cons-stream 1 (integrate-series cosine-series)))

余弦微分が正弦の符号を変えたもの = 正弦の符号を変えて積分すれば余弦

(define cosine-series
  (cons-stream 0 (integrate-series (scale-stream sine-stream -1))))

循環論法みたいで気持ち悪いが、遅延評価なら交互に実行すれば、求めた精度をやがて得られる。

3.60

べき級数の積の定義 https://ja.wikipedia.org/wiki/%E5%86%AA%E7%B4%9A%E6%95%B0#.E4.B9.97.E6.B3.95.E3.81.A8.E9.99.A4.E6.B3.95

(define (mul-series s1 s2)
  (cons-stream
    (* (stream-car s1) (stream-car s2))
    (add-streams
      (scale-stream (stream-cdr s2) (stream-car s1))
      (mul-series (stream-cdr s1) s2))))

3.61

(define (invert-unit-series s)
  (let ((sr (stream-cdr s)))
    (cons-stream 1
      (stream-map -
        (mul-series sr
           (invert-unit-series sr))))))

3.62

べき級数がよく分かっていないが、 f/g は gに対する級数Xを見つけて、 f と乗算すれば得られるはず。 よって、

(define (dev-series s1 s2)
  (if (= 0 (stream-car s2))
      (error "-- zero " )
      (mul-series s1 (invert-unit-series s2))))

正接は sin/cos なので、

(define tangent-series
  (dev-series sine-series cosine-series))

SICP 3.4.2

3.38

3.38a

  1. Peter => Paul => Mary 45
  2. Peter => Mary => Paul 35
  3. Paul => Peter => Mary 45
  4. Paul => Mary => Peter 50
  5. Mary => Peter => Paul 40
  6. Mary => Paul => Peter 40

3.38b

以下のパターンが考えられる

  • 並列実行により、いずれか1人の残高反映が失われる
  • 同いずれか二人の残高反映が失われる

( ) が失われた処理

  1. Peter => Paul (Mary) 90
  2. Peter => Mary (Paul) 55
  3. Paul => Peter (Mary) 90
  4. Paul => Mary (Peter) 40
  5. Mary => Peter (Paul) 60
  6. Mary => Paul (Peter) 30
  7. Peter (Paul) (Mary) 110
  8. Paul (Peter) (Mary) 80
  9. Mary (Peter) (Mary) 50

3.39

起こりえるパターンは

  1. (* 10 10) => set! 100 => (+ 100 1) => set! x 101 101
  2. (* 10 10) => (+ 10 1) => set! 100 => set! x 11 11
  3. (* 10 10) => (+ 10 1) => set! x 11 => set! 100 100
  4. (+ 10 1) => set! x 11 => (* 11 11) => set! 121 121

4.40

  1. ( 10 10) => set 100 => ( 100 100 100) => set 1000000 1000000
  2. ( 10 10) => ( 10 10 10) => set 100 => set 1000 1000
  3. ( 10 10) => ( 10 10 10) => set 1000 => set 100 100
  4. ( 10 10 10) => set 1000 => ( 1000 1000) => set 1000000 1000000
  5. ( 10 10 10) => ( 10 10) => set 1000 => set 100 100
  6. ( 10 10 10) => ( 10 10) => set 100 => set 1000 1000

なお、serializeすると、1000000 だけになる。

3.41

不要。 balance は、処理が完了するまでは処理前の値を返す。 balance 自体は副作用を起こさないので、同時アクセスによる影響は無い。

3.42

安全かつ、差分はないように見える。 時間の浪費?という観点で言うと、make-accountの時点で serializeするので、 確かにdispatchの時点での処理時間は減るかもしれない。

3.43

交換は失敗するが合計は保持される場合 f:id:linus404:20170521092836p:plain

合計も保持されない場合 (不可分だった新残高計算と残高セットを分離している) f:id:linus404:20170521092843p:plain

3.44

Louisは誤っている。 送金の場合は、 differenceを計算する必要が無いので、3.43のような問題は発生しない

3.45

serialized-exchangeを行う際

(serializer1 (serializer2
  ((account1 'withdraw) difference)
  ((account2 'deposit) difference)))
=>
(serializer1 (serializer2
  ((serializer1 (withdraw account1 amount))
  (serializer2 (deposit account2 amount)))))

serializer1の中にserializer1があるので、この処理は永遠に終わらない

3.46

両方のプロセスが mutexを獲得できてしまう f:id:linus404:20170521092851p:plain

3.47

a

mutexを使った実装。 acquire されたら countを減らす。 count が 0 になるまでは acquireを許容。 release されたら countを増やす。

(define (make-semaphore)
  (let ((count n)
        (mutex1 make-mutex))
       (define (the-semaphore m)
         (cond
           ((eq m 'aquire)
              (mutex1 'aquire)
              (if (> count 0)
                  (begin
                    (set! count (- count 1))
                    (muxtex1 'release))
                  (begin
                    (mutex1 'release)
                    (the-semaphore m))))
           ((eq m 'release)
              (mutex1 'aquire)
              (set! count (+ count 1))
              (mutex1 'release))))
    the-semaphore))

b

方針は同じ. ただし、 test-and-set は 排他を採れたときにfalseを返すので分岐の順序が変わる

(define (make-semaphore)
  (let ((count n)
        (cell (list false)))
       (define (the-semaphore m)
         (cond
           ((eq m 'aquire)
              (if (test-and-set! cell)
                  (the-semaphore m)
                    (if (> count 0)
                      (begin
                        (set! count (- count 1))
                        (clear! cell))
                      (begin
                        (clear! cell)
                        (the-semaphore m)))))
           ((eq m 'release)
              (set! count (+ count 1)))))
    the-semaphore))

3.48

デッドロックが起きるのは、二者間で 保護した資源と 保護しようとした資源とが 相互に入れ替わってしまった場合である。 本文中で言うと、Peterのa1, Paulのa2 が保護した資源。Peterのa2とPaulのa1が保護しようとした資源。 この入れ替わりが発生しないようにするためには、保護する順番を全員が共通化する必要がある。 本文中で言うと、二人ともa1から保護しに行けば、デッドロックは発生し得ない。

#lang racket

(define (make-account balance id)
  (define (withdraw amount)
    (if (>= balance amount)
        (begin (set! balance (- balance amount))
               balance)
        "Insufficient funds"))
  (define (deposit amount)
    (set! balance (+ balance amount))
    balance)
  (let ((protected (make-serializer)))
    (define (dispatch m)
      (cond ((eq? m 'withdraw) (protected withdraw))
            ((eq? m 'deposit) (protected deposit))
            ((eq? m 'balance) balance)
            ((eq? m 'id) id)
            (else (error "Unknown request -- MAKE-ACCOUNT"
                         m))))
    dispatch))


(define (serialized-exchange account1 account2)
  (let ((serializer1 (account1 'serializer))
        (serializer2 (account2 'serializer)))
    (if (< (account1 'id) (account2 'id))
        ((serializer1 (serializer2 exchange)) account1 account2)
        ((serializer2 (serializer1 exchange)) account2 account1)
        )))

3.49

先行して保護した共有資源の処理結果に応じて、次に保護すべき資源が決まるような処理。 例を考えたが、思いつかなかった。。。

SICP 3.3.5

3.33

avalagerは以下の2パターンが考えられる f:id:linus404:20170305111521p:plain

;avalager
(define (avalager a b c)
  (let ((u (make-connector))
        (v (make-connector)))
    (adder a b u)
    (multiplier u v c)
    (constant 0.5 v)
    'ok))
;avalager
(define (avalager a b c)
  (let ((u (make-connector))
        (v (make-connector)))
    (adder a b u)
    (multiplier c v u)
    (constant 2 v)
    'ok))

動作確認

#lang racket

;helper

(define (adder a1 a2 sum)
  (define (process-new-value)
    (cond ((and (has-value? a1) (has-value? a2))
           (set-value! sum
                       (+ (get-value a1) (get-value a2))
                       me))
          ((and (has-value? a1) (has-value? sum))
           (set-value! a2
                       (- (get-value sum) (get-value a1))
                       me))
          ((and (has-value? a2) (has-value? sum))
           (set-value! a1
                       (- (get-value sum) (get-value a2))
                       me))))
  (define (process-forget-value)
    (forget-value! sum me)
    (forget-value! a1 me)
    (forget-value! a2 me)
    (process-new-value))
  (define (me request)
    (cond ((eq? request 'I-have-a-value)
           (process-new-value))
          ((eq? request 'I-lost-my-value)
           (process-forget-value))
          (else
           (error "Unknown request -- ADDER" request))))
  (connect a1 me)
  (connect a2 me)
  (connect sum me)
  me)


(define (inform-about-value constraint)
  (constraint 'I-have-a-value))


(define (inform-about-no-value constraint)
  (constraint 'I-lost-my-value))

(define (multiplier m1 m2 product)
  (define (process-new-value)
    (cond ((or (and (has-value? m1) (= (get-value m1) 0))
               (and (has-value? m2) (= (get-value m2) 0)))
           (set-value! product 0 me))
          ((and (has-value? m1) (has-value? m2))
           (set-value! product
                       (* (get-value m1) (get-value m2))
                       me))
          ((and (has-value? product) (has-value? m1))
           (set-value! m2
                       (/ (get-value product) (get-value m1))
                       me))
          ((and (has-value? product) (has-value? m2))
           (set-value! m1
                       (/ (get-value product) (get-value m2))
                       me))))
  (define (process-forget-value)
    (forget-value! product me)
    (forget-value! m1 me)
    (forget-value! m2 me)
    (process-new-value))
  (define (me request)
    (cond ((eq? request 'I-have-a-value)
           (process-new-value))
          ((eq? request 'I-lost-my-value)
           (process-forget-value))
          (else
           (error "Unknown request -- MULTIPLIER" request))))
  (connect m1 me)
  (connect m2 me)
  (connect product me)
  me)

(define (constant value connector)
  (define (me request)
    (error "Unknown request -- CONSTANT" request))
  (connect connector me)
  (set-value! connector value me)
  me)

(define (probe name connector)
  (define (print-probe value)
    (newline)
    (display "Probe: ")
    (display name)
    (display " = ")
    (display value))
  (define (process-new-value)
    (print-probe (get-value connector)))
  (define (process-forget-value)
    (print-probe "?"))
  (define (me request)
    (cond ((eq? request 'I-have-a-value)
           (process-new-value))
          ((eq? request 'I-lost-my-value)
           (process-forget-value))
          (else
           (error "Unknown request -- PROBE" request))))
  (connect connector me)
  me)


(define (make-connector)
  (let ((value false) (informant false) (constraints '()))
    (define (set-my-value newval setter)
      (cond ((not (has-value? me))
             (set! value newval)
             (set! informant setter)
             (for-each-except setter
                              inform-about-value
                              constraints))
            ((not (= value newval))
             (error "Contradiction" (list value newval)))
            (else 'ignored)))
    (define (forget-my-value retractor)
      (if (eq? retractor informant)
          (begin (set! informant false)
                 (for-each-except retractor
                                  inform-about-no-value
                                  constraints))
          'ignored))
    (define (connect new-constraint)
      (if (not (memq new-constraint constraints))
          (set! constraints
                (cons new-constraint constraints))
          'ignore)
      (if (has-value? me)
          (inform-about-value new-constraint)
          'ignore)
      'done)
    (define (me request)
      (cond ((eq? request 'has-value?)
             (if informant true false))
            ((eq? request 'value) value)
            ((eq? request 'set-value!) set-my-value)
            ((eq? request 'forget) forget-my-value)
            ((eq? request 'connect) connect)
            (else (error "Unknown operation -- CONNECTOR"
                         request))))
    me))

(define (for-each-except exception procedure list)
  (define (loop items)
    (cond ((null? items) 'done)
          ((eq? (car items) exception) (loop (cdr items)))
          (else (procedure (car items))
                (loop (cdr items)))))
  (loop list))


(define (has-value? connector)
  (connector 'has-value?))


(define (get-value connector)
  (connector 'value))


(define (set-value! connector new-value informant)
  ((connector 'set-value!) new-value informant))


(define (forget-value! connector retractor)
  ((connector 'forget) retractor))


(define (connect connector new-constraint)
  ((connector 'connect) new-constraint))


;avalager
(define (avalager a b c)
  (let ((u (make-connector))
        (v (make-connector)))
    (adder a b u)
    (multiplier u v c)
    (constant 0.5 v)
    'ok))

;test
(define (test-avg x y)
  (let ((a (make-connector))
        (b (make-connector))
        (c (make-connector)))
    (probe "avalage" c)
    (avalager a b c)
    (constant x a)
    (constant y b)
    'ok))

(test-avg 2 3)

3.34

乗算器としては問題ないが、以下のようなコードで平方根がとれない。

;test
(define x (make-connector))
(define y (make-connector))
(probe "x" x)
(probe "y" y)
(squarer x y)
(constant 4 y)

結果

#<procedure:me>
#<procedure:me>
#<procedure:me>

Probe: y = 4
#<procedure:me>

(multiplier m1 m2 product) は m1=m2 であることを知らないので、 productしか確定していない状態と解釈してしまう。

3.35

;helper
(define (square x) (* x x))

;squarer
(define (squarer a b)
  (define (process-new-value)
    (if (has-value? b)
        (if (< (get-value b) 0)
            (error "square less than 0 -- SQUARER" (get-value b))
            (set-value! a (sqrt (get-value b)) me))
        (if (has-value? a)
            (set-value! b (square (get-value a) me))
            'ignore)))
  (define (process-forget-value)
    (forget-value! a me)
    (forget-value! b me))
  (define (me request)
    (cond ((eq? request 'I-have-a-value)
           (process-new-value))
          ((eq? request 'I-lost-my-value)
           (process-forget-value))
          (else
           (error "Unkown request" request))))
  (connect a me)
  (connect b me)
  me)

;test
(define x (make-connector))
(define y (make-connector))
(probe "x" x)
(probe "y" y)
(squarer x y)
(constant 4 y)

3.37

(define (c+ x y)
  (let ((z (make-connector)))
    (adder x y z)
    z))
(define (c- x y)
  (let ((z (make-connector)))
    (adder y z x)
    z))
(define (c* x y)
  (let ((z (make-connector)))
    (multiplier x y z)
    z))
(define (c/ x y)
  (let ((z (make-connector)))
    (multiplier y z x)
    z))

(define (cv x)
  (let ((z (make-connector))