(define (can-raise x)
  (if (get 'raise (type-tag x))
      #t
      #f))

(define (equal-level? x y)
  (if (= (type-tag x) (type-tag y))
      #t
      #f))

(define (choose-high-level x y)
  (define (can-raise-to x y)
    (if (can-raise x)
        (let ((x-raised (raise x)))
          (if (= (type-tag x-raised) (type-tag y))
              #t
              (can-raise-to x-raised y)))
        #f))
  (if (can-raise-to x y)
      y
      x))

(define (raise-to x y)
  (if (= (type-tag x) (type-tag y))
      x
      (raise-to (raise x) y)))
 

(define (apply-generic op . args)
  (let ((type-tags (map type-tag args)))
    (let (proc (get op type-tags))
      (if proc
          (apply proc (map (contents args)))
          (if (= (length args 2))
              (let ((a1 (car args))
                    (a2 (cadr args)))
                (if (not (equal-level? a1 a2))
                    (if (= (choose-high-level a1 a2) a1)
                      (apply-generic op a1 (raise-to a2 a1))
                      (apply-generic op (raise-to a1 a2) a2))
                    (error "No method")))
              (error "No method"))))))