問題2-83

｢整数->有理数->実数->複素数｣というように、各型を拡大解釈するための順序が存在する場合、型のレベルを一段上げるための手続きraiseを定義してやれば、強制型変換ロジックを汎用化することができます。この中で、｢実数｣に関しては、これまで扱ってこなかった要素なので、'scheme-realというタグによってコントロールするパッケージを新設しました。ロジックは、scheme-numberパッケージとほぼ同じです。これによって、attach-tag関連の定義を見直しました。(整数をそのまま扱えるように修正した自分の方法が間違っていたことにも気づきました)

(define (attach-tag type-tag contents) 
  (cons type-tag contents))

(define (type-tag datum)
  (cond ((pair? datum) (car datum))
        ((integer? datum) 'scheme-number)
        ((number? datum) 'scheme-real)
        (else (error "Bad tagged datum" datum))))

(define (contents datum)
  (cond ((pair? datum) (cdr datum))
        ((integer? datum) datum)
        ((number? datum) datum)
        (else (error "Bad tagged datum" datum))))

(define (install-scheme-real-package) 
  (define (tag x)
    (attach-tag 'scheme-real x))
  (put 'add '(scheme-real scheme-real)
       (lambda (x y) (tag (+ x y))))
  (put 'sub '(scheme-real scheme-real)
       (lambda (x y) (tag (- x y))))
  (put 'mul '(scheme-real scheme-real)
       (lambda (x y) (tag (* x y))))
  (put 'div '(scheme-real scheme-real)
       (lambda (x y) (tag (/ x y))))
  
  (put 'equ? '(scheme-real scheme-real)
       (lambda (x y) (tag (= x y))))
  (put '=zero? '(scheme-real)
       (lambda (x) (tag (= 0 x))))
  
  (put 'make 'scheme-real
       (lambda (x) (tag x)))
  'done)

(define (make-scheme-real n)
  ((get 'make 'scheme-real) n))

(install-scheme-real-package)  ;=>done
(type-tag 3)  ;=>scheme-number
(type-tag 3.3)  ;=>scheme-real

次に、上記オブジェクトツリーの一つ上のレベルへ型を強制変換するロジックを、複素数以外の各パッケージへ追加します。

;(define (raise x) (apply-generic 'raise x))
(define (raise x)
  (cond ((eq? 'complex (type-tag x)) x)
        (else ((get 'raise (type-tag x)) (contents x)))))

(define (install-scheme-number-package) 
  ;;other code
  (put 'raise 'scheme-number
       (lambda (x) (make-rational x 1)))
  ;;other code
  'done)

(define (install-rational-package)
  ;;other code
  (put 'raise 'rational
       (lambda (x) (make-scheme-real (/ (* (numer x) 1.0)
                                        (* (denom x) 1.0)))))
  ;;other code
  'done)

(define (install-scheme-real-package) 
  ;;other code
  (put 'raise 'scheme-real
       (lambda (x) (make-complex-from-real-imag x 0)))
  ;;other code
  'done)

(type-tag 3)  ;=>scheme-number

(raise 3)  ;=>(rational 3 . 1)
(type-tag (raise 3))  ;=>rational

(raise (raise 3))  ;=>(scheme-real . 3.0)
(type-tag (raise (raise 3)))  ;=>scheme-real

(raise (raise (raise 3)))  ;=>(complex rectangular 3.0 . 0)
(type-tag (raise (raise (raise 3))))  ;=>complex

(raise (make-rational 1 3))  ;=>(scheme-real . 0.3333333333333333)

最後のテストでは、1/3を実数化していますが、評価中に丸められてしまうため、実数であることは間違いありませんが、無限循環少数であることを正確には表現できていません。このあたりについては、どのように処理すべきなのか頭を悩ますところです。