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)

SICP Exercise 2.83: Raising Types

Suppose you are designing a generic arithmetic system for dealing with the tower of types shown in figure 2.25: integer, rational, real, complex. For each type (except complex), design a procedure that raises objects of that type one level in the tower. Show how to install a generic raise operation that will work for each type (except complex).

New Types and Type Checking

Before we start into raising types, we should note that the system we've been developing in sections 2.5.1 and 2.5.2 does not deal with the tower of types presented in figure 2.25. At the moment our system has the following tower of types:

      complex
         ↑
      rational
         ↑
   scheme-number

One way of dealing with this is to note that Scheme itself has its own tower of types which matches the tower of types we need for this exercise and that the scheme-number package will work with any type of Scheme number, not just integers. As a result we can use scheme-number as the basis for any of the types required for this exercise by copying the scheme-number package, and then changing the name of the package and the type tag in use in the copy. To keep us on our toes we'll only represent the integer and real types in this manner, and leave the rational and complex types as they are.

Of course the scheme-number package doesn't restrict what type of Scheme number it can represent. So that in itself leaves our system open to abuse - if we were to create the integer package using just the steps above (i.e. without further changes) there would be nothing to stop an (ab)user of the system from using the integer package to make an "integer" using a rational, real or complex Scheme number as the "integer" value to be represented.

In order to prevent such abuse, and to ensure that our system is well behaved, we'll need to make sure that the integer package is only ever used to represent integers, while the real package is only ever used to represent real numbers. Thankfully Scheme provides the integer? and real? predicates (and the corresponding rational? and complex? predicates too) which perform the appropriate tests. We can use these to modify the procedures installed for 'make in the two packages so that they enforce the correct type.

This gives us the following implementations for these packages:

;;;
;;; Integer package
;;;
(define (install-integer-package)
  (define (tag x)
    (attach-tag 'integer x))    
  (put 'add '(integer integer)
       (lambda (x y) (tag (+ x y))))
  (put 'sub '(integer integer)
       (lambda (x y) (tag (- x y))))
  (put 'mul '(integer integer)
       (lambda (x y) (tag (* x y))))
  (put 'div '(integer integer)
       (lambda (x y) (make-rational x y)))
  (put 'equ? '(integer integer) =)
  (put '=zero? '(integer)
       (lambda (x) (= 0 x)))
  (put 'make 'integer
       (lambda (x) (if (integer? x)
                       (tag x)
                       (error "non-integer value" x))))
  'done)

(define (make-integer n)
  ((get 'make 'integer) n))

;;;
;;; Real package
;;;
(define (install-real-package)
  (define (tag x)
    (attach-tag 'real x))    
  (put 'add '(real real)
       (lambda (x y) (tag (+ x y))))
  (put 'sub '(real real)
       (lambda (x y) (tag (- x y))))
  (put 'mul '(real real)
       (lambda (x y) (tag (* x y))))
  (put 'div '(real real)
       (lambda (x y) (tag (/ x y))))
  (put 'equ? '(real real) =)
  (put '=zero? '(real)
       (lambda (x) (= 0 x)))
  (put 'make 'real
       (lambda (x) (if (real? x)
                       (tag x)
                       (error "non-real value" x))))
  'done)

(define (make-real n)
  ((get 'make 'real) n))

While we're talking about type correctness, it's possibly also worth noting that we don't do anything to ensure that the numbers represented by our rational package conform to the definition of rational numbers. I.e. both the numerator and denominator must be integers in order for it to be a valid rational number. Nor do we do anything to enforce that a complex number's real and imaginary parts are real numbers.

Of course, depending upon your Scheme interpreter, or the implementation of gcd you're using, you might find that you're already prevented from creating rational representations with non-integer values. However, to be consistent with the integer and real packages we've created, and to ensure that type correctness is enforced regardless of interpreter, we'll also update the rational and complex packages to with the appropriate checks. In the case of the complex package we'll actually put the checks in the underlying rectangular and polar packages so that we're prevented from constructing invalid representations at as low a level as possible.

Here are the updates:

(define (install-rational-package)
  ;; internal procedures
  …
  (define (make-rat n d)
    (if (and (integer? n) (integer? d))
        (let ((g (gcd n d)))
          (cons (/ n g) (/ d g)))
        (error "non-integer numerator or denominator"
               (list n d))))
  …
  ;; interface to rest of the system
  …
  'done)


(define (install-rectangular-package)
  ;; internal procedures
  …
  (define (make-from-real-imag x y)
    (if (and (in-tower? x) (in-tower? y))
        (cons x y)
        (error "non-real real or imaginary value" (list x y))))
  …
  (define (make-from-mag-ang r a) 
    (if (and (real? r) (real? a))
        (cons (* r (cos a)) (* r (sin a)))
        (error "non-real magnitude or angle" (list r a))))
  …
  ;; interface to the rest of the system
  …
  'done)

(define (install-polar-package)
  ;; internal procedures
  …
  (define (make-from-mag-ang r a)
    (if (and (in-tower? r) (in-tower? a))
        (cons r a)
        (error "non-real magnitude or angle" (list r a))))
  …
  (define (make-from-real-imag x y) 
    (if (and (in-tower? x) (in-tower? y))
        (cons (sqrt (+ (square x) (square y)))
              (atan y x))
        (error "non-real real or imaginary value" (list x y))))
  …
  ;; interface to the rest of the system
  …
  'done)

Raising Types

Okay, so now onto the exercise itself. We need to design a procedure that will raise an object of a particular type one level in the tower. The section on Coercion gives the example coercion procedure scheme-number->complex. It seems logical that we want to introduce further coercion procedures that correspond to the steps in the type tower. Let's consider what each procedure should do:

• integer->rational should convert an integer to a rational number by using the value of the integer as the numerator and, as 1 is the identity value for division, 1 as the denominator.
• rational->real should convert a rational number to a real number by taking the numerator and denominator from the rational number and converting them to a single (real) number representing that rational number. Of course the simple way to achieve this is by dividing the numerator by the denominator.
• real->complex should convert a real number to a complex number by using the value of the real number as the real component of the complex number and 0 as the imaginary component.

Here are the procedures:

(define (integer->rational i) (make-rational i 1))
(define (rational->real r) (make-real (/ (numer r) (denom r))))
(define (real->complex r) (make-complex-from-real-imag r 0))

Now what do we do with them?

We could simply install these procedures in the table under an appropriate key (such as raise) and then define a generic raise procedure that dispatches using apply-generic in the normal manner:

(define (raise x) (apply-generic 'raise x))

However, I feel that this approach has some issues:

• It doesn't cope well with complex. We're not explicitly told the semantics for raise when dealing with complex representations. We're simply told that it should be an "operation that will work for each type (except complex)." If we implement raise using apply-generic then trying to raise a complex representation will result in an error. We could work around this by implementing and installing the identity transform procedure, complex->complex, but this doesn't quite feel right.
• We're using coercion procedures, but we're not making any use of the get-coercion and put-coercion introduced in the section on Coercion.
• The type tower is expressed implicitly by the procedures installed under the raise key. If we assume that each coercion procedure is defined and installed in the corresponding package (i.e. integer->rational is installed in the integer package, and so on) then this further means that there is no central location from which the type tower can be deduced and maintained.

To address these issues we can change our approach somewhat.

Let's install the coercion procedures using put-coercion and define the tower of types explicitly, as a list of types ordered from subtype to supertype (i.e. with integer first and complex last). raise can then simply find the type in the list, get the next type from its list as its immediate supertype and then get and use the appropriate coercion procedure to perform the raise. We've then got three special conditions to deal with and we can now deal with each separately:

• If the type's not present in the list then we can raise an error indicating that we've been called with a type that's not in the tower of types. This may mean erroneous data, or it may mean that a new type has been introduced to the system that hasn't been properly incorporated into the tower of types yet.
• If the type is found in the list and it has a supertype but there's no corresponding coercion procedure, then this indicates a programming error. We've added the type to the tower of types, but failed to add all the necessary coercion procedures to support the tower.
• If the type is found in the list but it has no supertype then this indicates that the type is at the top of the tower of types. As noted before we're not told explicitly what to do with the top type. Let's just return the value unchanged as it's raised as high as it can be already.

Note also that nothing in this approach precludes us from installing other coercion procedures (e.g. such as integer->complex), so will still be possible for procedures to look for "shortcuts" in raising types, skipping intermediate types if an appropriate coercion procedure exists.

Okay, given all that, let's implement it:

(define tower-of-types '(integer rational real complex))

(define (raise x)
  (define (apply-raise types)
    (cond ((null? types)
           (error "Type not found in the tower-of-types"
                  (list x tower-of-types)))
          ((eq? (type-tag x) (car types))
           (if (null? (cdr types))
               x
               (let ((raiser (get-coercion (type-tag x) (cadr types))))
                 (if raiser
                     (raiser (contents x))
                     (error "No coercion procedure found for types"
                            (list (type-tag x) (cadr types)))))))
          (else (apply-raise (cdr types)))))
  (apply-raise tower-of-types))

And, for completion's sake, here's the changes to the types:

(define (install-integer-package)
  …
  (define (integer->rational i) (make-rational i 1))
  …
  (put-coercion 'integer 'rational integer->rational)
  …
  'done)

(define (install-rational-package)
  ;; internal procedures
  …
  (define (rational->real r) (make-real (/ (numer r) (denom r))))
  …
  ;; interface to rest of the system
  …
  (put-coercion 'rational 'real rational->real)
  …
  'done)

(define (install-real-package)
  …
  (define (real->complex r) (make-complex-from-real-imag r 0))
  …
  (put-coercion 'real 'complex real->complex)
  …
  'done)

Note that we don't need to make any changes to the complex package.

Let's see it in action:

> (raise (make-integer 2))
(rational 2 . 1)
> (raise (make-rational 3 4))
(real . 3/4)
> (raise (make-rational 5 3))
(real . 5/3)
> (raise (make-real 3.14159))
(complex rectangular 3.14159 . 0)
> (raise (make-real 1.234))
(complex rectangular 1.234 . 0)
> (raise (make-real 3/4))
(complex rectangular 3/4 . 0)

Addendum

2013-02-14 - identified as part of exercise 2.93 work!
Note that with the removal of support for the 'scheme-number primitive type we no longer need the tagging procedures attach-tag, type-tag and contents to cope with untagged types or with the 'scheme-number tag. As a result we can also revert these procedures to their pre-exercise 2.78 state:

(define (attach-tag type-tag contents)
  (cons type-tag contents))
(define (type-tag datum)
  (if (pair? datum)
      (car datum)
      (error "Bad tagged datum -- TYPE-TAG" datum)))
(define (contents datum)
  (if (pair? datum)
      (cdr datum)
      (error "Bad tagged datum -- CONTENTS" datum)))

SICP Exercise 2.82: Multi-Argument Coercion

Show how to generalize apply-generic to handle coercion in the general case of multiple arguments. One strategy is to attempt to coerce all the arguments to the type of the first argument, then to the type of the second argument, and so on. Give an example of a situation where this strategy (and likewise the two-argument version given above) is not sufficiently general. (Hint: Consider the case where there are some suitable mixed-type operations present in the table that will not be tried.)

Let's use the strategy suggested as the basis of our implementation.

In order to implement this we'll need a procedure that can coerce a list of arguments to a particular type, or provides a clear indication when this is not possible, so let's start there.

We can implement such a procedure iteratively, trying to coerce each argument in turn and accumulating a list of coerced arguments as we go. We'll need to append a list containing the newly-coerced argument at each step, as we want the arguments to end up in the same order as they were originally! This may lead you to question as to why we wouldn't do this recursively using cons to build the resulting list. We could do but, IMNSHO, the iterative approach allows us to provide a cleaner API when we fail to coerce an argument:

• With an iterative implementation if we reach an argument that we fail to coerce we can simply discard the accumulated result so far and instead return a special error value such as #f. Callers can then easily check whether or not the coercion succeeded.
• With a recursive implementation if we reach an argument that we fail to coerce the best we could do would be to return '() immediately instead of processing the rest of the arguments. The chain of recursive calls so far would still cons their successfully coerced arguments onto this and so the result of the procedure evaluation would be a list containing all of the coerced arguments preceding the failed one. Callers would then need to check the length of the returned list against the expected length to see whether or not the coercion succeeded.

To reduce the nesting in the implementation we'll take advantage of let*, a variant of let that performs the bindings of value to name in sequential order, allowing later bindings to use earlier bindings.

We'll also check whether or not an argument is already of the required type before trying to coerce it. If it's already of the required type then we don't need to perform any coercion.

Here's the implementation:

(define (coerce-to target-type remaining-args result)
  (if (null? remaining-args)
      result
      (let* ((arg (car remaining-args))
             (original-type (type-tag arg)))
        (if (eq? original-type target-type)
            (coerce-to target-type
                       (cdr remaining-args)
                       (append result (list arg)))
            (let ((original->target (get-coercion (type-tag arg) target-type)))
              (if original->target
                  (coerce-to target-type
                             (cdr remaining-args)
                             (append result (list (original->target arg))))
                  #f))))))

In order to test this out we'll need to implement the get-coercion and put-coercion procedures. We can do this for now by simply reserving an operation name in our table for coercion procedures ('coercion will do) and then wrapping the put and get procedures appropriately:

(define (put-coercion source-type target-type proc)
  (put 'coercion (list source-type target-type) proc))

(define (get-coercion source-type target-type)
  (get 'coercion (list source-type target-type)))

Having done that we can install the example scheme-number->complex coercion procedure from the Coercion section and then test our coerce-to procedure:

> (coerce-to 'complex
           (list (make-scheme-number 1)
                 (make-scheme-number 2)
                 (make-scheme-number 3))
           '())
((complex rectangular 1 . 0) (complex rectangular 2 . 0) (complex rectangular 3 . 0))
> (coerce-to 'complex
           (list (make-scheme-number 1)
                 (make-complex-from-real-imag 2 1)
                 (make-scheme-number 3))
           '())
((complex rectangular 1 . 0) (complex rectangular 2 . 1) (complex rectangular 3 . 0))
> (coerce-to 'complex
           (list (make-rational 1 2)
                 (make-complex-from-real-imag 2 1)
                 (make-scheme-number 3))
           '())
#f

That all looks good, so let's move on to using this to try to coerce the arguments to a type for which there is a suitable procedure to evaluate. If we assume we have a list of types to try out then what we want to do is to iterate through the types until we find one for which we can coerce all the arguments to that type and it is possible to get a corresponding procedure for arguments of that type. If we manage to find such a type then we'll evaluate the procedure with the coerced arguments, otherwise we'll raise an error.

The procedure itself will end up as an inner procedure of our updated apply-generic, so both the op and args arguments of apply-generic will be in scope. Bearing that in mind we can express this procedure as follows:

(define (apply-generic-iter coercion-types)
  (if (null? coercion-types)
      (error "No method for these types, and could not coerce"
             (list op (map type-tag args)))
      (let ((coerced-args (coerce-to (car coercion-types) args '())))
        (if coerced-args
            (let ((proc (get op (map type-tag coerced-args))))
              (if proc
                  (apply proc (map contents coerced-args))
                  (apply-generic-iter (cdr coercion-types))))
            (apply-generic-iter (cdr coercion-types))))))

To test this we'll first extend the complex package to include a new operation, addd, which adds three complex numbers together:

(define (install-complex-package)
  ;; imported procedures from rectangular and polar packages
  …
  ;; internal procedures
  …
  (define (addd-complex z1 z2 z3)
    (make-from-real-imag (+ (complex-real-part z1)
                            (complex-real-part z2)
                            (complex-real-part z3))
                         (+ (complex-imag-part z1)
                            (complex-imag-part z2)
                            (complex-imag-part z3))))
  …
  ;; interface to rest of the system
  …
  (put 'addd '(complex complex complex)
       (lambda (z1 z2 z3) (tag (addd-complex z1 z2 z3))))
  …
  'done)

Next we'll define the generic procedure addd:

(define (addd x y z) (apply-generic 'addd x y z))

Finally we can test this by defining op and args appropriately:

> (define op 'addd)
> (define args (list (make-scheme-number 1)
                     (make-scheme-number 2)
                     (make-scheme-number 3)))
> (apply-generic-iter '(scheme-number complex))
(complex rectangular 6 . 0)
> (define args (list (make-scheme-number 1)
                     (make-complex-from-real-imag 2 1)
                     (make-scheme-number 3)))
> (apply-generic-iter '(scheme-number complex))
(complex rectangular 6 . 1)
> (define args (list (make-complex-from-real-imag 1 2)
                     (make-scheme-number 3)
                     (make-complex-from-real-imag 4 5)))
> (apply-generic-iter '(scheme-number complex))
(complex rectangular 8 . 7)

Good stuff!

Now we're almost ready to put all this together... But not quite. First we should think about how we get the list of types to call this with?

The exercise suggests that we "attempt to coerce all the arguments to the type of the first argument, then to the type of the second argument, and so on." We know that we can get a list of the types of the arguments we're called with by evaluating (map type-tag args). We could then just iterate through that list and try coercing the arguments to each one in turn. However, this would be wasteful in many cases. If there are multiple arguments of the same type then we'll end up trying to perform the coercion to that type and, if it's successful, try to get the corresponding procedure multiple times.

So how can we avoid this? Well obviously it would be more efficient if we only tried each type once. So let's build ourselves a procedure that can take a list and throw out any duplicates. The resulting order isn't too important, so let's define its behaviour as follows: given a list the procedure will cons the head of the list onto the result of uniquifying the tail of the list iff the tail does not contain the head item. This results in the ordering of the unique list reflecting the ordering of the last occurrence of each item.

Here's the procedure:

  (define (uniquify l)
    (if (null? l)
        '()
        (let ((head (car l))
              (tail (cdr l)))
          (if (memq head tail)
              (uniquify tail)
              (cons head (uniquify tail))))))

...and here it is in action:

> (uniquify '(1 2 3 4 3 2 1))
(4 3 2 1)
> (uniquify '(1 2 1 3 1 4 1))
(2 3 4 1)
> (uniquify '(2 2 2 4 2 3 1 3))
(4 2 1 3)

Okay, finally we can put it together, right? We've got a procedure that tries to coerce a list of arguments to a particular type and we've got a procedure that iterates through a list of types, coercing the arguments to each type in turn until it finds a procedure it can evaluate for that type. We've even got a procedure that will enable us to ensure we only try each type once. So we're good to go, right?

Well, almost. There's just one more thing I'd like to consider.

Suppose we get called with a list of arguments all of the same type. We'll try to coerce them to that type which, while it will succeed, is not a necessary operation. So before we start any coercion let's first check to see if there's a procedure installed for the un-coerced types. If there is then we can evaluate it directly. If there isn't then we have to go ahead with extracting the list of types, uniquify it and, if the resulting type list has more than one item in it, try to find an appropriate installed procedure via type coercion.

Why only go ahead with trying to coerce if the uniquified type list has more than one item in it? Well if the type list only has one item in it then all the arguments must be of the same type: the one type in the type list. As a result our coercion procedure will not change the types of any of the arguments and so if a procedure existed for such a type list then our initial check for an appropriate installed procedure should have succeeded.

Oh, and this has the added advantage that if the argument list is of mixed type and there just happens to be a procedure installed that corresponds to that list of types then we'll invoke that. That wouldn't have happened if we'd followed the exercises suggested strategy to the letter.

Right, now we can put it all together:

(define (apply-generic op . args)
  (define (uniquify l)
    (if (null? l)
        '()
        (let ((head (car l))
              (tail (cdr l)))
          (if (memq head tail)
              (uniquify tail)
              (cons head (uniquify tail))))))
  (define (coerce-to target-type remaining-args result)
    (if (null? remaining-args)
        result
        (let* ((arg (car remaining-args))
               (original-type (type-tag arg)))
          (if (eq? original-type target-type)
              (coerce-to target-type
                         (cdr remaining-args)
                         (append result (list arg)))
              (let ((original->target (get-coercion (type-tag arg) target-type)))
                (if original->target
                    (coerce-to target-type
                               (cdr remaining-args)
                               (append result (list (original->target arg))))
                    #f))))))
  (define (apply-generic-iter coercion-types)
    (if (null? coercion-types)
        (error "No method for these types, and could not coerce"
               (list op (map type-tag args)))
        (let ((coerced-args (coerce-to (car coercion-types) args '())))
          (if coerced-args
              (let ((proc (get op (map type-tag coerced-args))))
                (if proc
                    (apply proc (map contents coerced-args))
                    (apply-generic-iter (cdr coercion-types))))
              (apply-generic-iter (cdr coercion-types))))))
  (let* ((type-tags (map type-tag args))
         (proc (get op type-tags)))
    (if proc
        (apply proc (map contents args))
        (let ((unique-types (uniquify type-tags)))
          (if (> (length unique-types) 1)
              (apply-generic-iter unique-types)
              (else (error "No method for this type"
                           (list op type-tags))))))))

Let's see this in action with addd:

> (addd (make-scheme-number 1)
        (make-complex-from-real-imag 2 1)
        (make-scheme-number 3))
(complex rectangular 6 . 1)
> (addd (make-complex-from-real-imag 1 2)
        (make-scheme-number 3)
        (make-complex-from-real-imag 4 5))
(complex rectangular 8 . 7)

Okay, so there's the updated apply-generic.

The exercise also asks us to "Give an example of a situation where this strategy (and likewise the two-argument version given above) is not sufficiently general". Well there are two situations I can think of where this approach will fail:

1. While our implementation will successfully work with mixed-type procedures where there is a procedure installed for the types of the arguments that apply-generic is called with, it will fail to test for installed procedures of other mixed types. For example, suppose there is a procedure installed for the argument type list of '(complex scheme-number) then a call to apply-generic with arguments with the corresponding type list of '(scheme-number complex) will fail, even if it is possible to coerce the individual arguments to the appropriate types.
2. Our implementation will only try to coerce to a type if there is at least one argument of that type. At the moment our system has packages installed for the scheme-number, rational and complex types. However, only the complex package has a procedure installed that implements addd. If we try to evaluate addd with an argument list consisting of only types scheme-number and rational then apply-generic will never try to coerce the arguments to the complex type and so will never find the installed procedure.