SICP問題2.82 - tmurataの日記

ふと気づくと8/13以来だ。ｗ
しばらく放置してたら、内容を忘れたのも加わって正直さっぱり分からん。

(define (apply-generic op . args)
    (let ((type-tags (map type-tag args)))
      ;; 変数 x を型 type に強制変換する。変数 x の型が type と同じ場合は
      ;; 変換しないで x を戻す。 (and corce (corce x)) の部分は
      ;; 型変換用の関数がある場合は変換し、ない場合は false を返すということ
      (define (do-coerce x type)
	(if (eq? (type-tag x) type)
	    x
	    (let ((coerce (get-coercion (type-tag x) type)))
	      (and coerce
		   (coerce x)))))
      ;; 変換結果のリストのfalse(変換できなかった引数)があるかをチェックする
      (define (all-coerced? coerceds) ;; 変換後リストに#fが含まれるかを調べる
	(if (pair? coerceds)
	    (if (car coerceds) 
		(all-coerced? (cdr coerceds))
		#f)
	    #t))
      ;; 引数の型のリストの一番目から順番に、全ての引数がその型に強制変換できるか
      ;; を見ていく。結果は変換済のリストに格納される。
      ;; 変換された結果にfalseが含まれていなければ、変換できたことになる。
      ;; 変換できなかった場合はリストの次の型に対して同じ処理を行う。
      ;; 変換できた場合は、強制変換された型について対象の演算があるかを見る。
      ;; 演算がなかった場合はリストの次の型について同じ処理をしていく。
      ;; 演算と強制変換後の引数のリストを返す
      (define (find-proc-coerced types)
	(if (null? types)
	    #f
	    (let ((target-type (car types))
		  (rest-types (cdr types)))
	      (let ((coerceds (map (lambda (x) (do-coerce x target-type)) args)))
		(if (all-coerced? coerceds)
		    (let ((proc (get op (map type-tag coerceds))))
		      (if proc
			  (cons proc coerceds)
			  (find-proc-coerced rest-types)))
		    (find-proc-coerced rest-types))))))
      ;; 本体
      (let ((proc (get op type-tags)))
	;; 変換していない引数で演算が取得できれば 、演算を行う。
	;; 演算が取得できない場合は強制変換を行う
	(if proc
	    (apply proc (map contents args))
	    ;; 強制変換後の演算と引数のリストが返ってきた場合は演算を行い
	    ;; 返ってこなかった場合はエラーとする
	    (let ((proc-coerced (find-proc-coerced type-tags)))
	      (if proc-coerced 
		  (apply (car proc-coerced) (map contents (cdr proc-coerced)))
		  (error "No method for these types -- APPLY-GENERIC"
			 (list op type-tags))))))
      ) ;; let type-tags ...
    ) ;; apply-generc

テスト

(define z (make-complex-from-real-imag 1 2))
; z
z
; (complex rectangular 1 . 2)
; 三引数のaddの登録
(put 'add '(scheme-number scheme-number scheme-number)
     (lambda (x y z) (+ x y z)))
(put 'add '(complex complex complex)
     (lambda (x y z) (add (add (cons 'complex x)
                               (cons 'complex y))
                          (cons 'complex z))))
(define (add . args) (apply apply-generic (cons 'add args)))
; 実行
(add z  2 2)
; (complex rectangular 5 . 2)
(add 2 z 2)
; (complex rectangular 5 . 2)
(add 2 2 z)
; (complex rectangular 5 . 2)
(add  z z 2)
; (complex rectangular 4 . 4)
(add z z)
; (complex rectangular 2 . 4)
z
; (complex rectangular 1 . 2)
(add z z z)
; (complex rectangular 3 . 6)

この戦略、(そして上の二引数版が)十分に一般的でない状況の例。

(define r (make-rational 1 3))
; r
r
; (rational 1 . 3)
(add 2 r 2)
; *** ERROR: No method for these types -- APPLY-GENERIC (add (scheme-number rational scheme-number))
; Stack Trace:
; _______________________________________

上の結果のように強制変換できても演算が用意されていないものに関してはエラーとなってしまう。
組合せとして、違う型同士の演算にしか関数が定義されていない場合、この戦略では必ず全ての型が同じに変換され、同関数を適用できないため、一般的な戦略とはいえない。