src/sicp/ex2_84.rkt

   1 #lang racket
   2
   3 (define (type-height type)
   4   (cond
   5     ((eq? type 'integer) 0)
   6     ((eq? type 'rational) 1)
   7     ((eq? type 'real) 2)
   8     ((eq? type 'complex) 3)))
   9
  10 (define (compose f g)
  11   (lambda (x) (f (g x))))
  12
  13 (define (identity x) (lambda (x) x))
  14
  15 (define (raise-to type1 type2)
  16   (if (eq? type1 type2)
  17       identity
  18       (let ((t1->upper (get 'raise (list type1))))
  19         (compose t1->upper (raise-to t1->upper type2)))))
  20
  21 (define (apply-generic op . args)
  22   (let ((type-tags (map type-tag args)))
  23     (let ((proc (get op type-tags)))
  24       (if proc
  25           (apply proc (map contents args))
  26           (if (= (length args) 2)
  27               (let ((type1 (car type-tags))
  28                     (type2 (cadr type-tags))
  29                     (a1 (car args))
  30                     (a2 (cadr args)))
  31                 (let ((th1 (type-height type1))
  32                       (th2 (type-height type2)))
  33                   (if (> th1 th2)
  34                       (let ((t2->t1 (raise-to type2 type1)))
  35                         (if (t2->t1)
  36                             (apply-generic op a1 (t2->t1 a2))
  37                             (error "cannot coerce type2 to type1")))
  38                       (let ((t1->t2 (raise-to type1 type2)))
  39                         (if (t1->t2)
  40                             (apply-generic op (t1->t2 a1) a2)
  41                             (error "cannot coerce type1 to type2")))))))))))