SICP 読み (51) 2.4.3 データ主導プログラミングと加法性
大切なサケを吸収されたのは問題 2.73 の頁あたり。
ここ、動かん (というか動かせん) とゆーのは苦痛なんで 3.3.3 節から表の手続きをパクって動かしてしまえ。
で、面倒なので SICP のサイトから全部パクった。以下で動くはず。
(define (assoc key records)
(cond ((null? records) #f)
((equal? key (caar records)) (car records))
(else (assoc key (cdr records)))))
(define (make-table)
(let ((local-table (list '*table*)))
(define (lookup key-1 key-2)
(let ((subtable (assoc key-1 (cdr local-table))))
(if subtable
(let ((record (assoc key-2 (cdr subtable))))
(if record
(cdr record)
#f))
#f)))
(define (insert! key-1 key-2 value)
(let ((subtable (assoc key-1 (cdr local-table))))
(if subtable
(let ((record (assoc key-2 (cdr subtable))))
(if record
(set-cdr! record value)
(set-cdr! subtable
(cons (cons key-2 value) (cdr subtable)))))
(set-cdr! local-table
(cons (list key-1
(cons key-2 value))
(cdr local-table)))))
'ok)
(define (dispatch m)
(cond ((eq? m 'lookup-proc) lookup)
((eq? m 'insert-proc!) insert!)
(else (error "Unknown operation -- TABLE" m))))
dispatch))
(define operation-table (make-table))
(define get (operation-table 'lookup-proc))
(define put (operation-table 'insert-proc!))
(define (attach-tag type-tag contents)
(cons type-tag contents))
(define (type-tag datum)
(if (pair? datum)
(car datum)
(error "Bad tagged datum -- TYPE TAG" datum)))
(define (contents datum)
(if (pair? datum)
(cdr datum)
(error "Bad tagged datum -- CONTENTS" datum)))
(define (install-rectangular-package)
;; internal procedures
(define (real-part z) (car z))
(define (imag-part z) (cdr z))
(define (make-from-real-imag x y) (cons x y))
(define (magnitude z)
(sqrt (+ (square (real-part z))
(square (imag-part z)))))
(define (angle z)
(atan (imag-part z) (real-part z)))
(define (make-from-mag-ang r a)
(cons (* r (cos a)) (* r (sin a))))
;; interface to the rest of the system
(define (tag x) (attach-tag 'rectangular x))
(put 'real-part '(rectangular) real-part)
(put 'imag-part '(rectangular) imag-part)
(put 'magnitude '(rectangular) magnitude)
(put 'angle '(rectangular) angle)
(put 'make-from-real-imag 'rectangular
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'rectangular
(lambda (r a) (tag (make-from-mag-ang r a))))
'done)
(define (install-polar-package)
;; internal procedures
(define (magnitude z) (car z))
(define (angle z) (cdr z))
(define (make-from-mag-ang r a) (cons r a))
(define (real-part z)
(* (magnitude z) (cos (angle z))))
(define (imag-part z)
(* (magnitude z) (sin (angle z))))
(define (make-from-real-imag x y)
(cons (sqrt (+ (square x) (square y)))
(atan y x)))
;; interface to the rest of the system
(define (tag x) (attach-tag 'polar x))
(put 'real-part '(polar) real-part)
(put 'imag-part '(polar) imag-part)
(put 'magnitude '(polar) magnitude)
(put 'angle '(polar) angle)
(put 'make-from-real-imag 'polar
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'polar
(lambda (r a) (tag (make-from-mag-ang r a))))
'done)
(define (apply-generic op . args)
(let ((type-tags (map type-tag args)))
(let ((proc (get op type-tags)))
(if proc
(apply proc (map contents args))
(error
"No method for these types -- APPLY-GENERIC"
(list op type-tags))))))
(define (real-part z) (apply-generic 'real-part z))
(define (imag-part z) (apply-generic 'imag-part z))
(define (magnitude z) (apply-generic 'magnitude z))
(define (angle z) (apply-generic 'angle z))
(define (make-from-real-imag x y)
((get 'make-from-real-imag 'rectangular) x y))
(define (make-from-mag-ang r a)
((get 'make-from-mag-ang 'polar) r a))で、これから試験を検討するんですが、表の関係の試験は略そう。
とりあえず、こんな試験を書いた。
(let ((obj (make-from-real-imag (sqrt 3) 1.0)))
(assert-equal (marume (sqrt 3))
(marume (apply-generic 'real-part obj))))で、動かしてみると
$ test/run-test.scm -vv - (test suite) 2.4.3 -- (test case) apply-generic test: E ./test/test-2.4.3.scm:16: (make-from-real-imag (sqrt 3) 1.0) Error occurred in apply-generic test *** ERROR: invalid application: (#f 1.7320508075688772 1.0) ./test/test-2.4.3.scm:16: (make-from-real-imag (sqrt 3) 1.0) 1 tests, 1 assertions, 0 successes, 0 failures, 1 errors Testing time: 0 $
あら、lookup がきちんと動いてないの?? と思ったらパケジを install する手続きを呼びださなければ、な事に気がつく (とほほほ
で、こう。
(let ((rect (install-rectangular-package))
(pol (install-polar-package)))
(let ((obj (make-from-real-imag (sqrt 3) 1.0)))
(assert-equal (marume (sqrt 3))
(marume (apply-generic 'real-part obj)))))で、試験。
$ test/run-test.scm -vv - (test suite) 2.4.3 -- (test case) apply-generic test: . 1 tests, 1 assertions, 1 successes, 0 failures, 0 errors Testing time: 0.014618 $
を、動いたぞ。いちいち let で install するのは面倒なので setup を使ってみる。
(define-test-suite "2.4.3"
("apply-generic test"
(setup (lambda ()
(install-rectangular-package)
(install-polar-package)))
("apply-generic test"
(let ((obj (make-from-real-imag (sqrt 3) 1.0)))
(assert-equal (marume (sqrt 3))
(marume (apply-generic 'real-part obj))))
)
)
)ちゃんと動いている模様。そろそろきちんと試験を検討する事に。
微妙な点を以下に列挙
- p.106 の註釈にある「記号 rectangular でなく、リスト (rectangular) を使ったのは、同一型でない複数個の引数の演算があるかも知れないためだ。」というもの。
- 2.4.2 において attach-tag と type-tag と contents の試験をしていない
- apply-generic の試験、ポイント高い。
- ((get 'make-from-real-imag 'rectangular) x y) は何を戻すのか
という事で、とりあえず attach-tag と type-tag と contents の試験を。確認するのは以下で良いか。
- attach-tag
- attach-tag の戻りを car したら attach-tag の第一引数と同じ値であること
- attach-tag の戻りを cdr したら attach-tag の第二引数と同じ値であること
- type-tag
- ペアでないものを渡したら例外発生
- 渡したリストの car と同値が戻されていること
- contesnts
- ペアでないものを渡したら例外発生
- 渡したリストの cdr と同値が戻されていること
試験は以下。
("attach-tag test"
("attach-tag test"
(assert-equal 'a (car (attach-tag 'a '(b c d))))
(assert-equal '(b c d) (cdr (attach-tag 'a '(b c d))))
)
)
("type-tag test"
("type-tag test"
(assert-error (lambda () (type-tag 'a)))
(assert-equal 'a (type-tag (cons 'a '(b c d))))
)
)
("contents test"
("contents test"
(assert-error (lambda () (contents 'a)))
(assert-equal '(b c d) (contents (cons 'a '(b c d))))
)
)次、apply-generic の試験について。
微妙なのが、args を map している部分。こんな手続きを作って様子を見てみる。
gosh> (define (test a . b)
(define (p x)
(display x)
(newline))
(p a)
(p b))
test
gosh>で、こうしてみる。
gosh> (test 'real-part ((get 'make-from-real-imag 'rectangular) (sqrt 3) 1.0)) real-part ((rectangular 1.7320508075688772 . 1.0)) #<undef> gosh>
とか
gosh> (test 'real-part ((get 'make-from-mag-ang 'polar) 2 (/ pi 6))) real-part ((polar 2 . 0.5235987755982988)) #<undef> gosh>
とか。args はリストのリストになっている。これを type-tag で map したらどうなるのか。
gosh> (map type-tag '((polar 2 . 0.5235987755982988))) (polar) gosh> (map type-tag '((polar 2 . 0.5235987755982988) (rectangular 1.7320508075688772 . 1.0))) (polar rectangular) gosh>
むむ。あるいは
gosh> (map contents '((polar 2 . 0.5235987755982988))) ((2 . 0.5235987755982988)) gosh> (map contents '((polar 2 . 0.5235987755982988) (rectangular 1.7320508075688772 . 1.0))) ((2 . 0.5235987755982988) (1.7320508075688772 . 1.0)) gosh>
したらこれは??
gosh> (get 'real-part '(polar)) #<closure (install-polar-package real-part)> gosh>
手続きが戻ってきた。当たり前か。最終的に適用されるのがこんな感じですか。
gosh> (apply (get 'real-part '(polar)) (map contents '((polar 2 . 0.5235987755982988)))) 1.7320508075688774 gosh>
備忘録までもう少し
gosh> (apply
(get 'real-part
(map type-tag '((polar 2 . 0.5235987755982988))))
(map contents '((polar 2 . 0.5235987755982988))))
1.7320508075688774
gosh> 手続きの定義を見るに、map を使って手続きを取り出したり、渡す引数を取り出しているのは註釈にもあるように_ドット末尾記法_を使っているから??
註釈 45 とか 47 にある「同一型でない複数個の引数があるかも知れない」とか「異る汎用演算は引数の個数が異るかも知れぬ」というソレが今ひとつ理解できてないなぁ。
とりあえず意味的にそのまんまと判断して試験を検討。試験としては
- put した手続きが呼び出されている
- put されていない場合、error
- 異る型の複数の引数を使用するケース
という事で以下。なんと言えば良いか分かりませんが微妙。
("apply-generic test"
(setup (lambda ()
(define (install-test-package)
(define (square x) (* x x))
(define (rect-mag x y)
(sqrt (+ (square (car x))
(square (cdr x)))))
(define (polar-mag x y) (car y))
(put 'rect-mag '(rectangular polar) rect-mag)
(put 'polar-mag '(rectangular polar) polar-mag)
'done)
(install-test-package)
(install-rectangular-package)
(install-polar-package)))
("apply-generic test"
(let ((obj (make-from-real-imag (sqrt 3) 1.0)))
(assert-equal '(rectangular)
(map type-tag '((rectangular 1.7320508075688772 . 1.0))))
(assert-equal '(rectangular polar)
(map type-tag '((rectangular 1.7320508075688772 . 1.0)
(polar 2 . 0.5235987755982988))))
(assert-equal '((1.7320508075688772 . 1.0))
(map contents '((rectangular 1.7320508075688772 . 1.0))))
(assert-equal '((1.7320508075688772 . 1.0) (2 . 0.5235987755982988))
(map contents '((rectangular 1.7320508075688772 . 1.0)
(polar 2 . 0.5235987755982988))))
(assert-equal (sqrt 3)
(apply-generic 'real-part obj))
(assert-equal 2.0
(apply-generic 'rect-mag
'(rectangular 1.7320508075688772 . 1.0)
'(polar 2 . 0.5235987755982988)))
(assert-equal 2
(apply-generic 'polar-mag
'(rectangular 1.7320508075688772 . 1.0)
'(polar 2 . 0.5235987755982988)))
(assert-error (lambda ()(apply-generic 'xxx obj))))
)
)一応複数引数で異る型にも対応している。他の試験は略。
