「計算機プログラムの構造と解釈」

計算プロセス(computational process)

基本式 組合せ法 抽象化法

環境(大域環境)

木構造のため込み(tree accumulation) (一般的)評価規則 特殊形式

合成手続き(compound procedure)

置換えモデル(substitution model) 作用的順序(normal-order evalution) 正規順序(applicative-order evalution)

Exercise 1.1

省略

Exercise 1.2

gosh> (/ (+ 5 4 (- 2 (- 3 (+ 6 (/ 4 5)))))
         (* 3 (- 6 2) (- 2 7)))
-37/150

Exercise 1.3

;; if
(define (f a b c)
  (if (>= a b)
      (if (>= b c)
          (+ (square a) (square b))
          (+ (square a) (square c)))
      (if (>= a c)
          (+ (square b) (square a))
          (+ (square b) (square c)))))

;; cond
(define (f a b c)
  (cond ((and (>= a b) (>= b c))
         (+ (square a) (square b)))
        ((and (>= a b) (>= c b))
         (+ (square a) (square c)))
        ((and (>= b a) (>= a c))
         (+ (square b) (square a)))
        ((and (>= b a) (>= c a))
         (+ (square b) (square c)))))

Exercise 1.4

(define (a-plus-abs-b a b)
  ((if (> b 0) + -) a b))

(a-plus-abs-b 1 2) を評価してみる。
a-plus-abs-b の本体をとりだす。
((if (> b 0) + -) a b)
仮引数a,bをそれぞれ1,2で置き換える。
((if (> 2 0) + -) 1 2)
合成式である演算子(if (> 2 0) + -)の値をとりだすと基本演算子+が得られ、
(+ 1 2) に帰着する。
3
になる。

Exercise 1.5

(define (p) (p))

(define (test x y)
  (if (= x 0)
      0
      y))

(test 0 (p))

作用的順序:
引数が評価され、0は0になる。(p)を評価すると(p)自身を呼ぶので、無限ループになる。

★手続きと引数はどちらが先に評価されるのか？
(R5RS 4.1.3 プロシージャ呼び出し
      演算子と被演算子が評価され(その順序は規定されてない)、
      結果として得られた手続きに結果として得られた引数が渡される。)

正規的順序:
testの本体を取り出す。
(if (= x 0) 0 y)
引数x,yを0,(p)で置き換える。
(if (= 0 0) 0 (p))
(= 0 0)は真を返すので0となり、(p)は評価されない。

Newton法 平方根

Exercise 1.6

(define (new-if predicate then-clause else-clause)
  (cond (predicate then-clause)
        (else else-clause)))

(new-if (= 2 3) 0 5)
;Value: 5

(new-if (= 1 1) 0 5)
;Value: 0

(define (sqrt-iter guess x)
  (new-if (good-enough? guess x)
          guess
          (sqrt-iter (improve guess x)
                     x)))

(sqrt-iter 1.0 3) を評価してみる。
sqrt-iterの本体を取り出し、仮引数guessとxを1.0と3で取り替えられ、
(new-if (good-enough? 1.0 3)
        1.0
        (sqrt-iter (improve 1.0 3)
                   3))
となり、new-if が評価される。しかし、new-if は手続きなので、引数がすべ
て評価されることになる。つまり、good-enough? の値の真偽にかかわらず、
sqrt-iter が常に評価される。その結果、new-if に展開され、引数の評価が無
限に続くことになる。
---
MIT Scheme で(sqrt-iter 1.0 3)を評価した結果、
;Aborting!: maximum recursion depth exceeded
とともに異常終了した。
Gauche で(sqrt-iter 1.0 3)を評価した結果、スタックオーバーフロー。

Exercise 1.7

・テストが失敗するケースがわからない。

・good-enough? の実装。
ある繰り返しの時点で、次の予測値を調べ、その変化率が非常に小さくなったら終る。
次の予測値は、(improve guess x) で得られる。
変化率は、(/ (- (improve guess x) guess) guess) で得られる。

(define (good-enough? guess x)
  (< (abs (/ (- (improve guess x) guess) guess)) 0.001))

Exercise 1.8

立方根をとるNewton法。SICP 1.1.7 の例と同じように考えた。

;; 立方根をとろうとする数 x と予測値 guess から出発する。予測値が目標に十分なら終わる。
;; そうでなければ、改善された予測値を使って手順を繰り返す。
(define (cube-root-iter guess x)
  (if (good-enough? guess x)
      guess
      (cube-root-iter (improve guess x)
                      x)))

;; 予測値を改善する。
(define (improve guess x)
  (/ (+ (/ x (square guess))
        (* 2 guess))
     3))

;; 予測値の3乗と立方根をとろうとする数の差が、許容値より小さい。
(define (good-enough? guess x)
  (< (abs (- (cube guess) x)) 0.001))

;; 予測値の初期値を1として計算を始める。
(define (cube-root x)
  (cube-root-iter 1.0 x))

;; 3乗と2乗
(define (cube x) (* x x x))
(define (square x) (* x x))

ブラックボックス抽象 手続き抽象(procedural abstraction) 束縛変数(bound variable) 束縛(bind) ブロック構造 レキシカルスコープ(lexical scoping)

局所的進化(local evolution)

線形再帰 反復 遅延演算 再帰的プロセス(recursive process) 線形再帰的プロセス(linear) 反復的プロセス(iterative process) 状態変数(state variable) 末尾再帰(tail recursion)

Exercise 1.9

(define (+ a b)
  (if (= a 0)
      b
      (inc (+ (dec a) b))))

(+ 4 5)
(inc (+ (dec 4) 5))
(inc (inc (+ (dec 3) 5)))
(inc (inc (inc (+ (dec 2) 5))))
(inc (inc (inc (inc (+ (dec 1) 5)))))
(inc (inc (inc (inc 5))))
(inc (inc (inc 6)))
(inc (inc 7))
(inc 8)
9
置き換えモデルは、膨張と収縮の形をとるので再帰的プロセス。

(define (+ a b)
  (if (= a 0)
      b
      (+ (dec a) (inc b))))

(+ 4 5)
(+ (dec 4) (inc 5))
(+ (dec 3) (inc 6))
(+ (dec 2) (inc 7))
(+ (dec 1) (inc 8))
9
置き換えモデルは膨張と収縮の形をとらないので反復的プロセス。

Exercise 1.10

Ackermann関数
 (define (A x y)
  (cond ((= y 0) 0)
        ((= x 0) (* 2 y))
        ((= y 1) 2)
        (else (A (- x 1)
                 (A x (- y 1))))))

(1)次の式の値は何か。
 (A 1 10)
;Value: 1024

(A 2 4)
;Value: 65536

(A 3 3)
;Value: 65536

(2)
(define (f n) (A 0 n))
(define (g n) (A 1 n))
(define (h n) (A 2 n))
と定義するとき、正の整数 n に対して、f,g,h が計算する関数の数学的定義を述べよ。

f: 2n を計算する関数。
g: 2^n を計算する関数。
h: ？

・(f 4)
(A 0 4)
(* 2 n) を返すので、2n を計算する関数。

・(g 4)
(A 1 4)
(A 0 (A 1 3))
(A 0 (A 0 (A 1 2)))
(A 0 (A 0 (A 0 (A 1 1))))
から、2^n を計算する関数。

・(h 1)
(A 2 1)
2

(A 2 1) は 2 を返す。

(h 2)
(A 2 2)
(A 1 (A 2 1))
4
(expt 2 2)

(h 3)
(A 2 3)
(A 1 (A 2 2))
(A 1 (A 1 (A 2 1)))
16
(expt 2 (expt 2 2))

(h 4)
(A 2 4)
(A 1 (A 2 3))
(A 1 (A 1 (A 2 2)))
(A 1 (A 1 (A 1 (A 2 1))))
65536
(expt 2 (expt 2 (expt 2 2)))
数学的にどう定義すればよいかは不明だった。

木構造再帰(tree recursion) フィボナッチ数列 黄金比 パスカルの三角形 メモ化(memoization)

Exercise 1.11

n < 3 に対して f(n) = n、 n > 3 に対して f(n) = f(n-1)+2f(n-2)+3f(n-3)
なる規則で定義する関数 f の、再帰的・反復的プロセスの方法で手続きを書け。

;; 再帰的
(define (f n)
  (if (< n 3)
      n
      (+ (* 1 (f (- n 1)))
         (* 2 (f (- n 2)))
         (* 3 (f (- n 3))))))

;; 反復的
(define (f-iter a b c count)
  (if (= count 0)
      c
      (f-iter (+ a (* 2 b) (* 3 c)) a b (- count 1))))

(define (f n)
  (f-iter 2 1 0 n))

;; 出力結果
(f 0)                                   ;0
(f 1)                                   ;1
(f 2)                                   ;2
(f 3)                                   ;4
(f 4)                                   ;11
(f 5)                                   ;25
(f 6)                                   ;59
(f 7)                                   ;142

Exercise 1.12

「パスカル三角形の要素を計算」の意味が不明だったので、
二項定理を用いて各行の要素の総和を求めることにした。
多分、解答になってない。

参考: http://www004.upp.so-net.ne.jp/s_honma/pascal/pascal.htm
nCk = n!/k!(n-k)!

(define (factorial n)
  (define (iter product counter)
    (if (> counter n)
        product
        (iter (* product counter) (+ counter 1))))
  (iter 1 1))

(define (nCk n k)
  (/ (factorial n) (* (factorial k) (factorial (- n k)))))

(define (pascal-iter k n)
  (if (> k n)
      0
      (+ (nCk n k) (pascal-iter (+ k 1) n))))

(define (pascal n)
  (pascal-iter 0 n))

(pascal 0)                              ;1
(pascal 1)                              ;2
(pascal 2)                              ;4
(pascal 3)                              ;8
(pascal 4)                              ;16
(pascal 5)                              ;32
(pascal 6)                              ;64

Exercise 1.13

φ = (1 + (sqrt 5))/2 とし、
ψ = (1 - (sqrt 5))/2 とし、
fib(n) が (φ^n - ψ^n)/(sqrt 5) に最も近い整数になっていることだけを確認することにした。
sqrt の精度が低いので十分確認できなかった(Exercise1-7 に問題がある)。

;; 2乗
(define (square x) (* x x))

;; 平方根
(define (sqrt x)
  (define (good-enough? guess x)
    (< (abs (/ (- (improve guess x) guess) guess)) 0.001))
  (define (average x y)
    (/ (+ x y) 2))
  (define (improve guess x)
    (average guess (/ x guess)))
  (define (sqrt-iter guess x)
    (if (good-enough? guess x)
        guess
        (sqrt-iter (improve guess x)
                   x)))
  (sqrt-iter 1.0 x))

;; べき乗
(define (power n k)
  (if (= k 0)
      1
      (* n (power n (- k 1)))))

(define (test n)
  (define psi (/ (- 1 (sqrt 5)) 2))
  (define phi (/ (+ 1 (sqrt 5)) 2))
  (/ (- (power phi n) (power psi n)) (sqrt 5)))

(test 10)                               ;Value: 55.29535579685757
(fib 10)                                ;55

(test 1)                                ;1
(fib 1)                                 ;1
(test 2)                                ;1.0
(test 3)                                ;2.002267573696145
(fib 3)                                 ;2
(test 4)                                ;3.00453514739229
(fib 4)                                 ;3
(test 5)                                ;5.011343010371192
(fib 5)                                 ;5
(test 6)                                ;8.022691162632853
(fib 6)                                 ;8
(test 7)                                ;13.045397762596725
(fib 7)                                 ;13
(test 8)                                ;21.086280968682264
(fib 8)                                 ;21

(test 50)                               ;12974856168.405893
(fib 50)                                ;12586269025

(test 100)                              ;3.767763786556457e20
(fib 100)                               ;354224848179261915075

計算量 ステップ数 スペース

Exercise 1.14

未解答

Exercise 1.15

(a) p は、(> (abs angle) 0.1)を満たすとき呼ばれるので、
はじめに1回呼ばれ、angleを(/ angle 3.0)として(> (abs angle) 0.1)
を満たす限り呼ばれる。したがって、以下のとおり5回。

(/ 12.15 3.0)                           ;4.05
(/ 4.05 3.0)                            ;1.3499999999999999
(/ 1.3499999999999999 3.0)              ;.44999999999999996
(/ .44999999999999996 3.0)              ;.15
(/ .15 3.0)                             ;4.9999999999999996e-2

(b) 解らない。
適当に答えると、ステップ数はθ(3a)に比例して増加し、スペースもθ(3a)で増加する。

べき乗(expt) 不変量

Exercise 1.16

;; http://ja.wikipedia.org/wiki/%E5%86%AA%E4%B9%97
;; 効率的演算法 の最初の方法から着想

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

(define (even? n)
  (= (remainder n 2) 0))

(define (fast-expt-iter a b n)
  (cond ((= n 0) a)
        ((even? n) (fast-expt-iter a (square b) (/ n 2)))
        (else (fast-expt-iter (* a b) b (- n 1)))))

(define (fast-expt b n)
  (fast-expt-iter 1 b n))

Exercise 1.17

(define (halve x) (/ x 2))
(define (double x) (* x 2))
(define (even? n)
  (= (remainder n 2) 0))

(define (x a b)
  (cond ((= b 0) 0)
        ((even? b) (double (x a (halve b))))
        (else (+ a (x a (- b 1))))))

gosh> (x 123 4567890987654321)
561850591481481483
gosh> (* 123 4567890987654321)
561850591481481483

Exercise 1.18

Exercise1-16 と同じ形なので、そのままあてはめた。

(define (double x) (+ x x))

(define (x a b)
  (x-iter 0 a b))

(define (x-iter product a b)
  (cond ((= b 0) product)
        ((even? b) (x-iter product (double a) (/ b 2)))
        (else (x-iter (+ a product) a (- b 1)))))

Exercise 1.19

未解答

最大公約数(GCD) ユークリッドの互除法

Exercise 1.20

Alyssaさんの指摘を受けて修正した。当初、if式の中での評価を考えていなかった。

;; 正規順序
正規順序による (gcd 206 40) の評価は次のように進行する。

if:(= 40 0) => #f
else:(gcd 40 (remainder 206 40))

if:(= (remainder 206 40) 0) => #f
else:(gcd (remainder 206 40)
          (remainder 40 (remainder 206 40)))
 
if:(= (remainder 40 (remainder 206 40)) 0) => #f
else:(gcd (remainder 40 (remainder 206 40))
          (remainder (remainder 206 40) (remainder 40 (remainder 206 40))))

if:(= (remainder (remainder 206 40) (remainder 40 (remainder 206 40))) 0) => #f
else:(gcd (remainder (remainder 206 40) (remainder 40 (remainder 206 40)))
          (remainder (remainder 40 (remainder 206 40))
                     (remainder (remainder 206 40) (remainder 40 (remainder 206 40)))))

if:(= (remainder (remainder 40 (remainder 206 40))
                 (remainder (remainder 206 40) (remainder 40 (remainder 206 40)))) 0) => #t
then:(remainder (remainder 206 40) (remainder 40 (remainder 206 40)))
=>2

となる。結局 remainder 演算が実行されるのは、if式の中で14回、最後に簡
約されるとき4回であり、計18回実行される。

;; 作用的順序
(gcd 206 40)
作用的順序による評価は次のように進行する。
(gcd 40 6)                              ;6: (remainder 206 40)
(gcd 6 4)                               ;4: (remainder 40 6)
(gcd 4 2)                               ;2: (remainder 6 4)
(gcd 2 0)                               ;0: (remainder 4 2)
2
 引数が評価されてから作用させるので、remainder は 4回実行される。

素数 フェルマーテスト フェルマーの小定理 法として合同 カーマイケル数 確率的アルゴリズム

Exercise 1.21

199, 1999, 19999 の最小除数

(smallest-divisor 199)
;Value: 199
(smallest-divisor 1999)
;Value: 1999
(smallest-divisor 19999)
;Value: 7

Exercise 1.22

指定範囲の連続する奇整数について素数性を調べる手続き search-for-prime を書け

;; 素数でない整数は出力しないようにした。
(define (search-for-prime start limit)
  (if (prime? start)
      (times-prime-test start))
  (if (<= (+ start 2) limit)
      (search-for-prime (+ start 2) limit)))

;; 速すぎて計測できないので大きな数で試した。
(search-for-prime 1000001 1000100)
1000003 *** 1.0000000000000009e-2
1000033 *** 1.0000000000000009e-2
1000037 *** 1.0000000000000009e-2

(search-for-prime 10000001 10000200)
10000019 *** .01999999999999602
10000079 *** .03999999999999915
10000103 *** 2.0000000000003126e-2

(search-for-prime 100000001 100000100)
100000007 *** .11999999999999744
100000037 *** 6.0000000000002274e-2
100000039 *** 6.0000000000002274e-2

ひと桁増えると計算時間がほぼ√10倍になると思うので、
・支持する。
・合っている。

Exercise 1.23

(define (next n)
  (if (= n 2)
      3
      (+ n 2)))

(define (find-divisor n test-divisor)
  (cond ((> (square test-divisor) n) n)
        ((divides? test-divisor n) test-divisor)
        (else (find-divisor n (next test-divisor)))))

(times-prime-test 1000003)
1000003 *** .00999999999999801
(times-prime-test 10000019)
10000019 *** 3.0000000000001137e-2
(times-prime-test 100000007)
100000007 *** .10999999999999943

速度に変化はないと思う。しかし理由が解らない。

Exercise 1.24

未解答

Exercise 1.25

未解答

Exercise 1.26

未解答

Exercise 1.27

カーマイケル数がフェルマーテストをだますことを示せ。

(define true #t)
(define false #f)

(define (carmichael-deceive-fermat-test? carmichael)
  (define (iter a n)
    (if (< a n)
        (if (= (expmod a n n) a)
            (iter (+ a 1) n)
            false)
        true))
  (iter 1 carmichael))

(carmichael-deceive-fermat-test? 561)   ;=> #t
(carmichael-deceive-fermat-test? 1105)  ;=> #t
(carmichael-deceive-fermat-test? 1729)  ;=> #t
(carmichael-deceive-fermat-test? 2465)  ;=> #t
(carmichael-deceive-fermat-test? 2821)  ;=> #t
(carmichael-deceive-fermat-test? 6601)  ;=> #t

以上から、整数 n について a < n のすべての a で、a^n が n を法として a と合同になる
素数でない n が存在することが分かるので、カーマイケル数はフェルマーテストをだます。

Exercise 1.28

未解答

高階手続き

級数の総和 Simpsonの公式 John Wallis アキュムレーション フィルタ

Exercise 1.29

;; 合成シンプソン公式を参考にした。
http://ja.wikipedia.org/wiki/%E3%82%B7%E3%83%B3%E3%83%97%E3%82%BD%E3%83%B3%E3%81%AE%E5%85%AC%E5%BC%8F

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

(define (integral f a b n)
  (define h (/ (- b a) n))
  (define (y k) (f (+ a (* k h))))
  (define (next n) (+ n 2))
  (/ (* h
        (+ (y 0)
           (* (sum y 1 next (- n 1)) 4)
           (* (sum y 2 next (- n 2)) 2)
           (y n)))
     3))

(integral cube 0 1 100)
=>1/4
(integral cube 0 1 1000)
=>1/4

Exercise 1.30

(define (sum term a next b)
  (define (iter a result)
    (if (> a b)
        result
        (iter (next a) (+ (term a) result))))
  (iter a 0))

Exercise 1.31

(a)
(1)与えられた範囲の点での関数値の積を返す手続き product を定義せよ。
(2)product を使って factorial を定義せよ。
(3)式 π/4 = (2*4*4*6*6*8..)/(3*3*5*5*7*7...) によってπの近似値を
   productを使って定義せよ。

(1)
(define (product term a next b)
  (if (> a b)
      1
      (* (term a) (product term (next a) next b))))

(2)
(define (factorial n)
  (product identity 1 inc n))

(3)
;; John Wallis
;; http://www.pluto.ai.kyutech.ac.jp/plt/matumoto/pi_small/node5.html
(define (pi-product a b)
  (define (pi-term x)
    (/ (* (* x 2) (+ (* x 2) 2))
       (square (+ (* x 2) 1))))
  (define (pi-next x) (+ x 1))
  (product pi-term a pi-next b))

gosh> (* 4 (pi-product 1.0 1000))
=>3.1423773650938855

(b) 反復的プロセスを生成する product を書け。

(define (product term a next b)
  (define (iter a result)
    (if (> a b)
        result
        (iter (next a) (* (term a) result))))
  (iter a 1))

Exercise 1.32

(a) sum や product 更に一般的な accumulate の特殊な場合であることを示せ。

;; 再帰的プロセス版
(define (accumulate combiner null-value term a next b)
  (if (> a b)
      null-value
      (combiner (term a)
                (accumulate combiner null-value term (next a) next b))))

(define (sum term a next b)
  (accumulate + 0 term a next b))

(define (product term a next b)
  (accumulate * 1 term a next b))

(b) 反復的プロセスを生成する版

(define (accumulate combiner null-value term a next b)
  (define (iter a result)
    (if (> a b)
        result
        (iter (next a) (combiner (term a) result))))
  (iter a null-value))

Exercise 1.33

;; 再帰版
(define (filtered-accumulate predicate combiner null-value term a next b)
  (cond ((> a b) null-value)
        ((predicate a)
         (combiner (term a)
                   (filtered-accumulate
                    predicate combiner null-value term (next a) next b)))
        (else (filtered-accumulate
               predicate combiner null-value term (next a) next b))))

;; 反復版
(define (filtered-accumulate predicate combiner null-value term a next b)
  (define (iter a result)
    (cond ((> a b) result)
          ((predicate a) (iter (next a) (combiner (term a) result)))
          (else (iter (next a) result))))
  (iter a null-value))

(a) 素数の2乗の和
(define (sum-squared-prime-numbers a b)
  (filtered-accumulate prime? + 0 square a inc b))

(sum-squared-prime-numbers 2 10)
;Value: 87
  
(b) i < n で gcd(i,n) = 1 となる全整数の積

 (define (product-gcd n)
  (define (p i)
    (= (gcd i n) 1))
  (filtered-accumulate p * 1 identity 1 inc n))

(product-gcd 10)
;Value: 189

(product-gcd 100)
;Value: 426252881942771063138176712755660145456313428952105524817872601

Exercise 1.34

(define (f g)
  (g 2))

解釈系に (f f) を評価させるとどうなるか。

f の本体を取り出し仮引数 g を f で置き換える。
(f 2)
f の本体を取り出し仮引数 g を 2 で置き換える。
(2 2)
に帰着する。左端の演算子を評価すると値は 2 となる。値は手続きでなければならないが、
数値なのでエラーになる。

MIT scheme での結果。
;The object 2 is not applicable.
Gauche での結果。
*** ERROR: invalid application: (2 2)

区間二分法(half-interval method) 関数の不動点(fixed point) 平方根 黄金比(golden ratio) 平均緩和法(average damping) 連分数(continued fraction) オイラーの展開 自然対数の底

記法： "|->" 「写像する」と読む。

Exercise 1.35

1.2.2節の黄金比は、x^2 = x + 1 を満たす x である。
これを等価な、x = 1 + 1/x と書けば、平方根の計算と同様、x |-> 1 + 1/x の不動点を
探すことと同じである。

gosh> (fixed-point (lambda (x) (+ 1 (/ 1 x))) 1.0)
=>1.6180327868852458

Exercise 1.36

(1) fixed-point を修正して、生成する近似値を順に印字できるようにせよ。

(define (average x y) (/ (+ x y) 2))

(define tolerance 0.00001)

(define (fixed-point f first-guess)
  (define (close-enough? v1 v2)
    (< (abs (- v1 v2)) tolerance))
  (define (try guess step)
    (let ((next (f guess)))
      (print-step next step)
      (if (close-enough? guess next)
          next
          (try next (+ step 1)))))
  (try first-guess 1))

(define (print-step n step)
  (display step)
  (display ": ")
  (display n)
  (newline))

(2) x^x = 1000 の解を求めよ。

(expt 4 4) < 1000 < (expt 5 5) なので、4.0 を fixed-point の予測値とした。

gosh> (fixed-point (lambda (x) (/ (log 1000) (log x))) 4.0)
1: 4.9828921423310435
2: 4.301189432497896
3: 4.734933901055578
(略)
27: 4.555543703263474
28: 4.555530430629037
29: 4.555539183677709
=>4.555539183677709

gosh> (expt 4.555539183677709 4.555539183677709)
=>1000.0087530953886

(3) 平均緩和法を使った場合とステップ数を比較せよ。

gosh> (fixed-point (lambda (x) (average (/ (log 1000) (log x)) x)) 4.0)
1: 4.491446071165521
2: 4.544974650975552
3: 4.553746974742814
4: 4.555231425802502
5: 4.555483906560562
6: 4.5555268862194875
7: 4.5555342036887705
=>4.5555342036887705

gosh> (expt 4.5555342036887705 4.5555342036887705)
=>999.9962217021748

平均緩和法を使った場合、ステップ数は 1/4 になった。

Exercise 1.37

(a) k項有限連分数を計算する手続きを定義し、kの順次の値で1/φの近似をとり手続きを調べよ。
    4桁の精度を得るにはkをどのくらいの大きさにしなければならないか。

(1) cont-frac

;; 再帰的プロセス版
(define (cont-frac n d k)
  (define (rec i)
    (if (= i k)
        (/ (n i) (d i))
        (/ (n i) (+ (d i) (rec (+ i 1))))))
  (rec 1))

(2) kの大きさ

1/φ の計算
gosh> (/ 1 (fixed-point (lambda (x) (+ 1 (/ 1 x))) 1.0))
=>0.6180344478216819

手続きを調べるため cont-frac-test を定義し、kの値が1から15まで1/φの近似を調べた。
kの増加に伴って精度が上がることを確認した。4桁の精度を得るには、kの値は11程度でよい。

(define (cont-frac-test a b)
  (if (<= a b)
      (let ((r (cont-frac (lambda (i) 1.0)
                          (lambda (i) 1.0)
                          a)))
        (display a)
        (display ": ")
        (display r)
        (newline)
        (cont-frac-test (+ a 1) b))))

gosh> (cont-frac-test 1 15)
1: 1.0
2: 0.5
3: 0.6666666666666666
4: 0.6000000000000001
5: 0.625
6: 0.6153846153846154
7: 0.6190476190476191
8: 0.6176470588235294
9: 0.6181818181818182
10: 0.6179775280898876
11: 0.6180555555555556
12: 0.6180257510729613
13: 0.6180371352785146
14: 0.6180327868852459
15: 0.6180344478216819

(b) cont-frac の反復的プロセス版

(define (cont-frac n d k)
  (define (iter a i)
    (if (= i 1)
        a
        (iter (/ (n (- i 1)) (+ (d (- i 1)) a)) (- i 1))))
  (iter (/ (n k) (d k)) k))

Exercise 1.38

オイラーの展開による自然対数の底を近似するプログラムを書け。

;; e-2-cfの計算でkが20程度で15桁の精度が得られたので、
;; kを20としてeを近似するプログラムを書いた。

(define (e)
  (define (e-2-cf k)
    (cont-frac (lambda (i) 1.0)
               (lambda (i) (if (= (remainder i 3) 2)
                               (- i (- (/ (+ i 1) 3) 1))
                               1.0))
               k))
  (+ (e-2-cf 20) 2))

gosh> (e)
=>2.718281828459045

Exercise 1.39

正接関数の近似値を計算する手続き(tan-cf x k)を定義せよ。

(define (tan-cf x k)
  (cont-frac (lambda (i) (if (= i 1) x (- (* x x))))
             (lambda (i) (- (* i 2) 1))
             k))

微分(derivation) Newton法 合成関数 平滑化関数 反復改良法

Exercise 1.40

cubicを定義せよ。

(define (cubic a b c)
  (lambda (x)
    (+ (* x x x) (* a (* x x)) (* b x) c)))

Exercise 1.41

1引数の手続きをとり、それを2回作用させる手続きを返す手続き double を定義せよ。

(define (double f)
  (lambda (x) (f (f x))))

次の式はどんな値を返すか。

(((double (double double)) inc) 5)
=>21

Exercise 1.42

f と g を1引数の関数とし、g の後の f の合成関数は関数 x |-> f(g(x)) と定義する。
合成関数を実装する手続き compose を定義せよ。

(define (compose f g)
  (lambda (x) (f (g x))))

((compose square inc) 6)
=>49

Exercise 1.43

数値関数fと正整数nをとり、fのn回作用関数を定義せよ。

;; 再帰的プロセス版
(define (repeated f n)
  (if (= n 1)
      f
      (compose f (repeated f (- n 1)))))

((repeated square 2) 5)
=>625

;; 反復的プロセス版
(define (repeated f n)
  (define (iter a n)
    (if (= n 1)
        a
        (iter (compose f a) (- n 1))))
  (iter f n))

((repeated square 2) 5)
=>625

Exercise 1.44

1. smooth を書け。

(define dx 0.00001)

(define (smooth f)
  (lambda (x)
    (/ (+ (f (- x dx)) (f x) (f (+ x dx)))
       3)))

2. n重平滑化関数を作る方法を示せ。

n重平滑化関数を得るには、与えられた関数 f の平滑化関数 (smooth f) を、
repeated を用いて n 回作用させればよい。

(define (n-fold-smooth f n)
  (repeated (smooth f) n))

Exercise 1.45

未解答

Exercise 1.46

未解答

合成データオブジェクト データ抽象(data abstraction) 抽象の防壁(abstraction barrier) 糊 クロージャ(closure) 公認インターフェイス データ主導プログラミング

選択子(selectors) 構成子(constructors) 希望的思考の戦略 有理数の表現 consで構成される対(pair)

Exercise 2.1

正負両方の引数を扱う改良版 make-rat を定義せよ。

(define (make-rat n d)
  (let ((g (gcd n d)))
    (cond ((or (and (positive? n) (negative? d))
               (and (negative? n) (negative? d)))
           (cons (/ (- n) g) (/ (- d) g)))
          ((and (= n 0) (negative? d))
           (cons (/ n g) (/ (- d) g)))
          (else
           (cons (/ n g) (/ d g))))))

(print-rat (make-rat 2 3))              ;=> 2/3
(print-rat (make-rat -2 3))             ;=> -2/3
(print-rat (make-rat 2 -3))             ;=> -2/3
(print-rat (make-rat -2 -3))            ;=> 2/3
(print-rat (make-rat -0 3))             ;=> 0/1
(print-rat (make-rat 0 -3))             ;=> 0/1
(print-rat (make-rat -0 -3))            ;=> 0/1

Exercise 2.2

平面上の線分を表現する。
1. 線分の表現を定義する構成子 make-segment と選択子 start-segment,end-segment を定義せよ。
2. 点の表現を定義する構成子 make-point と選択子 x-point,y-point を定義せよ。
3. 引数として線分をとり、中間点を返す手続き midpoint-segment を定義せよ。

(define (make-segment start-point end-point)
  (cons start-point end-point))
(define (start-segment s) (car s))
(define (end-segment s) (cdr s))

(define (make-point x y) (cons x y))
(define (x-point p) (car p))
(define (y-point p) (cdr p))

(define (midpoint-segment s)
  (let ((start-point (start-segment s))
        (end-point (end-segment s)))
    (make-point (/ (+ (x-point start-point) (x-point end-point)) 2)
                (/ (+ (y-point start-point) (y-point end-point)) 2))))

;; 実行例
(define p1 (make-point 1 3))            ;点1を定義
(define p2 (make-point 5 9))            ;点2を定義
(define s1 (make-segment p1 p2))        ;線分1を定義

(print-point (start-segment s1))        ;線分1の開始点を印字
=>(1,3)
(print-point (end-segment s1))          ;線分1の終着点を印字
=>(5,9)
(print-point (midpoint-segment s1))     ;線分1の中間点を印字
=>(3,6)

(define p3 (make-point -1 -3))          ;点3を定義
(define s2 (make-segment p3 p2))        ;線分2を定義

(print-point (start-segment s2))        ;線分2の開始点を印字
=>(-1,-3)
(print-point (end-segment s2))          ;線分2の終着点を印字
=>(5,9)
(print-point (midpoint-segment s2))     ;線分2の中間点を印字
=>(2,3)

Exercise 2.3

長方形は高さと幅をもった領域として表現できる。それぞれ長方形を引数として受
けとり、その周囲の長さと面積を計算する手続きを、rect-perimeter,
rect-area とする。長方形の表現を定義する構成子を make-rect 長方形の高さ
と幅を取り出す選択子を rect-height, rect-width とすると、rect-perimeter
と rect-area は次のように定義できる。

(define (rect-perimeter rect)
  (+ (* (rect-height rect) 2)
     (* (rect-width rect) 2)))

(define (rect-area rect)
  (* (rect-height rect) (rect-width rect)))

長方形を高さと幅の対で表現すれば、make-rect, rect-height, rect-width は
次のように実装できる。

(define (make-rect height width) (cons height width))
(define (rect-height rect) (car rect))
(define (rect-width rect) (cdr rect))

[周囲の長さと面積の計算]
(define rect1 (make-rect 3 4))
(rect-perimeter rect1)                  ;=> 14
(rect-area rect1)                       ;=> 12

[別な長方形の表現]

長方形は中間点と長さが同じ2つの線分を対角線として、その4つの端点を結ん
だ領域として表現できる。対角線は1対の点で表現される(Exercise 2.2)。対角
線を使って長方形の表現を定義する構成子 make-rect と長方形の2つの対角線
を取り出す選択子 first-diagonal, second-diagonal と長方形の高さと幅を計
算する手続き rect-height, rect-width を定義する。線分の幅を求める
length-segment も必要なので定義する。対角線の開始点は終了点より左にある
と仮定する。また、ユーザーが与える2つの対角線は中間点と長さが同一で異な
る線分であると仮定する。

(define (make-rect diagonal1 diagonal2)
  (cons diagonal1 diagonal2))

(define (first-diagonal rect) (car rect))
(define (second-diagonal rect) (cdr rect))

(define (length-segment s)
  (let ((start-point (start-segment s))
        (end-point (end-segment s)))
    (sqrt (+ (square (- (x-point end-point) (x-point start-point)))
             (square (- (y-point end-point) (y-point start-point)))))))

(define (rect-height rect)
  (let ((start-h-point (start-segment (first-diagonal rect)))
        (end-h-point (start-segment (second-diagonal rect))))
    (length-segment (make-segment start-h-point end-h-point))))

(define (rect-width rect)
  (let ((start-w-point (start-segment (first-diagonal rect)))
        (end-w-point (end-segment (second-diagonal rect))))
    (length-segment (make-segment start-w-point end-w-point))))

[周囲の長さと面積の計算]
(define d1 (make-segment (make-point -7 3) (make-point 2 -5)))
(define d2 (make-segment (make-point -7 -5) (make-point 2 3)))
(define rect2 (make-rect d1 d2))
(rect-height rect2)                     ;=> 8
(rect-width rect2)                      ;=> 9
(rect-perimeter rect2)                  ;=> 34
(rect-area rect2)                       ;=> 72

周囲と面積を計算する手続きは、どちらの長方形の表現でも働く。

メッセージパッシング

Exercise 2.4

次の cons について任意のオブジェクト x と y に対し、(car (cons x y)) が
x を生じることを証明せよ。また cdr を定義せよ。

(define (cons x y)
  (lambda (m) (m x y)))

(define (car z)
  (z (lambda (p q) p)))

(car (cons 3 4)) を評価する。
cons の本体を取り出し、仮引数を 3 と 4 で置き換える。

(lambda (m) (m 3 4)) になる。

car の本体を取り出し、仮引数を (lambda (m) (m 3 4)) で置き換える。

((lambda (m) (m 3 4)) (lambda (p q) p)) になる。

左端の手続きは、引数を1つとり、それを 3 と 4 に作用させるものである。
手続きの本体を取り出し、引数の手続き (lambda (p q) p) で置き換える。

((lambda (p q) p) 3 4) になる。

手続き (lambda (p q) p) は、引数を2つとり、最初の引数を返す。
手続きを引数 3 と 4 に作用させると 3 を返す。
したがって、(car (cons x y)) は、x を生じる。

cdr も同様に手続きを引数としてとり、引数を2つとり2番目の引数を返す手続きに
作用させる関数として定義できる。

(define (cdr z)
  (z (lambda (p q) q)))

(cdr (cons 3 4))
=>4

Exercise 2.5

未解答

Exercise 2.6

チャーチ数(Church numerals)

(define zero (lambda (f) (lambda (x) x)))

(define (add-1 n)
  (lambda (f) (lambda (x) (f ((n f) x)))))

1. one と two を定義せよ。
2. + を定義せよ。

1
one は、(add-1 zero) の返す値なので、(add-1 zero) を評価してみる。

add-1 の本体をとりだす。

(lambda (f) (lambda (x) (f ((n f) x))))

仮引数 n を zero で置き換える。

(lambda (f) (lambda (x) (f (((lambda (f) (lambda (x) x)) f) x)))) の評価に帰着する。

((lambda (f) (lambda (x) x)) f) は、(lambda (x) x) を返すので、

(lambda (f) (lambda (x) (f ((lambda (x) x) x)))) になる。

((lambda (x) x) x) は、x を返すので、

(lambda (f) (lambda (x) (f x))) に帰着する。

したがって、one は次のように定義できる。

(define one (lambda (f) (lambda (x) (f x))))

同様に、two は、(add-1 one) の返す値なので、(add-1 one) を評価すると次のように定義できる。

add-1 の本体をとりだし、仮引数 n を one で置き換える。

(lambda (f) (lambda (x) (f (((lambda (f) (lambda (x) (f x))) f) x)))) の評価に帰着する。

(((lambda (f) (lambda (x) (f x))) f) x) は、((lambda (x) (f x)) x) となりさらに、
(f x) となるので、

(lambda (f) (lambda (x) (f (f x)))) に帰着する。

(define two (lambda (f) (lambda (x) (f (f x)))))

2

区間算術演算

Exercise 2.7

選択子 upper-bound と lower-bound を定義せよ。

(define (upper-bound x) (max (car x) (cdr x)))
(define (lower-bound x) (min (car x) (cdr x)))

Exercise 2.8

区間の差の計算法を書け。対応する sub-interval を定義せよ。

差の最小値は下限の差であり、最大値は上限の差と考える。

(define (sub-interval x y)
  (make-interval (- (lower-bound x) (lower-bound y))
                 (- (upper-bound x) (upper-bound y))))

Exercise 2.9

区間の幅は区間の上限と下限の差の半分です。幅は区間によって規定された数
の不確かさの量です。ある算術演算では、ふたつの区間を演算した結果の幅は、
引数の区間の幅だけからなる関数ですが、他の演算では結果の幅は引数の区間
の幅の関数ではありません。ふたつの区間の和(差)の幅が、足される(引かれ
る)区間の幅だけからなる関数であることを示してください。乗算と除算には、
これが成り立たないことを例を挙げて示してください。(問題文の私訳)

区間の幅は上限と下限の差の半分だから次のように定義できる。

(define (width-interval x)
  (/ (- (upper-bound x) (lower-bound x)) 2.0))

区間の和の幅は、(width-interval (add-interval x y)) で得られる。
(add-interval x y) は、

(make-interval (+ (lower-bound x) (lower-bound y))  ;下限
               (+ (upper-bound x) (upper-bound y))) ;上限

となり、下限と上限の対である。したがって和の幅は、

(/ (- (+ (upper-bound x) (upper-bound y))  ;上限
      (+ (lower-bound x) (lower-bound y))) ;下限
   2.0)

となり、

(+ (/ (- (upper-bound x) (lower-bound x)) 2.0)
   (/ (- (upper-bound y) (lower-bound y)) 2.0))

とすれば、

(+ (width-interval x) (width-interval y)) となり区間の幅に関する関数になる。

区間の差の幅も同様に、
(make-interval (- (lower-bound x) (lower-bound y))  ;下限
               (- (upper-bound x) (upper-bound y))) ;上限

から、

(/ (- (- (upper-bound x) (upper-bound y))  ;上限
      (- (lower-bound x) (lower-bound y))) ;下限
   2.0)

となり、

(- (/ (- (upper-bound x) (lower-bound x)) 2.0)
   (/ (- (upper-bound y) (lower-bound y)) 2.0))

とすれば、

(- (width-interval x) (width-interval y)) となり区間の幅に関する関数になる。

Exercise 2.10

未解答

Exercise 2.11

未解答

Exercise 2.12

make-center-parcent と percent を定義せよ。

(define (make-center-parcent c p)
  (let ((w (* c (/ p 100.0))))
    (make-interval (- c w) (+ c w))))

(define (percent i)
  (let ((c (center i)))
    (/ (* (- (upper-bound i) c) 100.0) c)))

Exercise 2.13

未解答

Exercise 2.14

未解答

Exercise 2.15

未解答

Exercise 2.16

未解答

箱とポインタ記法 consの閉包性

並びの表現 リスト演算 cdrダウン consアップ リストの写像

Exercise 2.17

(空でない)リストの最後の要素だけからなるリストを返す last-pair を定義せよ。

・リストのcdrが空リストなら、last-pair はそのリストを返す。
・そうでなければ、last-pair はリストのcdrを返す。

(define (last-pair items)
  (if (null? (cdr items))
      items
      (last-pair (cdr items))))

(last-pair (list 23 72 149 34))
=>(34)

Exercise 2.18

逆順のリストを返す手続き reverse を定義せよ。

・引数のリストが空リストなら、reverse したリストも空リストである。
・空リストでなければ、リストの car を要素とするリストに、
  リストの cdr を reverse したリストを append する。

(define (reverse ls)
  (if (null? ls)
      '()                               ;nil
      (append (reverse (cdr ls)) (list (car ls)))))

;; 反復版
(define (reverse items)
  (define (reverse-iter a items)
    (if (null? items)
        a
        (reverse-iter (cons (car items) a) (cdr items))))
  (reverse-iter '() items))

(reverse (list 1 4 9 16 25))
=>(25 16 9 4 1)

Exercise 2.19

first-denomination, except-first-denomination, no-more? を
1. リスト構造の基本的演算を使って定義せよ。
2. coin-values の順は、cc の答に影響があるか。なぜか。

1
(define (first-denomination coin-values)
  (car coin-values))

(define (except-first-denomination coin-values)
  (cdr coin-values))

(define (no-more? coin-values)
  (null? coin-values))

(cc 100 us-coins)
=>292

2

Exercise 2.20

1個以上の整数をとり、先頭の引数と同じ偶奇性を持つ引数のリストを返す手続き
same-parity を定義せよ。

;; append を利用
 (define (same-parity ca . cd)
   (define (iter cd a)
     (if (null? cd)
         a
         (let ((obj (car cd)))
           (if (= (remainder ca 2) (remainder obj 2))
               (iter (cdr cd) (append a (list obj)))
               (iter (cdr cd) a)))))
   (iter cd (list ca)))

;; reverse を利用
(define (same-parity ca . cd)
  (define (iter cd a)
    (if (null? cd)
        (reverse a)
        (let ((obj (car cd)))
          (if (= (remainder ca 2) (remainder obj 2))
              (iter (cdr cd) (cons obj a))
              (iter (cdr cd) a)))))
  (iter cd (list ca)))

※高階手続きを利用するのがよいのだと思う。
;; Gauche で、srfi-1 の filter を利用。
(use srfi-1)
(define (same-parity ca . cd)
  (filter (lambda (x) (= (remainder ca 2) (remainder x 2)))
          (cons ca cd)))

;; 修正
(define (same-parity ca . cd)
  (let ((p (if (odd? ca) odd? even?)))
    (define (iter ls a)
      (cond ((null? ls) (reverse a))
            ((p (car ls)) (iter (cdr ls) (cons (car ls) a)))
            (else (iter (cdr ls) a))))
    (iter (cons ca cd) nil)))

(define (same-parity ca . cd)
  (filter (if (odd? ca) odd? even?) (cons ca cd)))

Exercise 2.21

square-list の2つの定義。

(define (square-list items)
  (if (null? items)
      '()
      (cons (square (car items))
            (square-list (cdr items)))))

(define (square-list items)
  (map square items))

(square-list (list 1 2 3 4))
=>(1 4 9 16)

Exercise 2.22

1 次の定義が逆順のリストを作るのはなぜか。
(define (square-list items)
  (define (iter things answer)
    (if (null? things)
        answer
        (iter (cdr things)
              (cons (square (car things))
                    answer))))
  (iter items '()))

(square-list (list 1 2 3 4))            ;=>(16 9 4 1)

返されるべきリストは、
(cons (square 1) (cons (square 2) (cons (square 3) (cons (square 4) '()))))
のように作られなければならないが、次のように引数のリストの先頭の要素から順に
手続きを作用させた結果を cons して行ったため。
answer                                  ;=> ()
(cons (square 1) answer)                ;=> (1):=answer
(cons (square 2) answer)                ;=> (4 1):=answer
(cons (square 3) answer)                ;=> (9 4 1):=answer
(cons (square 4) answer)                ;=> (16 9 4 1):=answer

2 次の定義も動かない。なぜか。
(define (square-list items)
  (define (iter things answer)
    (if (null? things)
        answer
        (iter (cdr things)
              (cons answer
                    (square (car things))))))
  (iter items '()))

(square-list (list 1 2 3 4))            ;=>((((() . 1) . 4) . 9) . 16)

次のようにリストが作られるため、cons の引数を交換しても期待した結果にはならない。
answer                                  ;=> ()
(cons answer (square 1))                ;=> (() . 1):=answer
(cons answer (square 2))                ;=> ((() . 1) . 4):=answer
(cons answer (square 3))                ;=> (((() . 1) . 4) . 9):=answer
(cons answer (square 4))                ;=> ((((() . 1) . 4) . 9) . 16):=answer

※ append や reverse を利用すれば期待する結果となる定義が書ける。

Exercise 2.23

for-each を実装せよ。

(define (for-each proc items)
  (cond ((null? items))
        (else (proc (car items))
              (for-each proc (cdr items)))))

gosh> (for-each (lambda (x) (newline) (display x))
                (list 57 321 88))

57
321
88#t

木の写像

Exercise 2.24

(list 1 (list 2 (list 3 4))) を評価したときの
1. 解釈系の印字結果
2. 箱とポインタ記法
3. 木としての解釈を書け。

1. 印字結果
(1 (2 (3 4)))

2. 箱とポインタ記法
;; (1 (2 (3 4))) のドット対記法 (1 . ((2 . ((3 . (4 . ())) . ())) . ())) から考えた。

[*|*]-[*|/]              
 |     |                 
 1    [*|*]-[*|/]       
       |     |          
       2    [*|*]-[*|/]
             |     |   
             3     4   

3. 木としての解釈
(1 (2 (3 4)))       
     .              
    / \             
   1   .   (2 (3 4))
      / \           
     2   .  (3 4)   
        / \         
       3   4        

Exercise 2.25

次のリストから 7 を取り出す car と cdr の組み合せを書け。
1. (1 3 (5 7) 9)
2. ((7))
3. (1 (2 (3 (4 (5 (6 7))))))

1. (define list1 '(1 3 (5 7) 9))
;; '(1 . (3 . ((5 . (7 . ())) . (9 . ()))))
(car (cdr (car (cdr (cdr list1)))))
=>7

2. (define list2 '((7)))
;; '((7 . ()) . ())
(car (car list2))
=>7

3. (define list3 '(1 (2 (3 (4 (5 (6 7)))))))
;; '(1 . ((2 . ((3 . ((4 . ((5 . ((6 . (7 . ())) . ())) . ())) . ())) . ())) . ()))
(car (cdr (car (cdr (car (cdr (car (cdr (car (cdr (car (cdr list3))))))))))))
=>7

Exercise 2.26

解釈系が印字する結果は何か。

(define x (list 1 2 3))
(define y (list 4 5 6))

(append x y)
=>(1 2 3 4 5 6)

(cons x y)
=>((1 2 3) 4 5 6)

(list x y)
=>((1 2 3) (4 5 6))

Exercise 2.27

deep-reverse を定義せよ。

・リストの reverse は、リストの cdr を reverse したものと
  car を要素とするリストを append したもの。
・空リストを reverse したものは空リスト。

だった。deep-reverse も同様だが、car も reverse すべき木の場合があるので、

・木 x の deep-reverse は、x の car の deep-reverse を要素とするリストに、
  cdr の deep-reverse を append したもの。
・ただし葉なら、葉を要素とするリストに cdr の deep-reverse を append するため、それを返す。

(define (deep-reverse x)
  (cond ((null? x) '())
        ((not (pair? x)) x)
        (else (append (deep-reverse (cdr x))
                      (list (deep-reverse (car x)))))))

(define x (list (list 1 2) (list 3 4)))
x
=>((1 2) (3 4))

(reverse x)
=>((3 4) (1 2))

(deep-reverse x)
=>((4 3) (2 1))

Exercise 2.28

fringe を定義せよ。

★間違っている版
・空リストの fringe は空リスト。
・木 x の fringe は、その car が木なら car の fringe と cdr の fringe を append したもの。
・car が葉なら、葉を要素とするリストと cdr の fringe を append したもの。
・葉ならそれを返す。

(define (fringe x)
  (cond ((null? x) '())
        ((not (pair? x)) x)
        ((pair? (car x))
         (append (fringe (car x))
                 (fringe (cdr x))))
        (else
         (append (list (car x))
                 (fringe (cdr x))))))

(define x (list (list 1 2) (list 3 4)))
x
=>((1 2) (3 4))

(fringe x)
=>(1 2 3 4)
(fringe (list x x))
=>(1 2 3 4 1 2 3 4)
(fringe '(1 2 ()))
=>(1 2 ())

★修正版
・空リストの fringe は空リスト。
・木 x の fringe は、その car の fringe と cdr の fringe を append したもの。
・car をとりながら葉に至るので、葉なら cdr の fringe に append するため、
  葉を要素とするリストを返す。

(define (fringe x)
  (cond ((null? x) '())
        ((not (pair? x)) (list x))
        (else
         (append (fringe (car x))
                 (fringe (cdr x))))))

(fringe x)
=>(1 2 3 4)
(fringe (list x x))
=>(1 2 3 4 1 2 3 4)
(fringe '(1 2 ()))
=>(1 2)

Exercise 2.29

モビールはふたつの枝でできていて、それぞれ枝には錘か別のモビールがぶら下がっている。

;; モビールの構成子
(define (make-mobile left right)
  (list left right))

;; 枝の構成子
(define (make-branch length structure)
  (list length structure))

a. 枝を返す選択子 left-branch, right-branch と、枝の部品を返す
   branch-length, branch-structure を書け。

;; 左の枝を返す
(define (left-branch mobile)
  (car mobile))

;; 右の枝を返す
(define (right-branch mobile)
  (car (cdr mobile)))

;; 枝の length を返す
(define (branch-length branch)
  (car branch))

;; 枝の structure を返す
(define (branch-structure branch)
  (car (cdr branch)))

b. 選択子を使い、モビールの全重量を返す手続き total-weight を定義せよ。

・モビールの重量は左右の枝の重量の和である。
・左と右に分けて後で加算する。
・枝は length と structure の合成データだから、structure をとりだし重量を求める。
・ただし、structure は錘である数か、別のモビールであるから、
  モビールなら total-weight を再帰的に呼んで計算する。

(define (total-weight mobile)
  (define (total branch)
    (let ((structure (branch-structure branch)))
      (if (pair? structure)
          (total-weight branch)
          structure)))
  (+ (total (left-branch mobile))
     (total (right-branch mobile))))

;;---- テスト ----------------------------------------------------------
(define m0 (make-mobile (make-branch 1 2)
                        (make-branch 3 4)))
m0                                      ;=>((1 2) (3 4))
(total-weight m0)                       ;=>6

(define m1 (make-mobile (make-branch 5 6)
                        m0))
m1                                      ;=>((5 6) ((1 2) (3 4)))
(total-weight m1)                       ;=>12

(define m2 (make-mobile m0 m1))
m2                                      ;=>(((1 2) (3 4)) ((5 6) ((1 2) (3 4))))
(total-weight m2)                       ;=>18

(define m3 (make-mobile (make-mobile (make-branch 1 2) (make-branch 3 4))
                        (make-mobile (make-branch 5 6) m2)))
m3      ;=>(((1 2) (3 4)) ((5 6) (((1 2) (3 4)) ((5 6) ((1 2) (3 4))))))
(total-weight m3)                       ;=>30
;;----------------------------------------------------------------------

c. モビールが釣り合っているかどうかをテストする述語を設計せよ。

(間違い: テストで、モビール(m4)の部分モビール(m3)が釣り合っていなくても、
         全体としてのモビール(m4)が釣り合うという結果になっている。)

引数としてモビールを1個とり、モビールが釣り合っていれば真を返し、
そうでなければ偽を返す述語 balanced-mobile? を定義する。
balanced-mobile? は、枝の回転力を計算する手続き rotation-power を使い、
左右の回転力を比較する。

(define (balanced-mobile? mobile)
  (= (rotation-power (left-branch mobile))
     (rotation-power (right-branch mobile))))

回転力を計算する rotation-power は、枝の length と structure を
掛け合わせたものだから、構成子 branch-structure と branch-length で
枝の部品を取得し計算すればよい。ただし、structure が別のモビールの場合、
そのモビールの左右の各枝を再帰的にたどって計算する必要がある。

(define (rotation-power branch)
  (let ((structure (branch-structure branch)))
    (if (pair? structure)
        (+ (rotation-power (left-branch branch))
           (rotation-power (right-branch branch)))
        (* structure (branch-length branch)))))

;;---- テスト ----------------------------------------------------------
m1                                      ;=>((5 6) ((1 2) (3 4)))
(rotation-power m1)                     ;=>44
(balanced-mobile? m1)                   ;=>#f
(rotation-power m3)                     ;=>102
(balanced-mobile? m3)                   ;=>#f
(define m4 (make-mobile (make-mobile (make-branch 8 11) ;88
                                     (make-branch 2 7)) ;14
                        m3))
m4 ;=>(((8 11) (2 7)) (((1 2) (3 4)) ((5 6) (((1 2) (3 4)) ((5 6) ((1 2) (3 4)))))))
(rotation-power m4)                     ;=>204
(balanced-mobile? m4)                   ;=>#t
;;----------------------------------------------------------------------

d. モビールの表現を変更し、構成子を次のようにした。
新しい表現に対応するには、どのくらいプログラムを変更しなければならないか。

(define (make-mobile left right)
  (cons left right))

(define (make-branch length structure)
  (cons length structure))

total-weight, balanced-mobile?, rotation-power は抽象の壁で隔離されているので、
合成データの選択子 right-branch と branch-structure を次のように変更するだけでよい。

(define (right-branch mobile)
  (cdr mobile))

(define (branch-structure mobile)
  (cdr mobile))

Exercise 2.30

square-tree を高階手続きを使わず定義せよ。また map と再帰を使って定義せよ。

(define (square-tree tree)
  (cond ((null? tree) '())
        ((not (pair? tree)) (square tree))
        (else (cons (square-tree (car tree))
                    (square-tree (cdr tree))))))

;; map と再帰を使う
(define (square-tree tree)
  (map (lambda (sub-tree)
         (if (not (pair? sub-tree))
             (square sub-tree)
             (square-tree sub-tree)))
       tree))

(square-tree
 (list 1
       (list 2 (list 3 4) 5)
       (list 6 7)))
=>(1 (4 (9 16) 25) (36 49))

Exercise 2.31

問題 2.30 を抽象化し、tree-map を作れ。

;; 高階手続きを使わない
(define (tree-map proc tree)
  (cond ((null? tree) '())
        ((not (pair? tree)) (proc tree))
        (else (cons (tree-map proc (car tree))
                    (tree-map proc (cdr tree))))))

;; map と再帰を使う
(define (tree-map proc tree)
  (map (lambda (sub-tree)
         (if (not (pair? sub-tree))
             (proc sub-tree)
             (tree-map proc sub-tree)))
       tree))

(define (square-tree tree) (tree-map square tree))

(square-tree
 (list 1
       (list 2 (list 3 4) 5)
       (list 6 7)))
=>(1 (4 (9 16) 25) (36 49))

Exercise 2.32

1. 集合の部分集合の集合を作る手続き subsets を完成させ、
2. なぜこれが上手く行くのか明快に説明せよ。

1
(define (subsets s)
  (if (null? s)
      (list '())
      (let ((rest (subsets (cdr s))))
        (append rest
                (map (lambda (x) (cons (car s) x))
                     rest)))))

(subsets '(1 2 3))
=>(() (3) (2) (2 3) (1) (1 3) (1 2) (1 2 3))

2

公認インターフェイス フィルタ アキュムレート

Exercise 2.33

リスト基本演算 map, append, length のアキュムレーションとしての定義

(define (map p sequence)
  (accumulate (lambda (x y) (cons (p x) y)) '() sequence))

(define (append seq1 seq2)
  (accumulate cons seq2 seq1))

(define (length sequence)
  (accumulate (lambda (x y) (+ 1 y)) 0 sequence))

Exercise 2.34

Horner の方法

(define (horner-eval x coefficient-sequence)
  (accumulate (lambda (this-coeff higher-terms)
                (+ this-coeff (* higher-terms x)))
              0
              coefficient-sequence))

(horner-eval 2 (list 1 3 0 5 0 1))      ;=>79

Exercise 2.35

count-leaves をアキュムレーションとして定義せよ。

(define (count-leaves t)
  (accumulate (lambda (x y) (+ x y))    ;accumulate == fold-right
              0
              (map (lambda (s)
                     (if (not (pair? s))
                         1
                         (count-leaves s)))
                   t)))

(count-leaves '())                                  ;=>0
(count-leaves '(1 2 (3 4 5 6 (7 8))))               ;=>8
(count-leaves '(1 (2 (3 (4 (5 6 7 (8 9))) 10 11)))) ;=>11

;; 別解1 fold-left(Exercise2.38)を使った定義
(define (count-leaves t)
  (fold-left (lambda (x y)
               (if (pair? y)
                   (+ (count-leaves y) x)
                   (+ 1 x)))
             0
             t))

;; 別解2 fold(srfi-1)を使った定義
(define (count-leaves t)
  (fold (lambda (x y)
          (if (pair? x)
              (+ (count-leaves x) y)
              (+ 1 y)))
        0
        t))

Exercise 2.36

accumulate-n の定義

(define (accumulate-n op init seqs)
  (if (null? (car seqs))
      '()
      (cons (accumulate op init (map car seqs))
            (accumulate-n op init (map cdr seqs)))))

(accumulate-n + 0 '((1 2 3) (4 5 6) (7 8 9) (10 11 12))) ;=>(22 26 30)

Exercise 2.37

;; http://ja.wikipedia.org/wiki/%E8%A1%8C%E5%88%97
;; http://www.geisya.or.jp/~mwm48961/kou2/matrix2.html
;; http://www.ikushu.jp/~jyugyo/puki/index.php?%B9%D4%CE%F3%C2%E5%BF%F4%A4%CE%B4%F0%C1%C3

;; マトリクス * ベクタ
(define (matrix-*-vector m v)
  (map (lambda (x) (dot-product x v)) m))

(matrix-*-vector '((2 -1) (-3 4)) '(1 2)) ;=>(0 5)
(matrix-*-vector '((4 -1) (-5 3)) '(1 2)) ;=>(2 1)

;; 転置
(define (transpose mat)
  (accumulate-n cons '() mat))

(transpose '((1 2 3) (4 5 6) (7 8 9)))  ;=>((1 4 7) (2 5 8) (3 6 9))
(transpose '((1 4 7) (2 5 8) (3 6 9)))  ;=>((1 2 3) (4 5 6) (7 8 9))

※ (apply map list '((1 2 3) (4 5 6) (7 8 9))) ;=>((1 4 7) (2 5 8) (3 6 9))

;; マトリクス * マトリクス
(define (matrix-*-matrix m n)
  (let ((cols (transpose n)))
    (map (lambda (x)
           (map (lambda (y)
                  (dot-product x y))
                cols))
         m)))

(matrix-*-matrix '((5 6) (7 8)) '((1 2) (3 4)))   ;=>((23 34) (31 46))
(matrix-*-matrix '((1 2) (3 4)) '((5 6) (7 8)))   ;=>((19 22) (43 50))

Exercise 2.38

(define (fold-left op initial sequence)
  (define (iter result rest)
    (if (null? rest)
        result
        (iter (op result (car rest))
              (cdr rest))))
  (iter initial sequence))

;; fold-right == accumulate
(define (fold-right op initial sequence)
  (if (null? sequence)
      initial
      (op (car sequence)
          (fold-right op initial (cdr sequence)))))

1. 次の値は何か。

(fold-right / 1 (list 1 2 3))                     ;=>3/2
(fold-left / 1 (list 1 2 3))                      ;=>1/6

(fold-right list nil (list 1 2 3))                ;=>(1 (2 (3 ())))
(fold-left list nil (list 1 2 3))                 ;=>(((() 1) 2) 3)

2. 同じ値を生じるための op の満たすべき性質は何か。

min, max, +, * などのように引数の順序が変っても結果が同一であること。

;; fold-left
(fold-left / 1 (list 2 3 4 5))                     ;=>1/120
(/ (/ (/ (/ 1 2) 3) 4) 5)                          ;=>1/120

;; fold-right
(accumulate / 1 (list 2 3 4 5))                    ;=>8/15
(fold-right / 1 (list 2 3 4 5))                    ;=>8/15
(/ 2 (/ 3 (/ 4 (/ 5 1))))                          ;=>8/15

;; fold-left
(fold-left / 1 (list 1 2 3 4))                     ;=>1/24
(/ (/ (/ (/ 1 1) 2) 3) 4)                          ;=>1/24

;; fold-right
(fold-right / 1 (list 1 2 3 4))                    ;=>3/8
(/ 1 (/ 2 (/ 3 (/ 4 1))))                          ;=>3/8

;; fold-left
(fold-left + 0 (list 1 2 3 4))                     ;=>10
(+ (+ (+ (+ 0 1) 2) 3) 4)                          ;=>10

;; fold-right
(fold-right + 0 (list 1 2 3 4))                    ;=>10
(+ 1 (+ 2 (+ 3 (+ 4 0))))                          ;=>10

;; fold-left
(fold-left max 0 (list 1 2 3 4))                   ;=>4
(max (max (max (max 0 1) 2) 3) 4)                  ;=>4

;; fold-right
(fold-right max 0 (list 1 2 3 4))                  ;=>4
(max 1 (max 2 (max 3 (max 4 1))))                  ;=>4

Exercise 2.39

reverse の fold-right と fold-left を使った定義

(define (reverse sequence)
  (fold-right (lambda (x y) (append y (list x))) nil sequence))

(define (reverse sequence)
  (fold-left (lambda (x y) (cons y x)) nil sequence))

;; fold(srfi-1)
(define (reverse sequence)
  (fold (lambda (x y) (cons x y)) nil sequence))

(reverse (list 1 2 3))                            ;=>(3 2 1)

Nested Mappings

●テキストの permutations の別な定義を考えてみた。

1. テキストの定義
(define (permutations s)
  (if (null? s)
      (list nil)
      (flatmap (lambda (x)
                 (map (lambda (p) (cons x p))
                      (permutations (remove x s))))
               s)))

(define (remove item sequence)
  (filter (lambda (x) (not (= x item)))
          sequence))

2. flatmap の入れ子にした
(define (permutations s)
  (if (null? s)
      (list nil)
      (flatmap (lambda (x)
                 (flatmap (lambda (p) (list (cons x p)))
                          (permutations (remove x s))))
               s)))

3.
(define (permutations s)
  (if (null? s)
      (list nil)
      (apply append
             (map (lambda (x)
                    (apply append
                           (map (lambda (p) (list (cons x p)))
                                (permutations (remove x s)))))
                  s))))

4.
(use srfi-42)
(define (permutations s)
  (if (null? s)
      (list nil)
      (append-ec (: x s)
                 (list-ec (: p (permutations (remove x s)))
                          (cons x p)))))

(permutations (list 1 2 3))
=>((1 2 3) (1 3 2) (2 1 3) (2 3 1) (3 1 2) (3 2 1))

●テキストの prime-sum-pairs の別な定義

;; テキストの定義
(define (prime-sum-pairs n)
  (map make-pair-sum
       (filter prime-sum?
               (flatmap
                (lambda (i)
                  (map (lambda (j) (list i j))
                       (enumerate-interval 1 (- i 1))))
                (enumerate-interval 1 n)))))

;; flatmap の入れ子にした
(define (prime-sum-pairs n)
  (map make-pair-sum
       (filter prime-sum?
               (flatmap
                (lambda (i)
                  (flatmap (lambda (j) (list (list i j)))
                           (enumerate-interval 1 (- i 1))))
                (enumerate-interval 1 n)))))

Exercise 2.40

1. unique-pairs を定義せよ。
2. unique-pairs を使って prime-sum-pairs の定義を簡単にせよ。

1
(define (unique-pairs n)
  (flatmap (lambda (i)
             (map (lambda (j) (list i j))
                  (enumerate-interval 1 (- i 1))))
           (enumerate-interval 1 n)))

;; 以下別解
(define (unique-pairs n)
  (flatmap (lambda (i)
             (flatmap (lambda (j) (list (list i j)))
                      (enumerate-interval 1 (- i 1))))
           (enumerate-interval 1 n)))

(define (unique-pairs n)
  (apply append
         (map (lambda (i)
                (apply append
                       (map (lambda (j) (list (list i j)))
                            (enumerate-interval 1 (- i 1)))))
              (enumerate-interval 1 n))))

(use srfi-42)
(define (unique-pairs n)
  (list-ec (: i 1 (+ n 1))
           (: j 1 i)
           (list i j)))

(unique-pairs 5)
=>((2 1) (3 1) (3 2) (4 1) (4 2) (4 3) (5 1) (5 2) (5 3) (5 4))

2
(define (prime-sum-pairs n)
  (map make-pair-sum
       (filter prime-sum? (unique-pairs n))))

(prime-sum-pairs 6)
=>((2 1 3) (3 2 5) (4 1 5) (4 3 7) (5 2 7) (6 1 7) (6 5 11))

Exercise 2.41

正の整数 n に対し、1 <= k < j < i <= n である異なる正の整数 i と j と
k のリストで、i + j + k が与えられた整数 s と等しくなるものをすべて見つ
ける手続きを書け。(と問題文を理解して解答した。)

;; もっと良い解があるのではないか。
(define (find-all s n)
  (filter (lambda (x) (= (accumulate + 0 x) s))
          (accumulate append nil
           (accumulate append nil
            (map (lambda (i)
                   (map (lambda (j)
                          (map (lambda (k) (list i j k))
                               (enumerate-interval 1 (- j 1))))
                        (enumerate-interval 1 (- i 1))))
                 (enumerate-interval 1 n))))))

;; flatmap 1
(define (find-all s n)
  (flatmap
   (lambda (x) (filter pair? x))
   (flatmap (lambda (i)
              (map (lambda (j)
                     (map (lambda (k) (and (= (+ i j k) s) (list i j k)))
                          (enumerate-interval 1 (- j 1))))
                   (enumerate-interval 1 (- i 1))))
            (enumerate-interval 1 n))))

;; flatmap 2
(define (find-all s n)
  (flatmap (lambda (i)
             (flatmap (lambda (j)
                        (flatmap (lambda (k)
                                   (if (= (+ i j k) s)
                                       (list (list i j k))
                                       '()))
                                 (enumerate-interval 1 (- j 1))))
                      (enumerate-interval 1 (- i 1))))
           (enumerate-interval 1 n)))

;; apply
(define (find-all s n)
  (apply append
         (map (lambda (i)
                (apply append
                       (map (lambda (j)
                              (apply append
                                     (map (lambda (k)
                                            (if (= (+ i j k) s)
                                                (list (list i j k))
                                                '()))
                                          (enumerate-interval 1 (- j 1)))))
                            (enumerate-interval 1 (- i 1)))))
              (enumerate-interval 1 n))))


(find-all 5 10)           ;=>()
(find-all 6 10)           ;=>((3 2 1))
(find-all 7 10)           ;=>((4 2 1))
(find-all 8 10)           ;=>((4 3 1) (5 2 1))
(find-all 9 10)           ;=>((4 3 2) (5 3 1) (6 2 1))
(find-all 10 10)          ;=>((5 3 2) (5 4 1) (6 3 1) (7 2 1))

;; srfi-42 を使ってみた
(use srfi-42)
(define (find-all s n)
  (list-ec (: i 1 (+ n 1))
           (: j 1 i)
           (: k 1 j)
           (if (= (+ i j k) s))
           (list i j k)))

(find-all 5 10)           ;=>()
(find-all 6 10)           ;=>((3 2 1))
(find-all 7 10)           ;=>((4 2 1))
(find-all 8 10)           ;=>((4 3 1) (5 2 1))
(find-all 9 10)           ;=>((4 3 2) (5 3 1) (6 2 1))
(find-all 10 10)          ;=>((5 3 2) (5 4 1) (6 3 1) (7 2 1))

Exercise 2.42

エイトクィーンパズル
empty-board と adjoin-position と safe? を書いてプログラムを完成せよ。

(define empty-board nil)

(define (safe? k positions)
  (define (conflict? level up down positions)
    (if (null? positions)
        #t
        (let ((row (caar positions)))
          ;; 同じ行・斜め上の筋・斜め下の筋にあるなら衝突
          (if (or (= level row) (= up row) (= down row))
              #f
              (conflict? level (- up 1) (+ down 1) (cdr positions))))))
  (if (= k 1) ;(null? positions) としてkを利用しなくてもできてしまう…
      #t
      (let ((row (caar positions)))
        ;; 列を遡って調べる
        (conflict? row (- row 1) (+ row 1) (cdr positions)))))

(define (adjoin-position new-row k rest-of-queens)
  (cons (list new-row k) rest-of-queens))

(define (queens board-size)
  (define (queen-cols k)
    (if (= k 0)
        (list empty-board)
        (filter
         (lambda (positions) (safe? k positions))
         (flatmap
          (lambda (rest-of-queens)
            (map (lambda (new-row)
                   (adjoin-position new-row k rest-of-queens))
                 (enumerate-interval 1 board-size)))
          (queen-cols (- k 1))))))
  (queen-cols board-size))

(queens 4)
=>(((3 4) (1 3) (4 2) (2 1))
   ((2 4) (4 3) (1 2) (3 1)))

(queens 5)
;;(map (lambda (x) (map (lambda (y) (car y)) x)) (queens 5))
=>((4 2 5 3 1) (3 5 2 4 1) (5 3 1 4 2) (4 1 3 5 2) (5 2 4 1 3)
   (1 4 2 5 3) (2 5 3 1 4) (1 3 5 2 4) (3 1 4 2 5) (2 4 1 3 5))

(queens 6)
;;(map (lambda (x) (map (lambda (y) (car y)) x)) (queens 6))
=>((5 3 1 6 4 2) (4 1 5 2 6 3) (3 6 2 5 1 4) (2 4 6 1 3 5))

(length (queens 7))
=>40

(length (queens 8))
=>92