問題2-87

型を単純化するdrop手続きを定義します。この問題に関しては、結構手間取った割には、まだまだ完全な解答を導きだせておらず、またこれまでのequ?やraiseの実装方法に重大な誤りがあったことを発見しました。
まずは、dropのインターフェイスを定義します。

(define (drop x)
  (cond ((eq? 'scheme-number (type-tag x)) x)
        ((equ? x
               (raise (project x)))
         (drop (project x)))
        (else x)))

この中にあるprojectという手続きは、型を強引に1レベル単純化する手続きです。(apply-genericを最初は使っていましたが、これだとdropを評価するときに上手く動きません。そもそも、apply-genericは四則演算のような手続きのみに使うべきだったということに気づきました。そのため、equ?/=zero?/raiseなども、apply-genericを使うべきではないとも思いました。)

(define (project x) ((get 'project (type-tag x)) (contents x)))

(define (install-complex-package)
  ;;...other code
  (put 'project 'complex
       (lambda (z1) (make-scheme-real (real-part z1))))
  ;;...other code
  'done)

(define (install-scheme-real-package) 
  ;;...other code
  (put 'project 'scheme-real
       (lambda (x) (make-rational (round (* 1000 x)) 1000)))
  ;;...other code
  'done)

(define (install-rational-package)
  ;;...other code
  (put 'project 'rational
       (lambda (x) (make-scheme-number (numer x))))
  ;;...other code
  'done)

(define (install-scheme-number-package)
  ;;...other code
  (put 'project 'scheme-number
       (lambda (x) (make-scheme-number x)))
  ;;...other code
  'done)

dropに渡された値をprojectして、それをraiseして、元の値と一致していたら(equ?が真ならば)、単純化された値であるprojectを返します。ここでは、もっと単純化できるかもしれないので、dropを再帰的に呼び出しています。
このdrop手続きをapply-genericに組み込みます。最終的な結果の部分に、dropを付け加えるだけでよさそうです。

(define (apply-generic op . args)
  (let ((type-tags (map type-tag args)))
    (let ((proc (get op type-tags)))
      (if proc
          (drop (apply proc (map contents args)))
          (if (= (length args) 2)
              (let ((a1 (car args))
                    (a2 (cadr args)))
                (let ((a1-lv (tree-level a1))
                      (a2-lv (tree-level a2)))
                  (cond ((= a1-lv a2-lv)
                         (error "No method for these same types"
                                (list op type-tags)))                              
                        ((< a1-lv a2-lv)
                         (apply-generic op (raise a1) a2))
                        ((> a1-lv a2-lv)
                         (apply-generic op a1 (raise a2)))
                        (else
                         (error "No method for these types"
                                (list op type-tags))))))
              (error "No method for these types"
                     (list op type-tags)))))))

(add (make-rational 3 5)
     (make-rational 7 5))  ;=>(scheme-number . 2)

(add 3.4 4.6)  ;=>(scheme-number . 8.0)
(add 3.3 3.3)  ;=>(rational 33.0 . 5.0)

(add (make-complex-from-real-imag 3 -1)
     (make-complex-from-real-imag 4 1))  ;=>(scheme-number . 7)

まだまだ改善の余地はありそうですが、時間がかかりすぎてしまったので、この問題はここまでとします。
次の問題2-86は、複素数パッケージの拡張問題で、整数パッケージや有理数パッケージに三角関数に関する計算を組み込めばよさそうですが、実装したとしても、今の自分ではテストのしようがないので、数学の基礎を学び直してから取り組んでみたいと思っています。