SICP Exercise 2.84: Successive Raising

Using the raise operation of exercise 2.83, modify the apply-generic procedure so that it coerces its arguments to have the same type by the method of successive raising, as discussed in this section. You will need to devise a way to test which of two types is higher in the tower. Do this in a manner that is "compatible" with the rest of the system and will not lead to problems in adding new levels to the tower.

Let's start with producing "a way to test which of two types is higher in the tower."

In the previous exercise we created an ordered list, tower-of-types, which describes the tower of types we're using. We used this in the implementation of the raise operation to determine the next highest type for the value that was being raised so that we could then retrieve the appropriate coercion procedure and apply it.

We can utilize the tower-of-types here too. We've already generalized apply-generic so that it can cope with variable arguments. So rather than just testing "which of two types is higher in the tower," let's just generalize our test procedure straightaway to cope with variable arguments.

We already know that we can get the types of a list of values by evaluating (map type-tag values). Given such a list of the value's types we can then find the highest type by following these steps:

1. Go through the tower-of-types, in order, from lowest to highest.
2. With each type from the tower, filter out that type from the list of the values' types.
3. If we get to the point where the filtered list of the values' types is empty then the highest type will be the last type that was filtered out from the list.

There are a couple of error cases, of course:

• If the list of the values' types is empty to begin with then there isn't a highest type - there aren't any types! We'll return #f in this case to show that we successfully determined that there is no highest type.
• If we've filtered out the top type from the tower-of-types and the filtered list of the values' types is still not empty then there must be values with types that aren't in the tower-of-types. This is a programming error and so we'll report it as such.

Here's the code:

(define (find-highest-type l)
  (define (filter-type t f)
    (cond ((null? f) '())
          ((eq? (car f) t) (filter-type t (cdr f)))
          (else (cons (car f) (filter-type t (cdr f))))))
  (define (find-highest highest remaining-tower remaining-list)
    (cond ((null? remaining-list) highest)
          ((null? remaining-tower)
           (error "Cannot find highest type from non-tower types -- FIND-HIGHEST-TYPE"
                  remaining-list))
          (else (find-highest (car remaining-tower)
                              (cdr remaining-tower)
                              (filter-type (car remaining-tower) remaining-list)))))
  (find-highest #f tower-of-types l))

...and here it is in action:

> (find-highest-type '(integer real rational real))
real
> (find-highest-type '(rational rational rational))
rational
> (find-highest-type '(complex real rational integer))
complex
> (find-highest-type '())
#f
> (find-highest-type '(integer wibble real wobble complex))
Cannot find highest type from non-tower types -- FIND-HIGHEST-TYPE (wibble wobble)

Assuming we have this wrapped up in a procedure that finds the highest type for a list of arguments, we'll also need a way of applying "the method of successive raising". This is a straightforward recursive procedure that takes a value to be raised and a type to raise it to and keeps raising the value using raise until it is of the requested type. For safety's sake let's also make sure that the type we're raising to is actually a valid type.

Here's the procedure:

(define (raise-to type value)
  (cond ((eq? type (type-tag value)) value)
        ((memq type tower-of-types) (raise-to type (raise value)))
        (else (error "Cannot raise to non-tower type -- RAISE-TO"
                     (list type tower-of-types)))))

Let's see this in action too:

> (raise-to 'real (make-integer 4))
(real . 4)
> (raise-to 'complex (make-rational 3 4))
(complex rectangular 3/4 . 0)
> (raise-to 'real (make-real 3.14159))
(real . 3.14159)
> (raise-to 'wibble (make-integer 42))
Cannot raise to non-tower type -- RAISE-TO (wibble (integer rational real complex))

We can then wrap this in another procedure that will take a type and a list of values and raises all of the values to that type:

(define (raise-all-to type values)
  (if (null? values)
      '()
      (cons (raise-to type (car values)) (raise-all-to type (cdr values)))))

This works like this:

> (raise-all-to 'real (list (make-integer 42) (make-real 3.14159) (make-rational 3 4)))
((real . 42) (real . 3.14159) (real . 3/4))
> (raise-all-to 'complex '())
()
> (raise-all-to 'wibble (list (make-integer 123)))
Cannot raise to non-tower type -- RAISE-TO (wibble (integer rational real complex))

Given all the above, updating apply-generic is straightforward. As before we start by trying to find and apply a procedure that corresponds directly to the raw arguments. Then, if no appropriate procedure can be found, and there are at least two arguments, we simply find the highest type from the arguments' types, raise all of the arguments to this type, get the procedure that corresponds to arguments of this type and then apply it.

To make the code cleaner we'll use let* again:

(define (apply-generic op . args)
  (let* ((type-tags (map type-tag args))
         (proc (get op type-tags)))
    (if proc
        (apply proc (map contents args))
        (if (> (length args) 1)
            (let* ((highest-type (find-highest-type type-tags))
                   (mapped-args (raise-all-to highest-type args))
                   (mapped-types (map type-tag mapped-args))
                   (mapped-proc (get op mapped-types)))
              (if mapped-proc
                  (apply mapped-proc (map contents mapped-args))
                  (error
                   "No method for these types -- APPLY-GENERIC"
                   (list op type-tags))))))))

To test this out let's use the addd procedure we introduced in exercise 2.82. In that exercise we only defined it for the complex package, so let's first add implementations to the other packages:

(define (install-integer-package)
  …
  (put 'addd '(integer integer integer)
       (lambda (x y z) (tag (+ x y z))))
  …
  'done)

(define (install-rational-package)
  ;; internal procedures
  …
  (define (addd x y z) 
       (make-rat (+ (* (numer x) (denom y) (denom z))
                    (* (denom x) (numer y) (denom z))
                    (* (denom x) (denom y) (numer z)))
                 (* (denom x) (denom y) (denom z))))
  …
  ;; interface to rest of the system
  …
  (put 'addd '(rational rational rational)
       (lambda (x y z) (tag (addd x y z))))
  …
  'done)

(define (install-real-package)
  …
  (put 'addd '(real real real)
       (lambda (x y z) (tag (+ x y z))))
  …
  'done)

...and, finally, let's give it a spin:

> (addd (make-real 3.14159) (make-rational 3 4) (make-complex-from-real-imag 1 7))
(complex rectangular 4.89159 . 7)
> (addd (make-rational 1 2) (make-rational 1 4) (make-rational 1 8))
(rational 7 . 8)
> (addd (make-integer 42) (make-real 3.14159) (make-rational 2 5))
(real . 45.54159)