SICP 読書ノート#24 - 2.5.2 異なる型のデータ統合 (pp.113-118)

「§2.5.2 異なる型のデータ統合」から。

全体のソースコードはGitHubに置いています。

https://github.com/uents/sicp/blob/master/ch2/ch2.5.2.scm

異なる型のデータ統合

前回のエントリで汎用演算システムを構築したが、異なる型同士の計算はできなかった。

racket@> (add (make-scheme-number 1) (make-rational 3 2))
(Bad key -- TYPE (scheme-number rational))
No method for these types -- APPLY-GENERIC (add (scheme-number rational))
  context...:
   /Applications/Racket6.0.1/collects/racket/private/misc.rkt:87:7

そこで型変換の仕組みを導入することで、上記の計算が行えるようにしていく。

型変換テーブル

演算テーブルで使ったハッシュテーブルを拡張し、型変換テーブルを定義する。

(define (put-table table key1 key2 item)
  (if (not (hash-has-key? table key1))
      (hash-set! table key1 (make-hash))
      true)
  (hash-set! (hash-ref table key1) key2 item))

(define (get-table table key1 key2)
  (define (not-found . msg)
;  (display msg (current-error-port))
;  (display "\n")
    false)
  (if (hash-has-key? table key1)
      (if (hash-has-key? (hash-ref table key1) key2)
          (hash-ref (hash-ref table key1) key2)
          (not-found "Bad key -- KEY2" key2))
      (not-found "Bad key -- KEY1" key1)))

;; 演算テーブル
(define *op-table* (make-hash))
(define (put op type item)
  (put-table *op-table* op type item))
(define (get op type)
  (get-table *op-table* op type))

;; 型変換テーブル
(define *coercion-table* (make-hash))
(define (put-coercion type1 type2 item)
  (put-table *coercion-table* type1 type2 item))
(define (get-coercion type1 type2)
  (get-table *coercion-table* type1 type2))

apply-generic

テキストから写経。演算手続きがなければ引数の型チェックを行う。型が一致しない場合は型変換手続きを探し、あれば適用する。

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

整数パッケージの追加

問題を解いていくには型パッケージをひと通り用意する必要がある。

型	パッケージ
複素数	complex-package
実数	scheme-number-package
有理数	rational-pacakge
整数	integer-package

と見立てると、複素数、実数、有理数は既出なので、整数パッケージを追加する。

(define (install-integer-package)
  ;; interface
  (define (tag x) (attach-tag 'integer x))
  (put 'add '(integer integer)
       (lambda (x y) (tag (+ x y))))
  (put 'sub '(integer integer)
       (lambda (x y) (tag (- x y))))
  (put 'mul '(integer integer)
       (lambda (x y) (tag (* x y))))
  (put 'div '(integer integer)
       (lambda (x y) (tag (/ x y))))
  (put 'make 'integer
       (lambda (x) (tag (floor x))))
  ;; ex 2.79
  (put 'equ? '(integer integer)
       (lambda (x y) (= x y)))
  ;; ex 2.80
  (put '=zero? '(integer)
       (lambda (x) (= x 0)))

  'done)

;; constructor
(define (make-integer n)
  ((get 'make 'integer) n))

(install-integer-package)

問題 2.81

Louisは同じ型どうしでも型変換を試みるように提案した。

例えば、以下のような型変換手続きを定義する。

(define (scheme-number->scheme-number n) n)
(define (complex->complex z) z)

(put-coercion 'scheme-number 'scheme-number
              scheme-number->scheme-number)
(put-coercion 'complex 'complex
              complex->complex)

a.

汎用べき乗演算

(define (exp x y) (apply-generic 'exp x y))

が定義してあり、scheme-numberパッケージのみ

(put 'exp '(scheme-number scheme-number)
     (lambda (x y) (tag (expt x y))))

があるが、他のパッケージにはないとする。2つの複素数を引数としてexpを呼び出すと何が起きるか？

試してみる。

racket@> (exp (make-complex-from-real-imag 1 1) (make-complex-from-real-imag 4 3))
(Bad key -- KEY2 (complex complex))
(Bad key -- KEY2 (complex complex))
(Bad key -- KEY2 (complex complex))
(Bad key -- KEY2 (complex complex))
(Bad key -- KEY2 (complex complex))
....

と無限ループが発生。理由は、

apply-genericの中でexp手続きを探すため、(get 'exp '(complex complex))が実行され#fが返る
1の返値はproc````に格納されるため、procが#fとなる。よって、proc```手続きの実行は行われず、型変換の処理に入る
type1 type2とも'complexのため、``t1->t2にcomplex->complex```手続きが格納される
ところが (apply-generic op (t1->t2 a1) a2) → (apply-generic op a1 a2) となり、同じ条件で再度apply-genericが実行される
1に戻る

b.

Louisは間違っている。aのように無限ループとなり正しく動作しない。

c.

2つの引数が同じであれば強制型変換を試みないように、apply-genericを修正せよ。

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

テスト。

racket@> (exp (make-complex-from-real-imag 1 1) (make-complex-from-real-imag 4 3))
(Bad key -- KEY2 (complex complex))
No method for these types (exp (complex complex))
  context...:
   /Applications/Racket6.0.1/collects/racket/private/misc.rkt:87:7

問題 2.82

型変換を単に先頭の引数の型に合わせるという手法では、引数の情報が落ちる可能性がある。

例えば第1引数を整数、第2引数を虚数が存在する複素数とすると、単に先頭の引数の型に変換する手法では整数に変換されるため、第2引数の虚数の情報が落ちてしまう。

問題 2.83

上位の型に変換するraise手続きを実装する。

integerパッケージに以下を追加。

(put 'raise '(integer)
     (lambda (z) (make-rational z 1)))

rationalパッケージに以下を追加。

(put 'raise '(rational)
     (lambda (z) (make-scheme-number (/ (numer z) (denom z)))))

scheme-numberパッケージに以下を追加。

(put 'raise '(scheme-number)
     (lambda (z) (make-complex-from-real-imag z 0)))

raise手続きを追加。型変換処理は不要のためapply-genericは使わない。

(define (raise z)
  (let ((proc (get 'raise (list (type-tag z)))))
    (if proc
        (proc (contents z))
        false)))

テスト。

racket@> (raise (make-integer 3))
'(rational 3 . 1)

racket@> (raise (raise (make-integer 3)))
'(scheme-number . 3)

racket@> (raise (raise (raise (make-integer 3))))
'(complex rectangular 3 . 0)

racket@> (raise (raise (raise (raise (make-integer 3)))))
#f

問題 2.84

引数の型が一致しなければ、引数の型を高めるようapply-genericを修正する。

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

どちらの引数の型が高いかを判別する述語手続き higher-type? を実装。

(define type-tower '(complex scheme-number rational integer))

(define (higher-type? type1 type2)
  (define (iter tower)
    (if (null? tower)
        false
        (cond ((eq? type1 (car tower)) type1)
              ((eq? type2 (car tower)) type2)
              (else (iter (cdr tower))))))
  (iter type-tower))

型上げを行う手続きを型変換テーブルに追加。

(put-coercion 'integer 'rational
              (lambda (z) (raise z)))
(put-coercion 'integer 'scheme-number
              (lambda (z) (raise (raise z))))
(put-coercion 'integer 'complex
              (lambda (z) (raise (raise (raise z)))))

(put-coercion 'rational 'scheme-number
              (lambda (z) (raise z)))
(put-coercion 'rational 'complex
              (lambda (z) (raise (raise z))))

(put-coercion 'scheme-number 'complex
              (lambda (z) (raise z)))

テスト。

racket@> (add (make-complex-from-real-imag 1 0)
              (add (make-scheme-number 2)
                   (add (make-rational 3 1) (make-integer 4))))
'(complex rectangular 10 . 0)

racket@> (add (make-integer 1)
              (add (make-rational 2 1)
                   (add (make-scheme-number 3) (make-complex-from-real-imag 4 0))))
'(complex rectangular 10 . 0)

異なる型同士の計算ができた。

問題 2.85

次は型下げについて考える。

例えば複素数であっても、'(complex rectangular 10 . 0) のように、実数部が整数で虚数部が0の場合は、単純に整数 '(integer . 10) を返すようにしたい。

project手続き

まず、1段階の型下げを行う手続きprojectを実装する。

rationalパッケージに以下を追加。

(put 'project '(rational)
     (lambda (z) (make-integer (/ (number z) (denom z)))))

scheme-numberパッケージに以下を追加。

(put 'project '(scheme-number)
     (lambda (z) (make-rational z 1)))

complexパッケージに以下を追加。

(put 'project '(complex)
     (lambda (z) (make-scheme-number (real-part z))))

project汎用手続きを定義。

(define (project z)
  (let ((proc (get 'project (list (type-tag z)))))
    (if proc
        (proc (contents z))
        false)))

テスト。

racket@> (project (make-complex-from-real-imag 3.5 1.5))
'(scheme-number . 3.5)

racket@> (project (project (make-complex-from-real-imag 3.5 1.5)))
'(rational 7.0 . 2.0)

racket@> (project (project (project (make-complex-from-real-imag 3.5 1.5))))
'(integer . 3.0)

racket@> (project (project (project (project (make-complex-from-real-imag 3.5 1.5)))))
#f

lower手続き

情報が落ちないところまで、型下げを行う手続き。

テキストではdropという名前だが、Racketにはすでに存在している手続きだったので、名前をlowerに変更。

(define (lower z)
  (if (not (pair? z))
      z
      (let ((p (project z)))
        (if p
            (if (equ? z (raise p))
                (lower p)
                z)
            z))))

テスト。

racket@> (lower (make-complex-from-real-imag 3.5 1))
'(complex rectangular 3.5 . 1)

racket@> (lower (make-complex-from-real-imag 3.5 0))
'(rational 7.0 . 2.0)

racket@> (lower (make-complex-from-real-imag 3 0))
'(integer . 3)

apply-genericでの型下げ

apply-genericへlowerを組み込み、できるだけ型を下げたデータを返すようにする。

(define (apply-generic op . args)
  (let* ((type-tags (map type-tag args))
         (proc (get op type-tags)))
    (if proc
        (lower (apply proc (map contents args))) ;; modified for ex 2.85
        (if (= (length args) 2)
            (let ((type1 (car type-tags))
                  (type2 (cadr type-tags))
                  (a1 (car args))
                  (a2 (cadr args)))
              (if (eq? type1 type2)                   ;; 
                  (error "No method for these types"  ;; added for ex 2.83
                         (list op type-tags))         ;;
                  (let ((t1->t2 (get-coercion type1 type2))
                        (t2->t1 (get-coercion type2 type1)))
                    (cond ((eq? type1 (higher-type? type1 type2)) ;;
                           (apply-generic op a1 (t2->t1 a2)))     ;; modified for ex 2.84
                          ((eq? type2 (higher-type? type1 type2)) ;;
                           (apply-generic op (t1->t2 a1) a2))     ;;
                          (else
                           (error "No method for these types"
                                  (list op type-tags)))))))
            (error "No method for these types"
                   (list op type-tags))))))

テスト。

racket@> (add (make-complex-from-real-imag 1 0)
              (add (make-scheme-number 2)
                   (add (make-rational 3 1) (make-integer 4))))
'(integer . 10)

complex型ではなくinteger型へ型下げが行われた。

問題 2.86

これまでの実装では、以下のような演算は上手く行くが、

racket@> (magnitude-part (make-complex-from-real-imag 4 3))
5
racket@> (real-part (make-complex-from-mag-ang 5 0))
5

以下のような演算は上手く行かない。

racket@> (magnitude-part (make-complex-from-real-imag (make-integer 4) (make-integer 3)))
*: contract violation
  expected: number?
  given: '(integer . 4)
  argument position: 1st
  other arguments...:
   '(integer . 4)
  context...:
   /Users/uents/work/sicp/ch2.5.2.scm:134:2: magnitude-part
   /Users/uents/work/sicp/ch2.5.2.scm:657:0: apply-generic
   /Users/uents/work/sicp/ch2.5.2.scm:657:0: apply-generic
   /Applications/Racket6.0.1/collects/racket/private/misc.rkt:87:7
   
racket@> (real-part (make-complex-from-mag-ang (make-integer 5) (make-integer 0)))
cos: contract violation
  expected: number?
  given: '(integer . 0)
  context...:
   /Users/uents/work/sicp/ch2.5.2.scm:162:2: real-part
   /Users/uents/work/sicp/ch2.5.2.scm:657:0: apply-generic
   /Users/uents/work/sicp/ch2.5.2.scm:657:0: apply-generic
   /Applications/Racket6.0.1/collects/racket/private/misc.rkt:87:7

上記の演算が上手く行くように、complex型のコンストラクタを修正する。

まずは、二乗、平方根、sin、cos、atan手続きを型タグデータに対応させる。

integerパッケージに以下を追加。

  (put 'square '(integer)
       (lambda (z) (tag (* z z))))
  (put 'square-root '(integer)
       (lambda (z) (tag (sqrt z))))
  (put 'sine '(integer)
       (lambda (z) (tag (sin z))))
  (put 'cosine '(integer)
       (lambda (z) (tag (cos z))))
  (put 'atang '(integer integer)
       (lambda (x y) (tag (atan x y))))

rationalパッケージに以下を追加。

  (put 'square '(rational)
       (lambda (z)
         (let ((n (numer z))
               (d (denom z)))
           (tag (make-rat (* n n)
                          (* d d))))))
  (put 'square-root '(rational)
       (lambda (z) (tag (make-rat (sqrt (numer z))
                                  (sqrt (denom z))))))
  (put 'sine '(rational)
       (lambda (z) (tag (make-rat (sin (/ (numer z) (denom z)))
                                  1))))
  (put 'cosine '(rational)
       (lambda (z) (tag (make-rat (cos (/ (numer z) (denom z)))
                                  1))))
  (put 'atang '(rational rational)
       (lambda (x y) (tag (make-rat (atan (/ (numer x) (denom x))
                                          (/ (numer y) (denom y)))
                                    1))))

scheme-numberパッケージに以下を追加。

  (put 'square '(scheme-number)
       (lambda (z) (tag (* z z))))
  (put 'square-root '(scheme-number)
       (lambda (z) (tag (sqrt z))))
  (put 'sine '(scheme-number)
       (lambda (z) (tag (sin z))))
  (put 'cosine '(scheme-number)
       (lambda (z) (tag (cos z))))
  (put 'atang '(scheme-number scheme-number)
       (lambda (x y) (tag (atan x y))))

汎用演算手続きを定義。

(define (square z) (apply-generic 'square z))
(define (square-root z) (apply-generic 'square-root z))
(define (sine z) (apply-generic 'sine z))
(define (cosine z) (apply-generic 'cosine z))
(define (atang x y) (apply-generic 'atang  x y))

rectangularパッケージのコンストラクタ、アクセサの一部を上記の手続きを使うように修正。

  (define (magnitude-part z)
    (square-root (add (square (real-part z))
                      (square (imag-part z)))))
  (define (angle-part z)
    (atang (imag-part z) (real-part z)))
  (define (make-from-mag-ang r a) 
    (cons (mul r (cosine a)) (mul r (sine a))))

polarパッケージのコンストラクタ、アクセサの一部をを上記の手続きを使うように修正。

  (define (real-part z)
    (mul (magnitude-part z) (cosine (angle-part z))))
  (define (imag-part z)
    (mul (magnitude-part z) (sine (angle-part z))))
  (define (make-from-real-imag x y) 
    (cons (square-root (add (square x) (square y)))
          (atang y x)))

もう１点。magnitude-part、angle-partが型タグデータを扱えるようになったため、 complexパッケージのequ?手続き内部の比較も、=からequ?に修正。

  (put 'equ? '(complex complex)
       (lambda (x y) (and (equ? (magnitude-part x) (magnitude-part y))
                          (equ? (angle-part x) (angle-part y)))))

テスト。とりあえず動いた。

racket@> (magnitude-part (make-complex-from-real-imag (make-integer 4) (make-integer 3)))
'(integer . 5)

racket@> (real-part (make-complex-from-mag-ang (make-integer 5) (make-integer 0)))
'(integer . 5)

equ?手続きの修正は最初は気づかなかったんだけど、この問題の修正の影響で、問題 2.85 の異なる型同士の演算がデグレしていたので修正。

問題 2.76 では気づかなかったけど、型の追加や修正に対して、それに依存する型がある場合は、依存する型も当然修正しないといけないことがある。当たり前といえば当たり前だけど。

やはりデータ主導といえども銀の弾丸ではないし、この規模になるとユニットテストも必要かな。

@uents blog

Code wins arguments.

SICP 読書ノート#24 - 2.5.2 異なる型のデータ統合 (pp.113-118)

異なる型のデータ統合

型変換テーブル

apply-generic

整数パッケージの追加

問題 2.81

a.

b.

c.

問題 2.82

問題 2.83

問題 2.84

問題 2.85

project手続き

lower手続き

apply-genericでの型下げ

問題 2.86