SICP 読み (68) 2.5.2 異る型のデータの統合

scheme SICP

今更ながら、検討メモはあまり具体的でない。検討なソレも以下に。
まず、apply-generic をどうすりゃ良いやら。

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

てっぺんで args を変換した方が良いのかな。

(define (apply-generic op . args)
 (let ((args (coercion args)))
   (let ((type-tags (map type-tag args)))
     (let ((proc (get op type-tags)))
;; -- 以下略 --

coercion 手続きは apply-generic の中で定義か。そうすると試験が微妙だな。トップレベルで定義した方が確認しやすそげ。どっちが良いのかなぁ。
そういった意味では tower of types なソレを先に定義する必要があります。手続きとしては

  • (define tower-of-types (make-table))
  • (define get-raise (tower-of-types 'lookup-proc))
  • (define put-raise (tower-of-types 'insert-proc))

なのかな。前のエントリ的な登録の具体例を挙げるとすると

(put-raise 'integer 'upper 'rational)
(put-raise 'rational 'lower 'integer)

なんかこれって違うデータ構造で実装できそげな気もするんですが ...

tower of types 関連の試験は一つに纏めます。直前エントリにある_(get type 'upper) が失敗_は '() を返却する事にする。(というか例えば complex な upper には '() を登録する)

 ("_tower of types_ test"
 (setup (lambda ()
          (install-integer-package)
          (install-rational-package)
          (install-real-package)
          (install-complex-package)
          (install-rectangular-package)
          (install-polar-package)))
 ("get 'lower test (complex)"
  (assert-equal 'real (get-raise 'complex 'lower))
  (assert-equal 'real
                (get-raise (type-tag
                            (make-complex-from-real-imag 1 1))
                           'lower))
  )
 ("get 'lower test (real)"
  (assert-equal 'rational (get-raise 'real 'lower))
  (assert-equal 'rational
                (get-raise (type-tag (make-real 5))
                           'lower))
  )
 ("get 'lower test (rational)"
  (assert-equal 'integer (get-raise 'rational 'lower))
  (assert-equal 'integer
                (get-raise (type-tag (make-rational 1 1))
                           'lower))
  )
 ("get 'lower test (integer)"
  (assert-equal '() (get-raise 'integer 'lower))
  (assert-equal '()
                (get-raise (type-tag (make-integer 1))
                           'lower))
  )

 ("get 'upper test (complex)"
  (assert-equal '() (get-raise 'complex 'upper))
  (assert-equal '()
                (get-raise (type-tag
                            (make-complex-from-real-imag 1 1))
                           'upper))
  )
 ("get 'upper test (real)"
  (assert-equal 'complex (get-raise 'real 'upper))
  (assert-equal 'complex
                (get-raise (type-tag (make-real 5))
                           'upper))
  )
 ("get 'upper test (rational)"
  (assert-equal 'real (get-raise 'rational 'upper))
  (assert-equal 'real
                (get-raise (type-tag (make-rational 1 1))
                           'upper))
  )
 ("get 'upper test (integer)"
  (assert-equal 'rational (get-raise 'integer 'upper))
  (assert-equal 'rational
                (get-raise (type-tag (make-integer 1))
                           'upper))
  )
 )

で、とりあえずテーブル実装して試験してみましたがパス。


次は coercion 手続きの実装ですが、ざっくりで以下なカンジ??
# って tower of types を木構造にすりゃ簡単なコトに今気がついた。
# とりあえず、検討したソレで実装して別途試す。

(define (coercion args)
 ;; まず変換する型を判断

 ;; 型変換して全体を返却
 )

変換する型を判断するのは

(define (which-type? args)
 (define (higher? obj1 obj2)
   (let ((t1-upper (get-raise (type-tag obj1) 'upper))
         (t1-lower (get-raise (type-tag obj1) 'lower))
         (t2-type (type-tag obj2)))
     (if (null? t1-lower-type)
         obj2
         (let g ((t1-upper t1upper))
           (let ((t1-upper-type (type-tag t1-upper)))
             (cond ((null? t1-upper) obj1)
                   ((eq? t1-upper-type t2-type) obj2)
                   (else
                    (g (get-raise (type-tag t1-upper) 'upper)))))))))

 (let f ((t1 (car args))     ;; 1st
         (t2 (cadr args))    ;; 2nd
         (t3 (cddr args)))   ;; other
   (let ((higher-obj (higher? t1 t2)))
     (if (null? t3)
         (type-tag higher-obj)
         (f heigher-obj (car t3) (cdr t3))))))

って長い。
けど、ここまで書けてりゃ coercion も書けるか。

(define (coercion args)
 (let ((coercion-type (which-type? args)))
   (let f ((l '()) (remainder args))
     (if (null? remainder)
         l
         (let g (obj (raise (car remainder)))
           (cond ((eq? coercion-type (type-tag obj))
                  (f (append l (list obj)) (cdr remainder)))
                 (else
                  (g (raise obj)))))))))

あ、同じだったトキのソレが考慮外だ。(とほほ
マトメて以下に。

(define (which-type? args)
 (define (higher? obj1 obj2)
   (define (higher-iter? obj1 obj2)
     (let ((t1-upper (get-raise (type-tag obj1) 'upper))
           (t1-lower (get-raise (type-tag obj1) 'lower))
           (t2-type (type-tag obj2)))
       (if (null? t1-lower)
           obj2
           (let g ((t1-upper t1-upper))
             (let ((t1-upper-type (type-tag t1-upper)))
               (cond ((null? t1-upper) obj1)
                     ((eq? t1-upper-type t2-type) obj2)
                     (else
                      (g (get-raise (type-tag t1-upper) 'upper)))))))))
   (if (eq? (type-tag obj1) (type-tag obj2))
       obj1
       (higher-iter? obj1 obj2)))

 (let f ((t1 (car args))     ;; 1st
         (t2 (cadr args))    ;; 2nd
         (t3 (cddr args)))   ;; other
   (let ((higher-obj (higher? t1 t2)))
     (if (null? t3)
         (type-tag higher-obj)
         (f heigher-obj (car t3) (cdr t3))))))

(define (coercion args)
 (let ((coercion-type (which-type? args)))
   (let f ((l '()) (remainder args))
     (if (null? remainder)
         l
         (let g (obj (raise (car remainder)))
           (cond ((eq? coercion-type (type-tag (car remainder)))
                  (f (append l (list (car remainder))) (cdr remainder)))
                 ((eq? coercion-type (type-tag obj))
                  (f (append l (list obj)) (cdr remainder)))
                 (else
                  (g (raise obj)))))))))

なんか微妙 ... # ってーかキタネぇ

あまり上記手続きにチェックは入れず、試験を書いてみる。(順番逆だし
確認するのは

  • which-type?
    • 引数二つ
      • 同じ場合
      • complex とそれ以下を比較 (前後も違えてみる??
      • real とそれ以下を比較
      • rational とそれ以下を比較
    • 引数三つ
      • 同じ場合
      • 異なる場合 (全部のケースを試験?? <- してません
  • coercion
    • 引数二つ
      • 同じ場合
      • complex とそれ以下 (値も確認
      • real とそれ以下 (値も確認
      • rational とそれ以下 (値も確認
    • 引数三つ
      • 同じ場合
      • 異なる場合 (全部のケース?? <- してない

実装が微妙なので面倒ですがきちんと試験を。(って本当かなぁ
試験しながら実装を微妙に修正。ちなみに試験をサラすのは略。長すぎるんで ...
実装は以下。

(define (which-type? args)
 (define (higher? obj1 obj2)
   (define (higher-iter? obj1 obj2)
     (let ((t1-upper (get-raise (type-tag obj1) 'upper))
           (t1-lower (get-raise (type-tag obj1) 'lower))
           (t2-type (type-tag obj2)))
       (if (null? t1-lower)
           obj2
           (let g ((t1-upper t1-upper))
             (if (null? t1-upper)
                 obj1
                 (if (eq? t1-upper t2-type)
                     obj2
                     (g (get-raise t1-upper 'upper))))))))

   (if (eq? (type-tag obj1) (type-tag obj2))
       obj1
       (higher-iter? obj1 obj2)))

 (let f ((t1 (car args))     ;; 1st
         (t2 (cadr args))    ;; 2nd
         (t3 (cddr args)))   ;; other
   (let ((higher-obj (higher? t1 t2)))
     (if (null? t3)
         (type-tag higher-obj)
         (f higher-obj (car t3) (cdr t3))))))

(define (coercion args)
 (let ((coercion-type (which-type? args)))
   (let f ((l '()) (remainder args))
     (if (null? remainder)
         l
         (if (eq? coercion-type (type-tag (car remainder)))
             (f (append l (list (car remainder))) (cdr remainder))
             (let g ((obj (raise (car remainder))))
               (cond ((eq? coercion-type (type-tag obj))
                      (f (append l (list obj)) (cdr remainder)))
                     (else
                      (g (raise obj))))))))))

絶対リファクタリング必要だし。

それは置いとくとして、とりあえず apply-generic に組み込んで試験を。実装は上記の通りなので、試験を先に書く。例えば以下。

 ("test of calc with coercion"
  (setup (lambda ()
           (install-integer-package)
           (install-rational-package)
           (install-real-package)
           (install-complex-package)
           (install-rectangular-package)
           (install-polar-package)))
  ("integer - real"
   (let ((result (add (make-integer 1) (make-real 3))))
     (assert-equal 'real (type-tag result)))
   )
  )


デグレード ...

最初に書いた apply-generic では NG な模様。(困
で、滅多矢鱈にパニクった挙句、coercion と apply-generic を以下のようにしたら通った。何故か、をきちんと整理する必要があるな。まだワケワカです。パニック状態。

(define (apply-generic op . args)
 (let ((args (coercion 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 (coercion args)
 (if (= 1 (length args))
     args
     (let ((coercion-type (which-type? args)))
       (let f ((l '()) (remainder args))
         (if (null? remainder)
             l
             (if (eq? coercion-type (type-tag (car remainder)))
                 (f (append l (list (car remainder))) (cdr remainder))
                 (let g ((obj (raise (car remainder))))
                   (cond ((eq? coercion-type (type-tag obj))
                          (f (append l (list obj)) (cdr remainder)))
                         (else
                          (g (raise obj)))))))))))

うーん....

忘れない内に残しておくとデグレ版の apply-generic と coercion は以下。

(define (coercion args)
 (let ((coercion-type (which-type? args)))
   (let f ((l '()) (remainder args))
     (if (null? remainder)
         l
         (if (eq? coercion-type (type-tag (car remainder)))
             (f (append l (list (car remainder))) (cdr remainder))
             (let g ((obj (raise (car remainder))))
               (cond ((eq? coercion-type (type-tag obj))
                      (f (append l (list obj)) (cdr remainder)))
                     (else
                      (g (raise obj))))))))))

(define (apply-generic op . args)
 (define (wrapped-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))))))
 (if (= 1 (length args))
     (wrapped-apply-generic op args)
     (let ((cargs (coercion args)))
       (wrapped-apply-generic op cargs))))

何が違うかとゆーと、

  • coercion は (length args) が 1 の場合の処理がナシ
  • apply-generic は wrap な処理がはいっている

やってるコトはそう違わん気がするんだけどトレイスした方が良いというかきちんと試験に通して結果を見てみた方が良さげ。む、wrapper の呼び方が微妙なの??


... なんかソレっぽいなぁ。(とほほほ
こういったケイスで wrapper 使うトキってどうすりゃ良いのだろうか。こんなカンジ? (ちなみに coercion は元に戻してます)

(define (apply-generic op . args)
 (define (wrapped-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))))))
 (if (= 1 (length args))
     (wrapped-apply-generic op args)
     (let ((cargs (coercion args)))
       (wrapped-apply-generic op cargs))))

試験したら通たよ。とほほほ。今日は調子悪いです。

もう少し

試験もざくっと書いて一応パス。ただし、非常に微妙な以下の手続きについて再検討を。

(define (which-type? args)
 (define (higher? obj1 obj2)
   (define (higher-iter? obj1 obj2)
     (let ((t1-upper (get-raise (type-tag obj1) 'upper))
           (t1-lower (get-raise (type-tag obj1) 'lower))
           (t2-type (type-tag obj2)))
       (if (null? t1-lower)
           obj2
           (let g ((t1-upper t1-upper))
             (if (null? t1-upper)
                 obj1
                 (if (eq? t1-upper t2-type)
                     obj2
                     (g (get-raise t1-upper 'upper))))))))

   (if (eq? (type-tag obj1) (type-tag obj2))
       obj1
       (higher-iter? obj1 obj2)))

 (let f ((t1 (car args))     ;; 1st
         (t2 (cadr args))    ;; 2nd
         (t3 (cddr args)))   ;; other
   (let ((higher-obj (higher? t1 t2)))
     (if (null? t3)
         (type-tag higher-obj)
         (f higher-obj (car t3) (cdr t3))))))

(define (coercion args)
 (let ((coercion-type (which-type? args)))
   (let f ((l '()) (remainder args))
     (if (null? remainder)
         l
         (if (eq? coercion-type (type-tag (car remainder)))
             (f (append l (list (car remainder))) (cdr remainder))
             (let g ((obj (raise (car remainder))))
               (cond ((eq? coercion-type (type-tag obj))
                      (f (append l (list obj)) (cdr remainder)))
                     (else
                      (g (raise obj))))))))))

(define (apply-generic op . args)
 (define (wrapped-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))))))

 (if (= 1 (length args))
     (wrapped-apply-generic op args)
     (let ((cargs (coercion args)))
       (wrapped-apply-generic op cargs))))
  • とりあえず apply-generic で wrap なソレは却下。
  • which の入れ子になった define を綺麗に整理。

を盛り込んだのが以下。まだ微妙。

(define (which-type? args)
 (define (higher? obj1 obj2)
   (let ((t1-type (type-tag obj1))
         (t2-type (type-tag obj2)))
     (if (eq? t1-type t2-type)
         obj1
         (let ((t1-upper (get-raise t1-type 'upper))
               (t1-lower (get-raise t1-type 'lower)))
           (if (null? t1-lower)
               obj2
               (let g ((t1-upper t1-upper))
                 (if (null? t1-upper)
                     obj1
                     (if (eq? t1-upper t2-type)
                         obj2
                         (g (get-raise t1-upper 'upper))))))))))
 (let f ((t1 (car args))     ;; 1st
         (t2 (cadr args))    ;; 2nd
         (t3 (cddr args)))   ;; other
   (let ((higher-obj (higher? t1 t2)))
     (if (null? t3)
         (type-tag higher-obj)
         (f higher-obj (car t3) (cdr t3))))))

(define (coercion args)
 (if (= 1 (length args))
     args
     (let ((coercion-type (which-type? args)))
       (let f ((l '()) (remainder args))
         (if (null? remainder)
             l
             (if (eq? coercion-type (type-tag (car remainder)))
                 (f (append l (list (car remainder))) (cdr remainder))
                 (let g ((obj (raise (car remainder))))
                   (cond ((eq? coercion-type (type-tag obj))
                          (f (append l (list obj)) (cdr remainder)))
                         (else
                          (g (raise obj)))))))))))

(define (apply-generic op . args)
 (let ((args (coercion 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)))))))

なんつーか動いてるんだけどグダグダ。

追記

higher? 手続きのケツにある if のネストは cond の方が良さげ。