SICP 問題 2.85

(define (install-project-packege)
  (define (project x) (apply-generic 'project x))
  (put 'project 'complex (lambda (x)
                           (make-real (real-part x))))
  (put 'project 'real (lambda (x)
                        (let ((rational (inexact->exact x)))
                          (make-rational (numerator rational)
                                         (denominator rational)))))
  (put 'project 'rational (lambda (x)
                            (make-scheme-number (round (/ (numer x)
                                                          (denom x))))))
  'done)

(define (drop x)
  (let ((projected ((get 'project (type-tag x)) x)))
    (let ((raised ((get 'raise (type-tag projected)) projected)))
      (if (equ? x raised)
        (drop projected)
        x))))

(define (apply-generic op . args)
  (let ((type-tags (map type-tag args))
        (tower '(complex real rational scheme-number)))
    (define (same-type? a b)
      (eq? (type-tag a) (type-tag b)))
    (define (type-< a b)
        (cond ((same-type? a b) false)
              ((eq? (type-tag a) (car tower)) true)
              ((eq? (type-tag b) (car tower)) false)
              (else (type-< ((get 'raise (type-tag a)) a)
                            ((get 'raise (type-tag b)) b)))))
    (define (highest-type lst)
      (let iter ((result (car lst))
                 (rest (cdr lst)))
        (cond ((null? rest) result)
              ((type-< result (car rest))
               (iter (car rest) (cdr rest)))
              (else
               (iter result (cdr rest))))))
    (define (same-highest-type high lst)
      (map (lambda (x) (let iter ((target x))
                         (if (eq? high target)
                             target
                             (iter ((get 'raise (type-tag target))
                                    target)))))
           lst))
    (let ((proc (get op types)))
      (if proc
          (drop (apply proc (map contents args))) ;;drop
          (let ((new-args (same-highest-type (highest-type args)
                                             args)))
            (let ((proc (get op (type-tag (car new-args)))))
              (if proc
                  (dorp (apply proc (map contents new-args))) ;;drop
                  (error "Nomethod for these types"
                         (list op type-tags)))))))))