**Exercise 2.81**

If *apply-generic* is called with two arguments of type *scheme-number* or of type *complex*, and no operation is found for these types, than the coercion mechanism comes into play. As a result the type of one of the arguments gets coerced to itself and *apply-generic* is invoked with exactly the same pair of arguments. The result is an infinite recursive loop.

If, by convention, Mr. Reasoner never installs any coercion procedures from a type to itself than *apply-generic* will always terminate in a finite number of steps. However, if at some later point *apply- generic* becomes more elaborate, it might be useful for there to be “identity” coercions.

Here is a modified version of *apply-generic* that does not try to coerce arguments of the same type:

```
(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 ((type1 (car type-tags))
(type2 (cadr type-tags))
(a1 (car args))
(a2 (cadr args)))
(if (eq? type1 type2)
(error "No method for these types" (list op type-tags)))
(let ((t1->t2 (get-coercion type1 type2))
(t2->t1 (get-coercion type2 type1)))
(cond (t1->t2 (apply-generic op (t1->t2 a1) a2))
(t2->t1 (apply-generic op a1 (t2->t1 a2)))
(else (error "No method for these types"
(list op type-tags)))))
(error "No method for these types" (list op type-tags))))))))
```

**Exercise 2.82**

This new version of *apply-generic* is capable of applying coercion not only in two argument cases but for any number of arguments. It consecutively scans the arguments and for each one attempts to coerce all other arguments to its type until an acceptable coercion is found or no more coercions are possible. Special precautions are taken to avoid infinite recursive loops as seen in the previous exercise:

```
(define (apply-generic op . args)
(define (coercion-good? coerced-args)
(let ((type-tags (map type-tag args))
(coerced-type-tags (map type-tag coerced-args)))
(and (not (equal? type-tags coerced-type-tags))
(get op coerced-type-tags))))
(define (coerce-argument to-type arg)
(if (eq? to-type (type-tag arg))
arg
(let ((coerce-proc (get-coercion (type-tag arg) to-type)))
(if coerce-proc
(coerce-proc arg)
'failed))))
(define (coerce-arguments to-type args)
(if (null? args)
'()
(let ((coerced-arg (coerce-argument to-type (car args)))
(coerced-args (coerce-arguments to-type (cdr args))))
(if (or (eq? coerced-arg 'failed) (eq? coerced-args 'failed))
'failed
(cons coerced-arg coerced-args)))))
(define (search rest)
(if (null? rest)
#f
(let ((coerced-args (coerce-arguments (type-tag (car rest)) args)))
(if (and (not (eq? coerced-args 'failed))
(coercion-good? coerced-args))
coerced-args
(search (cdr rest))))))
(let ((type-tags (map type-tag args)))
(let ((proc (get op type-tags)))
(if proc
(apply proc (map contents args))
(let ((coerced-args (search args)))
(if coerced-args
(apply apply-generic (cons op coerced-args))
(error "No method for these types" (list op type-tags))))))))
```

To understand why this coercion strategy is still not general enough consider a situation where we try to apply some operation to two arguments of types *a* and *b*. Let the operation be defined only for arguments of type *c*. Since *c* is not among the initial argument types, no attempt will be made to coerce *a* to *c* and *b* to *c*.

**Exercise 2.83**

For types *integer*, *rational*, and *real* we register a *raise* operation in the operation table and define a generic *raise* that delegates its job to *apply-generic*:

```
(define (raise-integer x)
(make-rational x 1))
(define (raise-rational x)
(make-real (/ (* 1.0 (numer x)) (* 1.0 (denom x)))))
(define (raise-real x)
(make-from-real-imag x 0))
(put 'raise '(integer) raise-integer)
(put 'raise '(rational) raise-rational)
(put 'raise '(real) raise-real)
(define (raise x) (apply-generic 'raise x))
```

**Exercise 2.84**

A new unary generic operation *height* is defined such that for any two types *a* and *b* *(height a)* is greater than *(height b)* if *a* is located above *b* in the tower of types. This allows *apply-generic* to check the height of its arguments and if necessary raise the lower one or both of them (if their heights are the same) until a matching operation is found or raising is no longer possible:

```
(put 'height '(integer) (lambda (x) 0))
(put 'height '(rational) (lambda (x) 1))
(put 'height '(real) (lambda (x) 2))
(put 'height '(complex) (lambda (x) 3))
(define (height x) (apply-generic 'height x))
(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) 2)
(let* ((a1 (car args))
(a2 (cadr args))
(h1 (height a1))
(h2 (height a2)))
(cond ((< h1 h2) (apply-generic (raise a1) a2))
((> h1 h2) (apply-generic a1 (raise a2)))
(else (apply-generic (raise a1) (raise a2)))))
(error "No method for these types -- APPLY-GENERIC" (op type-tags))))))
```

**Exercise 2.85**

There is some ambiguity in this exercise. On the one hand the authors suggest using the type tower from exercise 2.83 (integer -> rational -> real -> complex), and on the other, they talk about projecting reals directly onto integers, entirely forgetting about rational numbers.

I have decided not to skip rational numbers. To implement the projecting from reals to rationals I am using the *rationalize* and *inexact->exact* procedures provided by the Scheme system:

```
(define (project-complex x)
(make-real (real-part x)))
(define (project-real x)
(let ((scheme-rat (rationalize (inexact->exact x) 0.00001)))
(make-rational (numerator x) (denominator x))))
(define (project-rational x)
(make-integer (numer x)))
(put 'project '(complex) project-complex)
(put 'project '(real) project-real)
(put 'project '(rational) project-rational)
(define (project x) (apply-generic 'project x))
```

And here is the definition of the *drop* procedure:

```
(define (drop x)
(if (and (get 'project (list (type-tag x)))
(equ? (raise (project x)) x))
(drop (project x))
x))
```

The final part of the exercise is also a bit fishy. If *apply-generic* would actually apply *drop* to its result, then imagine what would happen if we execute the generic *raise* operation. The argument would first be raised and then immediately dropped down again. This would even cause an infinite recursive loop when *apply-generic* tries to coerce its arguments.

Probably the best that can be done is to leave *apply-generic* alone and instead choose whether to use *drop* when defining new generic operations. For example *add*, *sub*, *mul*, and *div* could have been defined as:

```
(define (add x y) (drop (apply-generic 'add x y)))
(define (sub x y) (drop (apply-generic 'sub x y)))
(define (mul x y) (drop (apply-generic 'mul x y)))
(define (div x y) (drop (apply-generic 'div x y)))
```

**Exercise 2.86**

To introduce the required changes to the system we need to redefine the internal procedures in the *complex* packages to use the generic *add*, *sub*, *mul*, and *div* operations instead of their built-in equivalents *+*, *–*, ***, and */*. Furthermore, we have to define new generic operations for *sine*, *cosine*, *arctan*, *square-root*, and *square*:

```
(define (sine x) (apply-generic 'sine x))
(define (cosine x) (apply-generic 'cosine x))
(define (arctan x y) (apply-generic 'arctan x y))
(define (square-root x) (apply-generic 'square-root x))
(define (square x) (apply-generic 'square x))
```

Next we have to add implementations for these new operations in the *Scheme-number* and *rational-number* packages:

```
;;internal to the scheme number package
(put 'sine '(scheme-number) (lambda (x) (tag (sin x))))
(put 'cosine '(scheme-number) (lambda (x) (tag (cos x))))
(put 'arctan '(scheme-number scheme-number) (lambda (x y) (tag (atan x y))))
(put 'square-root '(scheme-number) (lambda (x) (tag (sqrt x))))
(put 'square '(scheme-number) (lambda (x) (tag (* x x))))
;;internal to the rational number package
(define (to-scheme-number x)
(make-scheme-number (/ (* 1.0 (numer x) (denom x)))))
(put 'sine '(rational) (lambda (x) (sine (to-scheme-number x))))
(put 'cosine '(rational) (lambda (x) (cosine (to-scheme-number x))))
(put 'arctan '(rational rational)
(lambda (x y) (arctan (to-scheme-number x) (to-scheme-number y))))
(put 'square-root '(rational) (lambda (x) (square-root (to-scheme-number x))))
(put 'square '(rational) (lambda (x) (square (to-scheme-number x))))
```

Finally, we have to modify the *polar* and *rectangular* packages to use the new generic operations instead of their built-in counterparts.