Serendip

Web Studio

問題2.85

オブジェクトを塔に沿って下へ『押す』汎用演算 project の定義。

(define (install-project-package)
  (define (complex->real x)
    (make-real (real-part x)))
  (define (real->rational x)
    (make-rational (x->integer x) 1))
  (define (rational->integer x)
    (let ((n (car x))
          (d (cdr x)))
         (make-integer (round (/ n d)))))
  (put 'project 'complex complex->real)
  (put 'project 'real real->rational)
  (put 'project 'rational rational->integer)
  'done)

(install-project-package)

(define (project x)
  (let ((proc (get 'project (type-tag x))))
       (if proc
           (proc (contents x))
           #f)))

数を project 手続きで1段低い型に押し下げた結果を raise した型と元の数の型とを比較して、同じであれば型を下げる手続き drop。

(define (drop x)
  (if (pair? x)
      (let ((projected (project x)))
           (if projected
               (if (equ? (raise projected) x)
                   (drop projected)
                   x)
               x))
      x))

drop 手続きを使って結果の型を可能な限り引き下げる apply-generic 手続き。

(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))) ;; drop
                (if (= (length args) 2)
                    (let ((type1 (car type-tags))
                          (type2 (cadr type-tags)))
                         (if (eq? type1 type2)
                             (error "E1. No method for these types" (list op type-tags))
                             (let ((coerced-args (coerce-higher-type args)))
                                  (let ((proc (get op (map type-tag coerced-args))))
                                       (if proc
                                           (drop (apply proc (map contents coerced-args))) ;; drop
                                           (error "E2.No method for these types" (list op type-tags)))))))
                    (error "E3. No method for these types" (list op type-tags)))))))

実行結果

(define int (make-integer 2))
(define rat (make-rational 2 4))
(define rel (make-real 3.0))
(define cpx (make-complex-from-real-imag 2 0))
(drop int)
gosh> (integer . 2)
(drop rat)
gosh> (rational 1 . 2)
(drop rel)
gosh> (integer . 3)
(drop cpx)
gosh> (integer . 2)
(add int int)
gosh> (integer . 4)
(add int rel)
gosh> (integer . 5)
(add int cpx)
gosh> (integer . 4)
(add rat rel)
gosh> (real . 3.5)
(add cpx rel)
gosh> (integer . 5)

計算機プログラムの構造と解釈

posted with amazlet at 08.11.07

ジェラルド・ジェイ サスマン ジュリー サスマン ハロルド エイブルソン
ピアソンエデュケーション
売り上げランキング: 6542

Amazon.co.jp で詳細を見る