FujimotoHisa
- hisa (ふじもとひさ)
- 第68回 (2007.7.18)
- 第??回 (2007.6.27)
- 第45回 (2007.01.17)
- 第44回 (2007.01.10)
- 第43回 (2006.12.20)
- 第39回 (2006.11.22)
- 第38回 (2006.11.15)
- 第37回 (11/08)
- 第36回 (11/01)
- 第34回 (10/18)
- 第33回 (10/11)
- 第32回 (10/04)
- 第31回 (9/27)
- 第30回 (9/20)
- 第28回 (9/6)
- 第27回 (8/30)
- 第26回
- 第25回 (欠席)
- 第24回
- 第23回
- 第18回、19回は欠席
- 問題 2.3? 長方形の表現
- 2.1.3 データとは何か？
- 問題 2.4? 対の(別の)手続き表現
- 問題 2.5? (cons a b) を素因数分解で表現
- 問題 2.6 自然数を手続きで表現 (Church数)
- 2.1.4 拡張問題; 区間算術演算
- 問題 2.7 区間の構成子と選択子を定義せよ
- 問題 2.8 区間の差の計算
- 第17回 (2006.6.14)
- 第1-16回 (一章)
hisa (ふじもとひさ)
ひ日誌というWeb日記に、ときどき SICP や Scheme や Lisp などについて素人くさい！ことを書いたりしてます。
去年(2005年)は、Scheme で本格的なプログラムを書きたいなぁと思いつつ、結局 Ruby を使ってしまうというパターンを歩みました。SICP については、4章の前半あたりまで飛ばし読みした状態で止まっています。いつだったかちゃんと覚えてないのですが、私のemacsとlisp師匠でもある友達の家の本棚に飾ってあったのを発見しました。それがSICPとの出会いです。SICPを読む上で、とくに数学(例えば、ニュートン近似法ってなんだっけとか)がボトルネックとなっています。
SICP を離れると、RubyCocoa という Mac OS X 用のオープンソースソフトウェアの原作者でもあります。
処理系非依存な(つもりの)テスト用ライブラリを作りました: http://www.fobj.com/hisa/d/20061207.html#p02
第68回 (2007.7.18)
問題 3.28
(define (or-gate a1 a2 output)
(define (or-action-procedure)
(let ((new-value
(logical-or (get-signal a1) (get-signal a2))))
(after-delay or-gate-delay
(lambda ()
(set-signal! output new-value)))))
(add-action! a1 (or-action-procedure))
(add-action! a2 (or-action-procedure))
'ok)
問題 3.29
http://ja.wikipedia.org/wiki/ド・モルガンの法則
(AND a b) = (NOT (OR (NOT a) (NOT b)))
(define (or-gate-2 a1 a2 output)
(let ((b1 make-wire)
(b2 make-wire)
(c make-wire))
(inverter a1 b1)
(inverter a2 b2)
(and-gate b1 b2 c)
(inverter c output)
'ok))
問題 3.30
as bs ss はそれぞれ、同じ長さのwireのリストであることを前提にしています。 リストの長さの回数分だけ、全加算器とc-outと次のc-inを接続するワイヤを生 成して、接続していきます。
(define (ripple-carry-adder as bs ss c-in)
(define (loop as bs c-in ss c-out)
(if (null? ak)
'ok
(let ((a (car as)) (b (car bs)) (s (car ss)))
(full-adder a b c-in s c-out)
(loop (cdr as) (cdr bs) c-out
(cdr ss) (make-wire)))))
(loop as bs c-in
ss (make-wire)))
第??回 (2007.6.27)
問題3.23 Gaucheが落ちるdequeueプログラムを貼っておきます(バグあり)。 (Gauche:Bugs)
;;; SICP 問題 3.23 ;; dequeue -- 各アイテムの双方向にリンクされたリストで表現
(define (front-ptr q) (car q)) (define (rear-ptr q) (cdr q)) (define (set-front-ptr! q i) (set-car! q i)) (define (set-rear-ptr! q i) (set-cdr! q i))
(define (make-item v) (cons v (cons '() '()))) (define (item-value i) (car i)) (define (item-next-ptr i) (cadr i)) (define (item-prev-ptr i) (cddr i)) (define (set-item-next-ptr! i p) (set-car! (cdr i) p)) (define (set-item-prev-ptr! i p) (set-cdr! (cdr i) p))
(define (empty-queue? q) (null? (front-ptr q)))
(define (make-queue) (cons '() '()))
(define (front-queue q)
(if (empty-queue? q)
(error "FRONT called with an empty queue" q)
(item-value (front-ptr q))))
(define (rear-queue q)
(if (empty-queue? q)
(error "REAR called with an empty queue" q)
(item-value (rear-ptr q))))
(define (rear-insert-queue! q i)
(let ((new-item (make-item i)))
(cond ((empty-queue? q)
(set-front-ptr! q new-item)
(set-rear-ptr! q new-item)
q)
(else
(set-item-prev-ptr! new-item (rear-ptr q))
(set-item-next-ptr! (rear-ptr q) new-item)
(set-rear-ptr! q new-item)
q))))
(define (front-insert-queue! q i)
(let ((new-item (make-item i)))
(cond ((empty-queue? q)
(set-front-ptr! q new-item)
(set-rear-ptr! q new-item)
q)
(else
(set-item-next-ptr! new-item (front-ptr q))
(set-item-prev-ptr! (front-ptr q) new-item)
(set-front-ptr! q new-item)
q))))
(define (front-delete-queue! q)
(cond ((empty-queue? q)
(error "DELETE! called with an empty queue" q))
(else
(set-front-ptr! q (item-next-ptr (front-ptr q)))
q)))
(define (rear-delete-queue! q)
(cond ((empty-queue? q)
(error "DELETE! called with an empty queue" q))
(else
(set-rear-ptr! q (item-prev-ptr (rear-ptr q)))
q)))
(define (seg-fault)
(let ((q (make-queue)))
(front-insert-queue! q 'a)
(front-insert-queue! q 'b)
(front-delete-queue! q)
(front-delete-queue! q)
(front-delete-queue! q)))
(seg-fault)
第45回 (2007.01.17)
問題 2-74? アキナイ有限会社
問題 2-75? メッセージパッシング版の make-from-mag-ang
(define (make-from-mag-ang r a)
(define (dispatch op)
(cond ((eq? op 'real-part) (* r (cos a)))
((eq? op 'imag-part) (* r (sin a)))
((eq? op 'magnitude) r)
((eq? op 'angle) a)
(else (error "Unknown op -- MAKE-FROM-MAG-ANG" op))))
dispatch)
問題 2-76?
| 新しい型を追加 | 新しい演算を追加 | |
| 明白な型を持つ汎用演算 | × 全ての演算を変更 | ○ 新規演算以外の変更は不要 |
| データ主導流 | 型に対応した演算を新しく定義 | (あとで書く) |
| メッセージパッシング | 新規型以外の変更は不要 | 型の数だけ演算を定義 |
第44回 (2007.01.10)
問題 2-73? をやった(答えは第43回の方に書いた)。
第43回 (2006.12.20)
2.4節をやるときに必要な処理系非依存な最低限のgetとputを置いておきました(GetAndPut)。
問題 2-73? 記号微分プログラムをデータ主導に変更する
2.7.3節で作った記号微分のための部品類:
(define (variable? e) (symbol? e))
(define (same-variable? e1 e2)
(and (variable? e1) (variable? e2) (eq? e1 e2)))
(define (make-sum e1 e2) (list '+ e1 e2))
(define (make-product e1 e2) (list '* e1 e2))
(define (sum? e) (and (pair? e) (eq? (car e) '+)))
(define (addend e) (cadr e))
(define (augend e) (caddr e))
(define (product? e) (and (pair? e) (eq? (car e) '*)))
(define (multiplier e) (cadr e))
(define (multiplicand e) (caddr e))
(define (make-sum e1 e2)
(cond ((=number? e1 0) e2)
((=number? e2 0) e1)
((and (number? e1) (number? e2)) (+ e1 e2))
(else (list '+ e1 e2))))
(define (make-product e1 e2)
(cond ((=number? e1 0) 0)
((=number? e2 0) 0)
((=number? e1 1) e2)
((=number? e2 1) e1)
((and (number? e1) (number? e2)) (* e1 e2))
(else (list '* e1 e2))))
(define (base e) (cadr e))
(define (exponent e) (caddr e))
(define (make-exponential b e)
(cond ((=number? e 0) 1)
((=number? e 1) b)
(else (list '** b e))))
(define (=number? e1 e2)
(and (number? e1) (number? e2) (= e1 e2)))
データ主導型のderiv:
(define (deriv exp var)
(cond ((number? exp) 0)
((variable? exp) (if (same-variable? exp var) 1 0))
(else ((get 'deriv (operator exp)) (operands exp) var))))
(define (operator exp) (car exp))
(define (operands exp) (cdr exp))
a-1. やったことを説明せよ。
演算対型の表を検索して、演算を実装した手続きが見つかればそれを適用する。ここで:
| 型 | 算術演算子を表わす記号 |
| 演算 | 微分公式に基づいて式を簡約する手続き |
a-2. number?やvariable?がデータ主導の振り分けに吸収できない理由は？
無限に存在する数値や記号をすべて表に登録することはできないから。
b. 和と積の微分手続き書き、上のプログラムの表に設定するのに必要な補助
プログラムを書け！
(define (install-deriv-package)
(define (put-proc op proc)
(put 'deriv op
(lambda (exp var)
(proc (cons op exp) var))))
(define (deriv-sum exp var)
(make-sum (deriv (addend exp) var)
(deriv (augend exp) var)))
(define (deriv-product exp var)
(make-sum
(make-product (multiplier exp)
(deriv (multiplicand exp) var))
(make-product (deriv (multiplier exp) var)
(multiplicand exp))))
(define (deriv-exponential exp var)
(make-product
(make-product (exponent exp)
(make-exponential (base exp)
(make-sum (exponent exp)
-1)))
(deriv (base exp) var)))
(put-proc '+ deriv-sum)
(put-proc '* deriv-product)
(put-proc '** deriv-exponential)
'done)
c. ベキ乗のような、その他の微分規則を選び、データ主導システム上に設定せよ。
b. の答えに組み込んだ。
(define-test test-2.73 ((deriv '(+ x 3) 'x) => 1) ((deriv '(* x y) 'x) => 'y) ((deriv '(+ (+ (* a (** x 2)) (* b x)) c) 'x) => '(+ (* a (* 2 x)) b)) ((deriv '(+ (+ (* 7 (** x 2)) (* 5 x)) 3) 'x) => '(+ (* 7 (* 2 x)) 5)) ((deriv '(+ (* a (** x 2)) (* b x) c) 'x) => '(+ (* a (* 2 x)) b)) ((deriv '(+ (* 7 (** x 2)) (* 5 x) 3) 'x) => '(+ 5 (* 7 (* 2 x)))))
d.
[問題文] この代数式操作で、式の型はそれを結合している代数演算である。手続きの目印を反対にした(二次元表の軸を入れ替える)場合、微分システムにはどのような変更が必要か？
特に変更は必要ない。
第39回 (2006.11.22)
問題 2-63? 二進木をリストに変換する手続き tree->list
(a) どちらの手続きも、二進木の各項を左・中・右順に並べたリストを返す。
(b) 繰り返しの回数(tree->list-1もしくはcopy-to-listの実行回数)に着目するとどちらも(* 2 (log n))2n回となる。ただし、tree->list-1では、繰り返しごとにappendが呼ばれる。P.58で定義されているappendのステップ数の増加の程度はθ(n)。したがって、appendの影響がない分だけ、tree->list-2 の方がより遅くステップ数が増加する。
| | 手続き | | ステップ数の増加の程度 |
| tree->list-1 | θ(n * n) |
| tree->list-2 | θ(n) |
などと書いてみたけど正解かどうかよくわからない。tree->list-1で、appendの引数として渡されるリストの長さは log n の速さで減少していくはずだけど、それをどう考えるべきかとか…
第38回 (2006.11.15)
2.3.3 例: 集合の表現。まずは順序づけられないリストとしての集合。
問題 2-59? union-set (順序づけられないリスト版)
(define (union-set set1 set2)
(cond ((null? set1) set2)
((null? set2) set1)
(else (adjoin-set (car set1)
(union-set (cdr set1) set2)))))
詳細はこちらに書きました。
問題 2-60? 重複OK! 効率はどうなる？
重複可能なので、リストのサイズが無駄に大きくなるという前提の上で…
| adjoin-setは単純にconsするだけ | θ(1) |
| element-of-set?は変更不要で効率も同じ | θ(n) |
| intersection-setは変更不要で効率も同じ | θ(n^2) |
| union-setは単純にappend | appendの計算量 θ(n)だっけ？ |
(define (adjoin-set x set) (cons x set)) (define (union-set a b) (append a b))
第37回 (11/08)
問題 2-57? 任意の個数の項
任意の個数の項を扱う。和と積の表現だけを変更しderivには変更を加えないこと。
(実装の概要) make-sum と make-product を可変長引数対応にするため、項の リスト1つを引数にとるmake-sum-list, make-product-list を定義する。それ ぞれ、項リストを順に調べて、数値の項とそれ以外の項に分類する。数値項は 調べながら計算する。たとえば (a 1 b 2 (+ 3 4) c 5 d) という引数リストを make-sum-list に与えると、(+ 8 a b (+ 3 4) c d) という結果を返す。8は数 値項を計算した結果。
(define (make-sum-list args)
(define (build-result val syms)
(if (null? syms)
val
(if (null? (cdr syms))
(if (=number? val 0)
(car syms)
(list '+ val (car syms)))
(if (=number? val 0)
(cons '+ syms)
(cons '+ (cons val syms))))))
(define (loop val syms args)
(if (null? args)
(build-result val (reverse syms))
(let ((term (car args)) (rest (cdr args)))
(if (number? term)
(loop (+ val term) syms rest)
(loop val (cons term syms) rest)))))
(loop 0 '() args))
augendは、第二項以降のmake-sum-list。
(define (make-sum . args) (make-sum-list args)) (define (addend e) (cadr e)) ; 変更なし (define (augend e) (make-sum-list (cddr e)))
乗算のためのmake-product-listは、数値項の初期値を0から1に変更、演算子を+から*に変更する以外、make-sum-listと同じ。
(define (make-product-list args)
(define (build-result val syms)
(if (null? syms)
val
(if (null? (cdr syms))
(if (=number? val 1)
(car syms)
(list '* val (car syms)))
(if (=number? val 1)
(cons '* syms)
(cons '* (cons val syms))))))
(define (loop val syms args)
(if (null? args)
(build-result val (reverse syms))
(let ((term (car args)) (rest (cdr args)))
(cond ((=number? term 0) 0)
((number? term) (loop (* val term) syms rest))
(else (loop val (cons term syms) rest))))))
(loop 1 '() args))
(define (make-product . args) (make-product-list args)) (define (multiplier e) (cadr e)) ; 変更なし (define (multiplicand e) (make-product-list (cddr e)))
問題2-57のテスト(gauche用)
(define (test-2.57)
(use gauche.test)
(test* "test-2.57" 1
(deriv '(+ x 3) 'x))
(test* "test-2.57" 'y
(deriv '(* x y) 'x))
(test* "deriv" '(+ (* x y) (* y (+ x 3)))
(deriv '(* x y (+ x 3)) 'x))
(test* "test-2.57"
'(+ (* a (* 2 x)) b)
(deriv '(+ (* a (** x 2)) (* b x) c) 'x))
(test* "test-2.57"
'(+ 5 (* 7 (* 2 x)))
(deriv '(+ (* 7 (** x 2)) (* 5 x) 3) 'x)))
問題 2-58? 中置記法
(a) 構成子と選択子を変更して、初項と演算子の並び順を逆にするだけ
(define (make-sum e1 e2)
(cond ((=number? e1 0) e2)
((=number? e2 0) e1)
((and (number? e1) (number? e2)) (+ e1 e2))
(else (list e1 '+ e2))))
(define (make-product e1 e2)
(cond ((=number? e1 0) 0)
((=number? e2 0) 0)
((=number? e1 1) e2)
((=number? e2 1) e1)
((and (number? e1) (number? e2)) (* e1 e2))
(else (list e1 '* e2))))
(define (make-exponentiation b e)
(cond ((=number? e 0) 1)
((=number? e 1) b)
(else (list b '** e))))
(define (sum? e) (and (pair? e) (eq? (cadr e) '+))) (define (addend e) (car e)) (define (augend e) (caddr e))
(define (product? e) (and (pair? e) (eq? (cadr e) '*))) (define (multiplier e) (car e)) (define (multiplicand e) (caddr e))
(define (exponentiation? e) (and (pair? e) (eq? (cadr e) '**))) (define (base e) (car e)) (define (exponent e) (caddr e))
(define (test-2.58-a)
(use gauche.test)
(test* "deriv" 1
(deriv '(x + 3) 'x))
(test* "deriv" 'y
(deriv '(x * y) 'x))
(test* "deriv" '((x * y) + (y * (x + 3)))
(deriv '((x * y) * (x + 3)) 'x)))
(b) 括弧を省略可能にした場合、どうなる？
中置記法から前置記法への変換器を作る。選択子は、選択する前に渡された式を前置記法に変換する処理をはさめば良い。と佐野さんが言って作った。
第36回 (11/01)
問題 2.56 指数の規則をderivに追加
(define (deriv exp var)
(cond ((number? exp) 0)
((variable? exp) (if (same-variable? exp var) 1 0))
((sum? exp) (make-sum (deriv (addend exp) var)
(deriv (augend exp) var)))
((product? exp) (make-sum
(make-product (multiplier exp)
(deriv (multiplicand exp) var))
(make-product (deriv (multiplier exp) var)
(multiplicand exp))))
((exponentiation? exp)
(make-product (make-product (exponent exp)
(make-exponentiation (base exp)
(make-sum (exponent exp)
-1)))
(deriv (base exp) var)))
(else (error "unknown expression type -- DERIV" exp))))
(define (exponentiation? e) (and (pair? e) (eq? (car e) '**)))
(define (base e) (cadr e))
(define (exponent e) (caddr e))
(define (make-exponentiation b e)
(cond ((=number? e 0) 1)
((=number? e 1) b)
(else (list '** b e))))
(define (test-2.56)
(use gauche.test)
(test* "test-2.56" '(+ (* a (* 2 x)) b)
(deriv '(+ (+ (* a (** x 2)) (* b x)) c) 'x))
(test* "test-2.56" '(+ (* 7 (* 2 x)) 5)
(deriv '(+ (+ (* 7 (** x 2)) (* 5 x)) 3) 'x)))
第34回 (10/18)
図形言語を「Acceptable Scheme」JavaScript?と「Acceptable Lisp」Rubyで実装してみました。 http://www.fobj.com/hisa/pictlang/
第32回 (10/04)
2.2.4図形言語。c-wrapper経由でMac OS XのQuartzもしくはCocoaを叩いて図形言語にしようなどと考えたけど間に合わなかったので、PictureLanguageを参考にDrScheme?とPictureティーチパックを使用。
下準備
identityがないので定義
(define (identity x) x)
そのままpaintで描くと上下逆さまになるので、flip-vertしてから(オリジナルの)paintを呼ぶようにpaintとpaint-h-resを再定義(参考 PictureLanguage)
(begin (define orig-paint paint) (define orig-paint-hi-res paint-hi-res) (set! paint (lambda (painter) (orig-paint (flip-vert painter)))) (set! paint-hi-res (lambda (painter) (orig-paint-hi-res (flip-vert painter)))))
[脱線] トップレベルに書いた複数の式がどんな順に評価されるかよくわからないので(決まってるんだっけ？)、リスト内で出現順に評価される仕様のはずのbeginをで囲ってみた。意味あるのかよくかわらない。ここらへんまじめに考えるとけっこういろいろあってややこしい。
問題 2.24? up-splitを定義せよ
right-splitのbelowとbesideを入れ替える。
(define (up-split painter n)
(if (= n 0)
painter
(let ((smaller (up-split painter (- n 1))))
(below painter (beside smaller smaller)))))
問題 2.45? splitの抽象化、split関数を返す関数を定義
(define (split painter-a painter-b)
(define (recur painter n)
(if (= n 0)
painter
(let ((smaller (recur painter (- n 1))))
(painter-a painter (painter-b smaller smaller)))))
recur)
(define right-split (split beside below))
(define up-split (split below beside))
第30回 (9/20)
問題 2.42 エイトクイーンパズル
正しいかどうか疑わしい解答です。positionsを行を表わす整数のリストで表現。safe?やadjoin-positionではkを使わなかった。safe?の解釈に苦労。safe?ではpositionについて:
- 十分に短いか？ small-enough?
- 直前の列と離れているか？ far-enough?
- 行が同じものはないか？ uniq?
を調べる。テスト自体も同じ方針で書いたので、似たようなコードが重複してしまい、テストとして意味がないような気がする。
以下は本体:
(define (queens board-size)
(define empty-board nil)
(define (safe? k positions)
(define (small-enough? xs) (or (null? xs) (null? (cdr xs))))
(define (far-enough? x xs) (<= 2 (abs (- x (car xs)))))
(define (uniq? x xs)
(cond ((null? xs) #t)
((equal? x (car xs)) #f)
(else (uniq? x (cdr xs)))))
(or (small-enough? positions)
(let ((x (car positions)) (xs (cdr positions)))
(and (far-enough? x xs)
(uniq? x xs)))))
(define (adjoin-position new-row k rest-of-queens)
(cons new-row rest-of-queens))
(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))
以下はテスト:
(define (test-2.42)
(define (less-enough? l)
(or (null? l) (null? (cdr l))))
(define (far-enough? l)
(cond ((less-enough? l) #t)
((> 2 (abs (- (car l)
(cadr l)))) #f)
(else (far-enough? (cdr l)))))
(define (uniq? l)
(if (less-enough? l)
#t
(let loop ((x (car l)) (xs (cdr l)))
(cond ((null? xs) #t)
((equal? x (car xs)) #f)
(else (loop x (cdr xs)))))))
(use gauche.test)
(let ((result (queens 8)))
(test* "queens 8 (uniq? result)" #t (uniq? result))
(test* "queens 8 (uniq? each result)" #t
(let loop ((l result))
(cond ((null? l) #t)
((not (uniq? (car l))) #f)
(else (loop (cdr l))))))
(test* "queens 8 (far-enough? each result)" #t
(let loop ((l result))
(cond ((null? l) #t)
((not (far-enough? (car l))) #f)
(else (loop (cdr l))))))))
第28回 (9/6)
問題 2.36? accumulate-n
(define (test-2.36)
(use gauche.test)
(test* "test-2.36" '(22 26 30)
(accumulate-n + 0 '((1 2 3) (4 5 6) (7 8 9) (10 11 12)))))
(define (accumulate-n op init seqs)
(if (null? (car seqs))
nil
(cons (accumulate op init (map car seqs))
(accumulate-n op init (map cdr seqs)))))
ひらっちさんの別解あり。applyと可変長引数を使うと短くなるというもの。だけど、本文を読み進めている流れで見ると、問題文のコードの方が何をしてるかわかりやすい気がしました。
問題 2.37? 行列の計算
すっかり忘れてるので、まずはテストを書いたものの、そのテスト自体が怪しげ。確認してもらいました。問題を理解せずにテストは書けないということですね。
まずはテスト(gauche用)
(define (test-2.37)
(use gauche.test)
(test* "dot-product" (+ 2 6 12 20)
(dot-product '(1 2 3 4) '(2 3 4 5)))
(test* "matrix-*-vector" (list (+ 1 2 6)
(+ 2 4 9)
(+ 3 6 12)
(+ 4 8 15))
(matrix-*-vector '((1 1 2)
(2 2 3)
(3 3 4)
(4 4 5)) '(1 2 3)))
(test* "matrix-*-vector" '(6 7)
(matrix-*-vector '((1 1 2) (1 2 2)) '(1 1 2)))
(test* "transpose" '((1 2 3 4)
(1 2 3 4)
(2 3 4 5))
(transpose '((1 1 2)
(2 2 3)
(3 3 4)
(4 4 5))))
(test* "matrix-*-matrix"
(list (list (+ 1 2 6) (+ 1 2 6) (+ 1 2 6) (+ 2 3 8))
(list (+ 2 4 9) (+ 2 4 9) (+ 2 4 9) (+ 4 6 12))
(list (+ 3 6 12) (+ 3 6 12) (+ 3 6 12) (+ 6 9 16))
(list (+ 4 8 15) (+ 4 8 15) (+ 4 8 15) (+ 8 12 20)))
(matrix-*-matrix '((1 1 2)
(2 2 3)
(3 3 4)
(4 4 5))
'((1 1 1 2)
(2 2 2 3)
(3 3 3 4)))))
ここから解答。
(define (dot-product v w) (accumulate + 0 (map * v w)))
(define (matrix-*-vector m v) (map (lambda (i) (dot-product i v)) m))
(define (transpose m) (accumulate-n cons nil m))
(define (matrix-*-matrix m n)
(transpose
(map (lambda (i)
(matrix-*-vector m i))
(transpose n))))
matrix-*-matrix は自分で書いたら上のようにtransposeを2回やるようになってしまった。問題に忠実にやると:
(define (matrix-*-matrix m n)
(let ((cols (transpose n)))
(map (lambda (x) (matrix-*-vector cols x)) m)))
最初、このletは別にいらねーだろうと思ったけど、colsと名前を付けていることに意味があると考え直した。
問題 2.38? fold-left
つい最近「ふつうのHaskellプログラミング」でも読んだところ。
(define (fold-right op initial sequence) ; accumulate
(if (null? sequence)
initial
(op (car sequence)
(fold-right op initial (cdr sequence)))))
(define (fold-left op initial sequence)
(define (iter result rest)
(if (null? rest)
result
(iter (op result (car rest)) (cdr rest))))
(iter initial sequence))
2引数の関数(もしくは2項演算子) op の引数の順が、fold-rightとfold-leftとで逆になっているあたりでちょっとはまった。
(define (test-2.38)
(use gauche.test)
(test* "fold-right" (/ 1 (/ 2 (/ 3 1))) ; (1 / (2 / (3 / 1)))
(fold-right / 1 '(1 2 3)))
(test* "fold-left" (/ (/ (/ 1 1) 2) 3) ; (((1 / 1) / 2) / 3)
(fold-left / 1 '(1 2 3)))
(test* "fold-right" (list 1 (list 2 (list 3 nil))) ; (1 (2 (3 ())))
(fold-right list nil '(1 2 3)))
(test* "fold-left" (list (list (list nil 1) 2) 3) ; (((() 1) 2) 3)
(fold-left list nil '(1 2 3))))
fold-right と fold-left の違いは、使い慣れている中置記法で考えてみるとわかりやすい気がする。
(fold-right - 1 '(1 2 3)) => 1 ÷ (2 ÷ (3 ÷ 1)) (fold-left - 1 '(1 2 3)) => ((1 ÷ 1) ÷ 2) ÷ 3
(fold-right op INITIAL '(E1..En))
=> E1 op (E2 op (E3 op (...(En op INITIAL)...)))
(fold-left op INITIAL '(E1..En))
=> (...(((INITIAL op E1) op E2) op E3)...) op En
fold-light と fold-left の違いを打ち消すためにopが満たすべき性質
fold-lightとfold-leftがどんな並びに対しても同じ値を生じるためにopが満たすべき性質は何か？
op の引数の順が意味を持たないこと、引数を入れ替えても値が同じであること(可換性)…と思ったのだけど、杉本さんによると:
- 結合律が成り立つこと
- INITIALが単位元であること
とのこと。結合律が成り立つというのは、op の演算を連続して行う場合に、どの順で計算しても同じ値になるとということ。中置記法で書くと、任意のA,B,Cについて:
(A op B) op C ;; 左結合 A op (B op C) ;; 右結合
の値が同じになるということ。可換性があれば結合律が成立する。しかし、可換性がなくて結合律が成立する場合もある。行列の積(byひらっちさん)、append関数など。
また、単位元というのは、任意のAについて:
INITIAL op A ＝ A A op INITIAL ＝ A
が成り立つような INITIAL の値のこと。
(参考) http://ja.wikipedia.org/wiki/結合法則
問題 2.39? fold-(right/left)でreverseを定義
(define (test-2.39)
(use gauche.test)
(test* "reverse by fold-right" '(4 3 2 1)
(reverse-by-fold-right '(1 2 3 4)))
(test* "reverse by fold-left" '(4 3 2 1)
(reverse-by-fold-left '(1 2 3 4))))
(define (reverse-by-fold-right sequence)
(fold-right (lambda (x y)
(append y (list x)))
nil sequence))
(define (reverse-by-fold-left sequence)
(fold-left (lambda (x y)
(cons y x))
nil sequence))
第27回 (8/30)
2.2.3 公認インターフェースとしての並び
(define (sum-odd-squares tree)
(cond ((null? tree) 0)
((not (pair? tree))
(if (odd? tree) (square tree) 0))
(else
(+ (sum-odd-squares (car tree))
(sum-odd-squares (cdr tree))))))
(define (even-fibs n)
(define (next k)
(if (> k n)
nil
(let ((f (fib k)))
(if (even? f)
(cons f (next (+ k 1)))
(next (+ k 1))))))
(next 0))
並びの演算
(define (filter predicate sequence)
(cond ((null? sequence) '())
((predicate (car sequence))
(cons (car sequence)
(filter predicate (cdr sequence))))
(else
(filter predicate (cdr sequence)))))
(define (test-filter) (use gauche.test) (test* "filter" '(1 3 5) (filter odd? '(1 2 3 4 5))))
(define (accumulate op initial sequence)
(if (null? sequence)
initial
(op (car sequence)
(accumulate op initial (cdr sequence)))))
(define (test-accumulate) (use gauche.test) (test* "accumulate" 15 (accumulate + 0 '(1 2 3 4 5))) (test* "accumulate" 120 (accumulate * 1 '(1 2 3 4 5))) (test* "accumulate" '(1 2 3 4 5) (accumulate cons '() '(1 2 3 4 5))))
(define (enumerate-interval low high)
(if (> low high)
nil
(cons low (enumerate-interval (+ low 1) high))))
(define (test-enumerate-interval)
(use gauche.test)
(test* "enumerate-interval" '(2 3 4 5 6 7)
(enumerate-interval 2 7)))
(define (enumerate-tree tree)
(cond ((null? tree) '())
((not (pair? tree)) (list tree))
(else (append (enumerate-tree (car tree))
(enumerate-tree (cdr tree))))))
(define (test-enumerate-tree)
(use gauche.test)
(test* "enumerate-tree" '(1 2 3 4 5)
(enumerate-tree '(1 (2 (3 4) 5)))))
(define (sum-odd-squares tree)
(accumulate + 0
(map square
(filter odd?
(enumerate-tree tree)))))
(define (even-fibs n)
(accumulate cons '()
(filter even?
(map fib
(enumerate-interval 0 n)))))
(define (test-signal-procedure)
(use gauche.test)
(test* "sum-odd-squares" (+ 1 9 25)
(sum-odd-squares '(1 (2 (3 4) 5))))
(test* "even-fibs" '(0 2) (even-fibs 5))) ; (0 1 1 2 3 5)
(define (list-fib-squares n)
(accumulate cons '()
(map square
(map fib
(enumerate-interval 0 n)))))
(define (test-list-fib-squares)
(use gauche.test)
(test* "list-fib-squares" '(0 1 1 4 9 25 64 169 441 1156 3025)
(list-fib-squares 10)))
(define (product-of-squares-of-odd-elements sequence)
(accumulate * 1
(map square
(filter odd? sequence))))
(define (test-product-of-squares-of-odd-elements)
(use gauche.test)
(test* "product-of-squares-of-odd-elements" 225
(product-of-squares-of-odd-elements '(1 2 3 4 5))))
(define (salary-of-highest-paid-programmer records)
(accumulate max 0
(map salary
(filter programmer? records))))
問題 2.33?
(define (map* p sequence)
(accumulate (lambda (x y) (cons (p x) y))
nil sequence))
(define (append* seq1 seq2) (accumulate cons seq2 seq1))
(define (length* sequence)
(accumulate (lambda (x y) (+ y 1))
0 sequence))
(define (test-2.33) (use gauche.test) (test* "map*" '(1 4 9 16 25) (map* square '(1 2 3 4 5))) (test* "append*" '(1 1 1 2 2 2) (append* '(1 1 1) '(2 2 2))) (test* "length*" 5 (length* '(1 2 3 4 5))))
問題 2.34? 多項式の評価
a[n](x^n) + a[n-1](x^(n-1)) + ... + a[1]x + a[0] = (((a[n])x + a[n-1])x + a[n-2])x + ... + a[1])x + a[0]
(define (test-2.34)
(use gauche.test)
(test* "horner-eval" (+ 1 6 40 32)
(horner-eval 2 (list 1 3 0 5 0 1))))
(define (horner-eval x coefficient-sequence)
(accumulate (lambda (this-coeff higher-terms)
(+ (* higher-terms x) this-coeff))
0
coefficient-sequence))
問題 2.35? count-leaves を accumulate で定義
(define (test-2.35) (define x (cons (list 1 2) (list 3 4))) (use gauche.test) (test* "count-leaves" 4 (count-leaves x)) (test* "count-leaves" 8 (count-leaves (list x x))))
(define (count-leaves tree)
(accumulate + 0
(map (lambda (x)
(cond ((not (pair? x)) 1)
(else (count-leaves x))))
tree)))
第26回
問題 2.30? square-tree
テスト(gauche用)
(define (test-2.30)
(use gauche.test)
(test* "square-tree" '(1 (4 (9 16) 25) (36 49))
(square-tree '(1 (2 (3 4) 5) ( 6 7)))))
直接
(define (square-tree tree)
(define (square x) (* x x))
(cond ((null? tree) nil)
((not (pair? tree)) (square tree))
(else (cons (square-tree (car tree))
(square-tree (cdr tree))))))
map使用
(define (square-tree tree)
(define (square x) (* x x))
(map (lambda (tree)
(if (pair? tree)
(square-tree tree)
(square tree)))
tree))
問題 2.31? tree-map
(define (tree-map func tree)
(map (lambda (tree)
(if (pair? tree)
(tree-map func tree)
(func tree)))
tree))
(begin (define (square x) (* x x)) (define (square-tree tree) (tree-map square tree)) (test-2.30))
問題 2.32? 集合の全ての部分集合の集合
集合は異なる要素のリストで表現できる。集合の全ての部分集合の集合は リストのリストで表現できる。以下のsubsetsはなぜうまくいくか、明快 に説明せよ。
(define (test-2.32)
(use gauche.test)
(test* "test-2.32" '(() (3) (2) (2 3) (1) (1 3) (1 2) (1 2 3))
(subsets '(1 2 3))))
(define (subsets s)
(if (null? s)
(list nil)
(let ((rest (subsets (cdr s))))
(append rest
(map (lambda (x) (cons (car s) x))
rest)))))
subsets [] = [[]]
subsets (x:xs) = rest ++ map (x:) rest -- xを含まない集合と含む集合の和
where rest = subsets xs -- restはベキ集合のうちxを含まないもの
さらに、このプログラムの意味を日本語で理解しやすいように書き直してみました。 (明快に説明したつもり)
(define (ベキ集合 s) ; 集合sのベキ集合を返す関数
(define (集合の和 . ss) (apply append ss))
(define (空集合? s) (null? s))
(define 空集合1つを要素とする集合 (list nil))
(if (空集合? s)
空集合1つを要素とする集合
(let ((要素e (car s)) ; 集合sの要素のうちの1つ
(e以外すべて (cdr s))) ; e以外のすべてを要素とするsの部分集合
(let ((eを含まない集合の集合 (ベキ集合 e以外すべて))
(eを要素に加える (lambda (s) (cons 要素e s))))
(let ((eを含む集合の集合
(map eを要素に加える eを含まない集合の集合)))
(集合の和 eを含まない集合の集合
eを含む集合の集合))))))
(define (test-ベキ集合)
(use gauche.test)
(test* "test-ベキ集合" '(() (3) (2) (2 3) (1) (1 3) (1 2) (1 2 3))
(ベキ集合 '(1 2 3))))
これを書いてみた思ったこと。「プログラムを説明的にすること＝適切な名前を付 ける」に近い。一方で、入門Haskellなどを読んでいても感じることだが、高階 関数をうまく使おうとすると、名前付けを極力避ける方向に向かうようだ。プ ログラムを自然言語で説明的にしようとすること(AppleScript?とかCobolとか) と、高階関数プログラミング(名前から意味を取り去るのが数学や論理学の宿 命？)には、どこかしら相反するところがありそうだなぁ、と実感。
第25回 (欠席)
問題 2.29 二進モービル
書いただけでテストしてない。
(define (make-mobile left right) (list left right))
(define (make-branch length structure) (list length structure))
(a)
(define (left-branch mobile) (car mobile)) (define (right-branch mobile) (cadr mobile)) (define (branch-length branch) (car branch)) (define (branch-structure branch) (cadr branch))
(b)
(define (total-weight mobile)
(define (mobile? structure)
(pair? structure))
(define (branch-weight branch)
(let ((structure (branch-structure branch)))
(if (mobile? structure)
(total-weight structure)
structure)))
(+ (branch-weight (left-branch mobile))
(branch-weight (right-branch mobile))))
(c)
(define (balanced? mobile)
(define (mobile? branch)
(pair? structure))
(define (torque branch)
(* (branch-length branch)
(let ((structure (branch-structure branch)))
(if (mobile? branch)
(total-weight structure)
structure))))
(let ((branch-l (left-branch mobile))
(branch-r (right-branch mobile)))
(and (= (torque branch-l) (torque branch-r))
(mobile? branch-l)
(balanced? (branch-structure branch-l))
(mobile? branch-r)
(balanced? (branch-structure branch-r))
#t)))
(d) 構成子をconsに変更すると？
選択子の変更が必要。ただし list から cons に変更しただけなので、car部に 置くデータの選択肢 left-branch と branch-length に関しては、変更不要。
(define (right-branch mobile) (cdr mobile)) (define (branch-structure branch) (cdr branch))
第23回
問題 2.20 same-parity
(define (test-2.20)
(use gauche.test)
(test* "test-2.20" '(1 3 5 7) (same-parity 1 2 3 4 5 6 7))
(test* "test-2.20" '(2 4 6) (same-parity 2 3 4 5 6 7)))
(define (same-parity fst . rest)
(define (same? x)
(= (remainder fst 2) (remainder x 2)))
(define (make lst)
(if (null? lst)
'()
(if (same? (car lst))
(cons (car lst) (make (cdr lst)))
(make (cdr lst)))))
(cons fst (make rest)))
Ruiさんの答えがきれい。
リストの写像
;; scale-list
(define (test-scale-list)
(use gauche.test)
(test* "test scale-list" '(10 20 30 40 50)
(scale-list (list 1 2 3 4 5) 10)))
(define (scale-list items factor)
(if (null? items)
'()
(cons (* (car items) factor)
(scale-list (cdr items) factor))))
;; map*
(define (test-map*)
(use gauche.test)
(test* "test map" '(10 2.5 11.6 17)
(map* abs (list -10 2.5 -11.6 17)))
(test* "test map" '(1 4 9 16)
(map* (lambda (x) (* x x))
(list 1 2 3 4))))
(define (map* proc items)
(if (null? items)
'()
(cons (proc (car items))
(map* proc (cdr items)))))
問題 2.21 square-list
(define (test-square-list)
(use gauche.test)
(test* "test square-list-1" '(1 4 9 16)
(square-list-1 (list 1 2 3 4)))
(test* "test square-list-2" '(1 4 9 16)
(square-list-2 (list 1 2 3 4))))
(define (square-list-1 items)
(define (square x) (* x x))
(if (null? items)
'()
(cons (square (car items))
(square-list-1 (cdr items)))))
(define (square-list-2 items)
(map (lambda (x) (* x x)) items))
問題 2.22 square-list 反復プロセス版
(define (test-2.22)
(use gauche.test)
(test* "逆順になる" '(16 9 4 1)
(square-list-i-0 (list 1 2 3 4))))
(define (square-list-i-0 items)
(define (square x) (* x x))
(define (iter things answer)
(if (null? things)
answer
(iter (cdr things)
(cons (square (car things))
answer))))
(iter items '()))
なぜ逆になるか？
iterの再帰呼び出しのconsは左側から積まれていく。
(cons (_ 1) nil) => (1) (cons (_ 2) (cons (_ 1) nil)) => (4 1) (cons (_ 3) (cons (_ 2) (cons (_ 1) nil))) => (9 4 1) (cons (_ 4) (cons (_ 3) (cons (_ 2) (cons (_ 1) nil)))) => (16 9 4 1)
consの引数を逆にしてみたが、これもだめ！なぜか？
(cons nil (_ 1)) => (nil . 1) (cons (cons nil (_ 1)) (_ 2)) => ((nil . 1) . 4) (cons (cons (cons nil (_ 1)) (_ 2)) (_ 3)) => (((nil . 1) . 4) . 9) (cons (cons (cons (cons nil (_ 1)) (_ 2)) (_ 3)) (_ 4)) => ((((nil . 1) . 4) . 9) . 16)
問題 2.23 for-each
(define (for-each* proc items)
(cond ((null? items) #t)
(else (proc (car items))
(for-each* proc (cdr items)))))
(define (test-2.23)
(for-each* (lambda (x) (newline) (display x))
(list 57 321 88)))
第18回、19回は欠席
問題 2.3? 長方形の表現
x軸,y軸に平行なものに限定
長方形の周囲の長さ
(define (perimeter rect)
(+ (* 2 (width-rect rect))
(* 2 (height-rect rect))))
長方形の面積
(define (area rect)
(* (width-rect rect)
(height-rect rect)))
表現A
(define (make-rect left top right bot)
(cons (make-point left top)
(make-point right bot)))
(define (left-top-rect rect) (car rect)) (define (right-bot-rect rect) (cdr rect))
(define (width-rect rect)
(- (x-point (right-bot-rect rect))
(x-point (left-top-rect rect))))
(define (height-rect rect)
(- (y-point (right-bot-rect rect))
(y-point (left-top-rect rect))))
表現B
(define (make-rect2 left top width height)
(cons (make-point left top)
(make-point (+ left width) (+ top height))))
2.1.3 データとは何か？
cons, car, cdr をデータ構造を使わずと手続きのみで実装
問題 2.4? 対の(別の)手続き表現
(define (cons* x y) (lambda (m) (m x y))) (define (car* z) (z (lambda (p q) p))) (define (cdr* z) (z (lambda (p q) q)))
(car* (cons* x y)) => x を証明せよ
作用的順序(P.8)で置き換えていくと…
(car* (cons* x y)) (car* (lambda (m) (m x y))) ((lambda (m) (m x y)) (lambda (p q) p)) ((lambda (p q) p) x y) x
問題 2.5? (cons a b) を素因数分解で表現
(2^a)*(3^b) で表わす。a,bは非負の整数限定。 (素因数分解で表わす→ゲーデル数？)
(define (cons* x y) (* (expt 2 x) (expt 3 y)))
(define (car* z)
(if (= (remainder z 2) 0)
(+ 1 (car* (/ z 2)))
0))
(define (cdr* z)
(if (= (remainder z 3) 0)
(+ 1 (cdr* (/ z 3)))
0))
問題 2.6 自然数を手続きで表現 (Church数)
(define zero (lambda (f) (lambda (x) x))) (define (add-1 n) (lambda (f) (lambda (x) (f ((n f) x)))))
one と two を直接定義せよ
(add-1 zero) を作用的順序で置き換えていく
(add-1 zero) (add-1 (lambda (f) (lambda (x) x))) (lambda (f) (lambda (x) (f (((lambda (f) (lambda (x) x)) f) x)))) (lambda (f) (lambda (x) (f ((lambda (x) x) x)))) (lambda (f) (lambda (x) (f x)))
(add-1 (add-1 zero)) を作用的順序で置き換えていく
(add-1 one) (add-1 (lambda (f) (lambda (x) (f x)))) (lambda (f) (lambda (x) (f (((lambda (f) (lambda (x) (f x))) f) x)))) (lambda (f) (lambda (x) (f ((lambda (x) (f x)) x)))) (lambda (f) (lambda (x) (f (f x))))
つまり
(define zero (lambda (f) (lambda (x) x))) (define one (lambda (f) (lambda (x) (f x)))) (define two (lambda (f) (lambda (x) (f (f x))))) ;; さらにおそらく (define three (lambda (f) (lambda (x) (f (f (f x)))))) (define four (lambda (f) (lambda (x) (f (f (f (f x))))))) ...
add-1を繰り返し作用させずに加算手続き+を定義せよ。
これはわからなかったのでひらたさんの答えを見た。fの適用回数と下の定義のつながりがまだ見えず…
(define (plus n m) (lambda (f) (lambda (x) ((n f) ((m f) x)))))
2.1.4 拡張問題; 区間算術演算
(define (add-interval x y)
(make-interval (+ (lower-bound x) (lower-bound y))
(+ (upper-bound x) (upper-bound y))))
(define (mul-interval x y)
(let ((p1 (* (lower-bound x) (lower-bound y)))
(p2 (* (lower-bound x) (upper-bound y)))
(p3 (* (upper-bound x) (lower-bound y)))
(p4 (* (upper-bound x) (upeer-bound y))))
(make-interval (min p1 p2 p3 p4)
(max p1 p2 p3 p4))))
(define (div-interval x y)
(mul-interval x
(make-interval (/ 1.0 (upper-bound y))
(/ 1.0 (lower-bound y)))))
問題 2.7 区間の構成子と選択子を定義せよ
(define (make-interval a b) (cons a b)) (define (lower-bound i) (car i)) (define (upper-bound i) (cdr i))
問題 2.8 区間の差の計算
以降はまだやってない。区間算術演算苦手
第17回 (2006.6.14)
問題 2.2? 平面の線分の表現
(define (make-segment pt0 pt1) (cons pt0 pt1)) (define (start-segment seg) (car seg)) (define (end-segment seg) (cdr seg))
(define (make-point x y) (cons x y)) (define (x-point pt) (car pt)) (define (y-point pt) (cdr pt))
(define (midpoint-segment seg)
(define (mid a b) (/ (+ a b) 2))
(let ((start (start-segment seg))
(end (end-segment seg)))
(make-point (mid (x-point start) (x-point end))
(mid (y-point start) (y-point end)))))
問題 2.1? make-rat を正負対応せよ
(define (make-rat n d)
(let ((g (gcd n d))
(s (cond ((and (< n 0) (> d 0)) -)
((and (> n 0) (< d 0)) -)
(else +))))
(cons (s (/ (abs n) g)) (/ (abs d) g))))
Keyword(s):
References:[TadashiHirataChapter2_1] [MemberSchedules] [MemberSchedules2007Q1] [MemberSchedules2007Q2] [MemberSchedules2007Q3] [MemberProfiles] [TadashiHirataChapter1] [OkazawaYuji] [WhatToDo20060503] [MemberSchedules2006Q1] [MemberSchedules2006Q2] [MemberSchedules2006Q3] [MemberSchedules2006Q4]