SICP Exercise 2.88: Subtracting Polynomials

Extend the polynomial system to include subtraction of polynomials. (Hint: You may find it helpful to define a generic negation operation.)

The authors suggest that defining a generic negation operation may be useful in solving this exercise. Why would this be?

Well, if we consider what's required in order to subtract one polynomial from another then all will become clear. Assuming we have polynomials p1 and p2 and we want to calculate p1 - p2 then, similar to the addition of polynomials, we want to perform this term-wise:

• If there are terms of the same order in both p1 and p2 then we'll need a corresponding term in the resulting polynomial. The coefficient of this term will be the result of subtracting the coefficient of p2's term from the coefficient of p1's term.
• If only p1 has a term of a particular order then we need an identical term in the resulting polynomial, so we can just add it into the resulting polynomial directly.
• If only p2 has a term of a particular order then we need the negation of that term in the resulting polynomial.

So we could define an operation, sub-terms, that implements the steps above in a manner analogous to add-terms, and then define a procedure sub-poly which uses this in the same way as add-poly uses add-terms, using our generic negation operation to negate terms in p2 for which there is no corresponding term of the same order in p1.

Or we could be a bit smarter...

For any two values, a and b, that are of types representable in our system we know that a - b = a + (-b). In other words, subtracting b from a will give the same result as adding the negation of b to a.

When it comes to dealing with the terms of our polynomials this means that we can calculate the result of subtracting one term, t2, from another term, t1, by adding the result of negating t2 to t1. We can extend this to calculating the result of subtracting the polynomial p2 from p1 by negating all of the terms of p2, and then adding this new (negated) polynomial to p1. We already have an operation, add-poly, which will perform the addition. As a result, if we define a generic negation operation then implementing sub-poly simply becomes a case of evaluating add-poly with the first polynomial and the negation of the second polynomial.

So how do we define negation? Well, the generic operation itself is defined in the usual manner. We then just need to consider what to do for each of the different types:

• integer: Given an integer i we can calculate its negation by evaluating (- i), and then all we need to do is tag the results of this evaluation.
• rational: To negate a rational number we simply negate its numerator, which we can do in the same way as for integer, and then create a new rational number with the negated numerator and original denominator.
• real: A real number can be negated in the same way as for an integer.
• complex: To negate a complex number consider that, in order to calculate the negation of the complex number a + bi, we need to calculate -(a + bi). This is equivalent to (-a) + (-b)i. As a result we can calculate the negation by negating both the real and imaginary parts and constructing a new complex number from these negated components.
• polynomial: Finally, to negate a polynomial, we simply iterate through its terms and negate each one in turn using the generic negation operation. Once we've done this we create a new polynomial with the same indeterminate as the original and with the negated term list.

Okay, given that, here's the changes required to provide a generic negation operation:

(define (install-integer-package)
  …
  (put 'negate '(integer)
       (lambda (x) (tag (- x))))
  …
  'done)

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

(define (install-real-package)
  …
  (put 'negate '(real)
       (lambda (x) (tag (- x))))
  …
  'done)

(define (install-complex-package)
  …
  ;; internal procedures
  …
  (define (negate-complex z)
    (make-from-real-imag (negate (complex-real-part z))
                         (negate (complex-imag-part z))))
  …
  ;; interface to rest of the system
  …
  (put 'negate '(complex)
       (lambda (z) (tag (negate-complex z))))
  …
  'done)

(define (install-polynomial-package)
  ;; internal procedures
  …
  ;; Negation
  (define (negate-terms L)
    (if (empty-termlist? L)
        (the-empty-termlist)
        (let ((term (first-term L)))
          (adjoin-term (make-term (order term)
                                  (negate (coeff term)))
                       (negate-terms (rest-terms L))))))
  (define (negate-poly p)
    (make-poly (variable p)
               (negate-terms (term-list p))))
  …
  ;; interface to rest of the system
  …
  (put 'negate '(polynomial)
       (lambda (p) (tag (negate-poly p))))
  …
  'done)

Here's the negation in action:

> (negate (make-integer 42))
(integer . -42)
> (negate (make-rational 13 27))
(rational -13 . 27)
> (negate (make-real 3.14159))
(rational -3537115888337719 . 1125899906842624)
> (negate (make-complex-from-real-imag (make-real 3.5) (make-integer -32)))
(complex rectangular (rational -7 . 2) integer . 32)
> (define inner-poly (make-polynomial 
                      'y
                      (list (make-polynomial-term 2 (make-integer 1))
                            (make-polynomial-term 1 (make-rational -3 2))
                            (make-polynomial-term 0 (make-integer 42)))))
> (define outer-poly (make-polynomial
                      'x
                      (list (make-polynomial-term 4 (make-rational 7 2))
                            (make-polynomial-term 3 (make-complex-from-real-imag
                                                     (make-integer 42)
                                                     (make-integer -13)))
                            (make-polynomial-term 2 inner-poly)
                            (make-polynomial-term 0 (make-integer 5)))))
> (negate outer-poly)
(polynomial x (4 (rational -7 . 2))
              (3 (complex rectangular (integer . -42) integer . 13))
              (2 (polynomial y (2 (integer . -1))
                               (1 (rational 3 . 2))
                               (0 (integer . -42))))
              (0 (integer . -5)))

With that working, we just implement sub-poly as noted above:

(define (install-polynomial-package)
  …
  ;; Subtraction
  (define (sub-poly p1 p2)
    (add-poly p1 (negate-poly p2)))
  …
  ;; interface to rest of the system
  …
  (put 'sub '(polynomial polynomial)
       (lambda (p1 p2) (tag (sub-poly p1 p2))))
  …
  'done)

Now we can subtract one polynomial from another... Subtracting 5x⁴ + 4x³ + x + 1 from 4x⁴ + 2x² + 1 should give -x⁴ - 4x³ + 2x² - x:

> (sub (make-polynomial 'x
                        (list (make-polynomial-term 4 (make-integer 4))
                              (make-polynomial-term 2 (make-integer 2))
                              (make-polynomial-term 0 (make-integer 1))))
       (make-polynomial 'x
                        (list (make-polynomial-term 4 (make-integer 5))
                              (make-polynomial-term 3 (make-integer 4))
                              (make-polynomial-term 1 (make-integer 1))
                              (make-polynomial-term 0 (make-integer 1)))))
(polynomial x (4 (integer . -1))
              (3 (integer . -4))
              (2 (integer . 2))
              (1 (integer . -1)))

Looks good!

SICP Exercise 2.87 Addendum: Making Polynomials

If you were paying close attention at the end of exercise 2.87 you would have noticed that I created polynomials for testing =zero? as follows:

(make-polynomial 'x '())
(make-polynomial 'x (list (list 4 (make-integer 3))
                          (list 2 (make-integer 1))
                          (list 0 (make-real 2.3))))
(make-polynomial 'x (list (list 3 (make-real 0))
                          (list 2 (make-rational 0 4))
                          (list 1 (make-integer 0))))

Do you notice anything about the term list?

Yep, I had to create the term list representation directly as the operations within the polynomial package for doing so are not exposed externally. This means that I, and anyone using the system, needs to have knowledge of the internal representation used for terms and term lists in order to create polynomials. They would need to know that a term is a list consisting of the order of the indeterminate that the term is for and the coefficient to apply. They would also need to know that a term list is a list of such terms, ordered in decreasing value of the order of the terms.

Exposing the internal representation in this manner has a further implication. It means that once our system is in use we will be unable to change the internal representation without having to find all clients of the system and update them to use the new representation.

Yuck.

We can address these issues by encapsulating the internal representation of terms. To do this we'll need a way for clients to create valid term representations for passing to make-polynomial. We'll also want to update make-polynomial so that clients can pass us in any list of terms and we'll reorganize them into our desired internal representation.

The first of these steps is straightforward. The polynomial package already has an internal operation, make-term for constructing polynomial terms. We just need to expose this externally in the normal manner.

As for accepting any list of polynomials and converting them into a valid representation, let's consider what we'll have to do. We'll need to go through the passed-in list of terms and build up the valid internal representation as we go. To do this we'll need to start with a valid internal representation of an empty term list (which we can get by evaluating (the-empty-termlist)). We then need to iterate through the passed-in terms and, for each one, insert it into the correct position in the term list we're building up. We should also cope with the situation where there are two or more terms passed in with the same order. We could either raise an error in this case, or add the terms together. I chose the latter.

Here's the updates required to do all this:

(define (install-polynomial-package)
  …
  (define (make-poly variable term-list)
    (cons variable (build-term-list term-list (the-empty-termlist))))
  …
  (define (insert-term term terms)
    (if (empty-termlist? terms)
        (adjoin-term term (the-empty-termlist))
        (let* ((head (first-term terms))
               (head-order (order head))
               (term-order (order term)))
          (cond ((> term-order head-order) (adjoin-term term terms))
                ((= term-order head-order)
                 (adjoin-term (make-term term-order (add (coeff term) (coeff head)))
                              (rest-terms terms)))
                (else (adjoin-term head (insert-term term (rest-terms terms))))))))
  (define (build-term-list terms result)
    (if (null? terms)
        result
        (build-term-list (cdr terms) (insert-term (car terms) result))))
  …
  (put 'make 'polynomial-term make-term)
  …
  'done)

(define (make-polynomial-term order coeff)
  ((get 'make 'polynomial-term) order coeff))

We can then make polynomials as follows:

> (make-polynomial 'x
                   (list (make-polynomial-term 4 (make-integer 3))
                         (make-polynomial-term 2 (make-integer 1))
                         (make-polynomial-term 0 (make-real 2.3))))
(polynomial x (4 (integer . 3)) (2 (integer . 1)) (0 (real . 2.3)))
> (make-polynomial 'y
                   (list (make-polynomial-term 2 (make-integer 1))
                         (make-polynomial-term 0 (make-real 2.3))
                         (make-polynomial-term 4 (make-integer 3))))
(polynomial y (4 (integer . 3)) (2 (integer . 1)) (0 (real . 2.3)))
> (make-polynomial 'z
                   (list (make-polynomial-term 0 (make-integer 0))
                         (make-polynomial-term 3 (make-real 0.0))
                         (make-polynomial-term 2 (make-rational 1 2))))
(polynomial z (2 (rational 1 . 2)))
> (make-polynomial 'a
                   (list (make-polynomial-term 2 (make-integer 1))
                         (make-polynomial-term 3 (make-real 3.5))
                         (make-polynomial-term 2 (make-rational 1 2))))
(polynomial a (3 (real . 3.5)) (2 (rational 3 . 2)))

SICP Exercise 2.87: Testing Zero for Polynomials

Install =zero? for polynomials in the generic arithmetic package. This will allow adjoin-term to work for polynomials with coefficients that are themselves polynomials.

The polynomial Package

In section 2.5.3 the authors provide us with various operations for manipulating polynomials and their terms, along with the skeleton of a polynomial package. Before we can start into the exercise we need to put all this together so that we have a package we can install into the system we've been building from section 2.5.1.

To save you the hassle of doing it yourself, here's the basic polynomial package:

(define (install-polynomial-package)
  ;; internal procedures
  ;; representation of poly
  (define (make-poly variable term-list)
    (cons variable term-list))
  (define (variable p) (car p))
  (define (term-list p) (cdr p))
  
  ;; procedures same-variable? and variable? from section 2.3.2
  (define (variable? x) (symbol? x))
  (define (same-variable? v1 v2)
    (and (variable? v1) (variable? v2) (eq? v1 v2)))

  ;; representation of terms and term lists
  (define (adjoin-term term term-list)
    (if (=zero? (coeff term))
        term-list
        (cons term term-list)))
  (define (the-empty-termlist) '())
  (define (first-term term-list) (car term-list))
  (define (rest-terms term-list) (cdr term-list))
  (define (empty-termlist? term-list) (null? term-list))
  (define (make-term order coeff) (list order coeff))
  (define (order term) (car term))
  (define (coeff term) (cadr term))

  ;; procedures used by add-poly
  (define (add-poly p1 p2)
    (if (same-variable? (variable p1) (variable p2))
        (make-poly (variable p1)
                   (add-terms (term-list p1)
                              (term-list p2)))
        (error "Polys not in same var -- ADD-POLY"
               (list p1 p2))))
  (define (add-terms L1 L2)
    (cond ((empty-termlist? L1) L2)
          ((empty-termlist? L2) L1)
          (else
           (let ((t1 (first-term L1)) (t2 (first-term L2)))
             (cond ((> (order t1) (order t2))
                    (adjoin-term
                     t1 (add-terms (rest-terms L1) L2)))
                   ((< (order t1) (order t2))
                    (adjoin-term
                     t2 (add-terms L1 (rest-terms L2))))
                   (else
                    (adjoin-term
                     (make-term (order t1)
                                (add (coeff t1) (coeff t2)))
                     (add-terms (rest-terms L1)
                                (rest-terms L2)))))))))

  ;; procedures used by mul-poly
  (define (mul-poly p1 p2)
    (if (same-variable? (variable p1) (variable p2))
        (make-poly (variable p1)
                   (mul-terms (term-list p1)
                              (term-list p2)))
        (error "Polys not in same var -- MUL-POLY"
               (list p1 p2))))
  (define (mul-terms L1 L2)
    (if (empty-termlist? L1)
        (the-empty-termlist)
        (add-terms (mul-term-by-all-terms (first-term L1) L2)
                   (mul-terms (rest-terms L1) L2))))
  (define (mul-term-by-all-terms t1 L)
    (if (empty-termlist? L)
        (the-empty-termlist)
        (let ((t2 (first-term L)))
          (adjoin-term
           (make-term (+ (order t1) (order t2))
                      (mul (coeff t1) (coeff t2)))
           (mul-term-by-all-terms t1 (rest-terms L))))))
  
  ;; interface to rest of the system
  (define (tag p) (attach-tag 'polynomial p))
  (put 'add '(polynomial polynomial) 
       (lambda (p1 p2) (tag (add-poly p1 p2))))
  (put 'mul '(polynomial polynomial) 
       (lambda (p1 p2) (tag (mul-poly p1 p2))))
  (put 'make 'polynomial
       (lambda (var terms) (tag (make-poly var terms))))
  'done)

(define (make-polynomial var terms)
  ((get 'make 'polynomial) var terms))

Don't forget to install this by evaluating (install-polynomial-package) of course, or you won't get very far!

Zero Testing for Polynomials

Now onto the exercise itself!

In order to implement =zero? for the polynomial package we need to ask ourselves how we can test whether a polynomial is zero or not. We can't determine equality with zero by looking at the indeterminate itself. However, we can determine it from the coefficients.

If there are no coefficients then the polynomial is equal to zero. On the other hand, when there are coefficients, we can only say that the polynomial is equal to zero iff all of the coefficients are equal to zero. As soon as one of them is non-zero we're unable to tell whether or not the polynomial is equal to zero until we bind the indeterminate to a particular value. Of course, as the coefficients are types from our generic arithmetic system we can test these for equality with zero by recursively evaluating =zero? on each of them.

So we have a recursive approach. If the list of coefficients is empty then the polynomial is equal to zero. Otherwise, we test whether or not the first coefficient is equal to zero. If it is then the polynomial may be equal to zero, but we need to test the remaining coefficients for equality with zero before we can confirm this; if it isn't then the polynomial isn't equal to zero.

Let's put this into code:

(define (install-polynomial-package)
  …
  (define (=zero-all-terms? L)
    (cond ((empty-termlist? L) #t)
          ((not (=zero? (coeff (first-term L)))) #f)
          (else (=zero-all-terms? (rest-terms L)))))
  (define (=zero-poly? p)
    (=zero-all-terms? (term-list p)))
  …
  (put '=zero? '(polynomial) =zero-poly?)
  …
  'done)

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

> (=zero? (make-polynomial 'x '()))
#t
> (=zero? (make-polynomial 'x (list (list 4 (make-integer 3))
                                    (list 2 (make-integer 1))
                                    (list 0 (make-real 2.3)))))
#f
> (=zero? (make-polynomial 'x (list (list 3 (make-real 0))
                                    (list 2 (make-rational 0 4))
                                    (list 1 (make-integer 0)))))
#t

SICP Exercise 2.86: Complex Complex Numbers

Suppose we want to handle complex numbers whose real parts, imaginary parts, magnitudes, and angles can be either ordinary numbers, rational numbers, or other numbers we might wish to add to the system. Describe and implement the changes to the system needed to accommodate this. You will have to define operations such as sine and cosine that are generic over ordinary numbers and rational numbers.

Type Validation

If you recall, back in exercise 2.83 we augmented all of the procedures installed under the 'make key to validate the (Scheme built-in) types of the numeric operands passed to them to ensure that we could only construct valid representations of numbers. In the case of the complex package we restricted the real and imaginary parts, magnitudes and angles to Scheme real numbers by using real? to test each operand passed to the make-from-real-imag and make-from-mag-ang procedures defined in the rectangular and polar packages.

I'm assuming that, as we're going to allow the use of the integer, rational and real number representations provided by the integer, rational and real packages as the numeric operands for constructing complex representations, we're now going to disallow the use of the built-in Scheme real numbers. This means we need to replace the existing tests with ones that test that the operands are using numeric representations from within our tower-of-types. To ensure that we're not trying to build complex numbers with components that are themselves complex numbers we'll go one step further and ensure that the type we're using is lower in the tower than 'complex.

In the preceding exercise we devised a simple test for the first part of this restriction, which we used in apply-generic to determine whether or not we should drop the result down the tower-of-types: we check that the value is a pair and, if it is, get its type-tag and check that this is in the tower-of-types using memq. We can extract this to its own procedure:

(define (in-tower? value)
  (and (pair? value) (memq (type-tag value) tower-of-types)))

To perform the second part of the test, i.e. to check that the value's type is lower than 'complex, we can use the fact that the tower-of-types is a list ordered from lowest to highest in the tower. Recall that if the procedure memq finds the requested element in the provided list then it returns the tail of that list from that element onwards. If we use memq with the type we want to ensure is higher in the tower ('complex in this case, but let's call it T) then, provided T is present in the tower-of-types, memq will return a list consisting of T and all higher types. We can then check whether or not the type of the value we want to check is lower than T by testing to see whether it's present in the list of types that are T or higher. Iff it's not present in that list then it's a lower type.

Here's our procedure:

(define (is-lower? value type)
  (let ((type-and-higher (memq type tower-of-types)))
    (if (and type-and-higher
             (in-tower? value))
        (not (memq (type-tag value) type-and-higher))
        (error "Either value's type or type is not in tower-of-types"
               (list value type)))))

Let's see it in action:

> (is-lower? (make-integer 4) 'complex)
#t
> (is-lower? (make-rational 3 4) 'real)
#t
> (is-lower? (make-rational 3 4) 'rational)
#f
> (is-lower? (make-rational 3 4) 'integer)
#f

We can then update the rectangular and polar packages to use this test instead of real?:

(define (install-rectangular-package)
  ;; internal procedures
  …
  (define (make-from-real-imag x y)
    (if (and (is-lower? x 'complex) (is-lower? y 'complex))
        (cons x y)
        (error "non-real real or imaginary value" (list x y))))
  …
  (define (make-from-mag-ang r a) 
    (if (and (is-lower? r 'complex) (is-lower? a 'complex))
        (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 (is-lower? r 'complex) (is-lower? a 'complex))
        (cons r a)
        (error "non-real magnitude or angle" (list r a))))
  …
  (define (make-from-real-imag x y) 
    (if (and (is-lower? x 'complex) (is-lower? y 'complex))
        (cons (sqrt (add (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)

Generic Arithmetic Operations

Next let's think about the further changes we need to make to the rectangular and polar packages, as well as the changes we'll need to make to the complex package, in order that the operations defined within these packages can work with our system's numeric representations.

The exercise says "you will have to define operations such as sine and cosine that are generic over ordinary numbers and rational numbers." We'll need to go further than just defining generic equivalents for the trigonometric functions though. We'll need to define generic equivalents for all mathematical functions used within the complex packages. Once we've done that we can then replace all of the built-in mathematical functions within the complex packages with their generic equivalents.

Looking at the complex package and the two sub-packages, rectangular and polar we can see that the built-in mathematical functions that we'll need generic equivalents for are: +, -, *, /, =, sqrt, square, atan, cos and sin. We've already got generic equivalents for the first five: add, sub, mul and divide respectively for the first four, and equ?/=zero? for = depending upon the value we're comparing.

Let's move on to the remaining functions.

We can produce the generic operations in the usual manner:

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

All that remains is to install appropriate implementations of these in each of the packages lower in the tower-of-types than 'complex.

The procedures we need to install for 'square are straightforward. For 'integer and 'real values we can just use the built-in * operation and multiply the underlying numeric value by itself. For 'rational numbers we can simply use mul-rat to multiply the rational number by itself. The result can then be tagged as normal.

As for the square root and trigonometric functions, while we could calculate these using the techniques we learned back in section 1.3.3 and its associated exercises (e.g. such as exercise 1.39), we'll go easy on ourselves and just delegate to the corresponding built-in operations appropriately for each type. However, we do need to treat the results of these operations carefully:

• Given Scheme integer, rational or real values, the results of the built-in trigonometric operations may themselves be Scheme real numbers so, apart from in the real package, we can't just tag the results of the delegated operation normally. Instead we'll have to create real representations from them.
• Worse still, the result of the built-in sqrt operation may be a Scheme complex number. In this case we'll need to extract out the real and imaginary parts of the result and use these to create a complex representation... And as we're updating the system so that complex numbers can only be constructed using our system's own number representations, we'll have to turn the real and imaginary parts into real representations in order for us to construct the complex representation.

Once we've constructed the appropriate representation for the results we can then rely upon the work we did in exercise 2.85 to drop the number's type to the simplest representation available.

It's possibly worth noting that the complexity of dealing with the results of sqrt points to another piece of work we need to do. As complex representations can only be created using representations from within the tower-of-types we'll need to update the coercion procedure real->complex to that it too turns the components into real representations.

Given all that, here are the changes required to the integer, rational and real packages in order to install the procedures and support the complex package restrictions:

(define (install-integer-package)
  …
  (put 'sqrt '(integer)
       (lambda (x)
         (let ((root (sqrt x)))
           (make-complex-from-real-imag (make-real (real-part root))
                                        (make-real (imag-part root))))))
  (put 'square '(integer)
       (lambda (x) (tag (* x x))))
  (put 'arctan '(integer integer)
       (lambda (x y) (make-real (atan x y))))
  (put 'cosine '(integer)
       (lambda (x) (make-real (cos x))))
  (put 'sine '(integer)
       (lambda (x) (make-real (sin x))))
  …
  'done)

(define (install-rational-package)
  ;; internal procedures
  …
  (define (sqrt-rat x)
    (let ((root (sqrt (/ (numer x) (denom x)))))
      (make-complex-from-real-imag (make-real (real-part root))
                                   (make-real (imag-part root)))))
  (define (square-rat x)
    (mul-rat x x))
  (define (arctan-rat x y)
    (atan (/ (numer x) (denom x))
          (/ (numer y) (denom y))))
  (define (cosine-rat x)
    (cos (/ (numer x) (denom x))))
  (define (sine-rat x)
    (sin (/ (numer x) (denom x))))
  …
  ;; interface to rest of the system
  …
  (put 'sqrt '(rational)
       (lambda (x) (make-real (sqrt-rat x))))
  (put 'square '(rational)
       (lambda (x) (tag (square-rat x))))
  (put 'arctan '(rational rational)
       (lambda (x y) (make-real (arctan-rat x y))))
  (put 'cosine '(rational)
       (lambda (x) (make-real (cosine-rat x))))
  (put 'sine '(rational)
       (lambda (x) (make-real (sine-rat x))))
  …
  'done)

(define (install-real-package)
  …
  (define (real->complex r) (make-complex-from-real-imag (tag r) (tag 0)))
  …
  (put 'sqrt '(real)
       (lambda (x)
         (let ((root (sqrt x)))
           (make-complex-from-real-imag (tag (real-part root))
                                        (tag (imag-part root))))))
  (put 'square '(real)
       (lambda (x) (tag (* x x))))
  (put 'arctan '(real real)
       (lambda (x y) (tag (atan x y))))
  (put 'cosine '(real)
       (lambda (x) (tag (cos x))))
  (put 'sine '(real)
       (lambda (x) (tag (sin x))))
  …
  'done)

Before we go any further, let's give this a spin:

> (square-root (make-real 16.0))
(integer . 4)
> (square (make-rational 3 5))
(rational 9 . 25)
> (cosine (make-integer 0))
(integer . 1)
> (cos 0)
1.0
> (sine (make-integer 3))
(rational 5084384125703515 . 36028797018963968)
> (/ 5084384125703515.0 36028797018963968.0)
0.141120008059867
> (sin 3)
0.141120008059867
> (arctan (make-integer 3) (make-integer 4))
(rational 5796142707547873 . 9007199254740992)
> (/ 5796142707547873.0 9007199254740992.0)
0.643501108793284
> (atan 3 4)
0.643501108793284

Updating the complex Packages

All that remains is to go through the rectangular, polar and complex packages and replace all the built-in operations with our generic equivalents.

Note that the changes we'll make to make-from-mag-ang in the rectangular package and to make-from-real-imag in the polar package will have the effect of dropping the calculated components of the created complex representation. To keep everything consistent, let's explicitly drop the components passed to make-from-real-imag in the rectangular package and to make-from-mag-ang in the polar package.

Here are the changes to the packages:

(define (install-rectangular-package)
  ;; internal procedures
  …
  (define (make-from-real-imag x y)
    (if (and (is-lower? x 'complex) (is-lower? y 'complex))
        (cons (drop x) (drop y))
        (error "non-real real or imaginary value" (list x y))))
  (define (magnitude z)
    (square-root (add (square (real-part z))
                 (square (imag-part z)))))
  (define (angle z)
    (arctan (imag-part z) (real-part z)))
  (define (make-from-mag-ang r a) 
    (if (and (is-lower? r 'complex) (is-lower? a 'complex))
        (cons (mul r (cosine a)) (mul r (sine 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 (is-lower? r 'complex) (is-lower? a 'complex))
        (cons (drop r) (drop a))
        (error "non-real magnitude or angle" (list r a))))
  (define (real-part z)
    (mul (magnitude z) (cosine (angle z))))
  (define (imag-part z)
    (mul (magnitude z) (sine (angle z))))
  (define (make-from-real-imag x y) 
    (if (and (is-lower? x 'complex) (is-lower? y 'complex))
        (cons (square-root (add (square x) (square y)))
              (arctan y x))
        (error "non-real real or imaginary value" (list x y))))
  …
  ;; interface to the rest of the system
  …
  'done)

(define (install-complex-package)
  ;; imported procedures from rectangular and polar packages
  …
  ;; internal procedures
  …
  (define (add-complex z1 z2)
    (make-from-real-imag (add (complex-real-part z1) (complex-real-part z2))
                         (add (complex-imag-part z1) (complex-imag-part z2))))
  (define (sub-complex z1 z2)
    (make-from-real-imag (sub (complex-real-part z1) (complex-real-part z2))
                         (sub (complex-imag-part z1) (complex-imag-part z2))))
  (define (mul-complex z1 z2)
    (make-from-mag-ang (mul (complex-magnitude z1) (complex-magnitude z2))
                       (add (complex-angle z1) (complex-angle z2))))
  (define (div-complex z1 z2)
    (make-from-mag-ang (div (complex-magnitude z1) (complex-magnitude z2))
                       (sub (complex-angle z1) (complex-angle z2))))
  (define (equ-complex? z1 z2)
    (and (equ? (complex-real-part z1) (complex-real-part z2))
         (equ? (complex-imag-part z1) (complex-imag-part z2))))
  (define (=zero-complex? x) (=zero? (complex-magnitude x)))
  (define (addd-complex z1 z2 z3)
    (make-from-real-imag (addd (complex-real-part z1)
                               (complex-real-part z2)
                               (complex-real-part z3))
                         (addd (complex-imag-part z1)
                               (complex-imag-part z2)
                               (complex-imag-part z3))))
  …
  ;; interface to rest of the system
  …
  'done)

I've included the addd procedure we added in exercise 2.82 as well for completeness.

Okay, let's see this all in action:

> (square-root (make-integer -1))
(complex rectangular (integer . 0) integer . 1)
> (make-complex-from-real-imag (make-real 3.0) (make-rational 1 2))
(complex rectangular (integer . 3) rational 1 . 2)
> (add (make-complex-from-real-imag (make-integer 4) (make-rational 2 4))
       (make-integer 4))
(complex rectangular (integer . 8) rational 1 . 2)
> (sub (make-complex-from-real-imag (make-real 1.5) (make-integer 3))
       (make-complex-from-real-imag (make-rational 1 2) (make-integer 3)))
(integer . 1)

SICP Exercise 2.85: Simplifying Types

This section mentioned a method for "simplifying" a data object by lowering it in the tower of types as far as possible. Design a procedure drop that accomplishes this for the tower described in exercise 2.83. The key is to decide, in some general way, whether an object can be lowered. For example, the complex number 1.5 + 0i can be lowered as far as real, the complex number 1 + 0i can be lowered as far as integer, and the complex number 2 + 3i cannot be lowered at all. Here is a plan for determining whether an object can be lowered: Begin by defining a generic operation project that "pushes" an object down in the tower. For example, projecting a complex number would involve throwing away the imaginary part. Then a number can be dropped if, when we project it and raise the result back to the type we started with, we end up with something equal to what we started with. Show how to implement this idea in detail, by writing a drop procedure that drops an object as far as possible. You will need to design the various projection operations and install project as a generic operation in the system. You will also need to make use of a generic equality predicate, such as described in exercise 2.79. Finally, use drop to rewrite apply-generic from exercise 2.84 so that it "simplifies" its answers.

The procedure project is very similar in function to raise, except that it pushes objects down the tower of types instead of pulling them up. If we had coercion procedures installed for each type that could coerce an object to the next lowest type in the tower, rounding or discarding components as necessary to force the coercion, then the implementation of project can be based upon raise.

I'm all for repeating patterns that are known to work, so let's give ourselves such coercion procedures. Here's what we want them to do:

• rational->integer needs to compute the nearest integer value that corresponds to the rational number representation. We can achieve this by calculating the result of dividing the numerator by the denominator and then using round to round this appropriately.
• real->rational needs to calculate the nearest rational representation of the real number. Now we're using Scheme's internal real number representation, so we can use a few built-in Scheme procedures to help us... Given a Scheme real number, numerator and denominator will calculate the nearest rational representation for that number and then return their numerator and denominator respectively. However, it will return these as Scheme real numbers, so we need to convert them to Scheme integers before we can make our rational number. The built-in procedure inexact->exact can do this for us. Note that round will not - given a Scheme real number it will round it to the nearest integer value, but will continue to represent it as a Scheme real number, which would fall foul of our integer? checks in make-rational.
• complex->real simply throws away the imaginary part of the complex number.

Here are the corresponding updates to the packages:

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

(define (install-real-package)
  …
  (define (real->rational r) (make-rational (inexact->exact (numerator r))
                                            (inexact->exact (denominator r))))
  …
  (put-coercion 'real 'rational real->rational)
  …
  'done)

(define (install-complex-package)
  ;; imported procedures from rectangular and polar packages
  …
  ;; internal procedures
  …
  (define (complex->real z) (make-real (complex-real-part z)))
  …
  ;; interface to rest of the system
  …
  (put-coercion 'complex 'real complex->real)
  …
  'done)

Okay, so now let's produce project. Our existing raise procedure simply walks through the tower-of-types until it finds a match, finds the coercion procedure that corresponds to that type and the following type in the tower-of-types, and uses that to perform the raise. We should be able to do something similar. There are at least a couple of ways we could achieve this:

• We could pull out apply-raise from our implementation of raise, and then simply have project invoke this with the reverse of the tower-of-types. This would walk through the tower-of-types from highest to lowest type and so would find and apply the coercion procedure corresponding to the type and its next lowest type.
• Alternatively we could simply walk through the tower-of-types in order, as per raise, but check the second element in the remaining types at each iteration to see if it matches the type of our argument. If it does then we know that the next lowest type is the first element in the remaining types and so can find and apply the coercion procedure using these types. This version requires slightly different error checking from the original raise, but is pretty straightforward to implement.

It doesn't really matter which we use, so here's both...

First, here's the solution using reverse, including the changes to raise:

(define (apply-raise x types)
  (cond ((null? types)
         (error "Type not found in the tower-of-types"
                (list (type-tag 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 x (cdr types)))))

(define (raise x)
  (apply-raise x tower-of-types))

(define (project x)
  (apply-raise x (reverse tower-of-types)))

...and here's the solution using an independent implementation of project:

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

They both produce the same results - I've verified this... Here's the results of one of my sets of tests:

> (project (make-real 3.5))
(rational 7 . 2)
> (project (make-rational 7 3))
(integer . 2)
> (raise (project (make-real 3.5)))
(real . 7/2)
> (raise (project (make-rational 7 3)))
(rational 2 . 1)

Now we can move on to drop itself.

This is fairly straightforward and can be achieved recursively by projecting the value passed to it, raiseing the result of this, and then determining whether or not we managed to project it to a lower level successfully. If we did then we can recurse on the projected value; if not then we should return the value unchanged.

Note that testing "whether or not we managed to project it to a lower level successfully" requires two tests:

• We need to check that the result of raiseing the result of projecting the value is equal to the value we started with.
• We also need to remember that project will return the value itself if we are at the bottom of the hierarchy, and so we need to check that the projected value has a different type from the original value. If we don't test this then an infinite loop will result. Why? Well, consider what would happen if we tried to drop an integer in the manner described above, but without testing that project actually changed the type (and before we've made any further changes to apply-generic):
  1. First we would project the value, which would give us back the same integer value.
  2. We would then raise the result of the project, which would give us an equivalent rational value.
  3. We would then check for equality between the integer value and its equivalent raiseed rational using equ?.
  4. This would invoke apply-generic for the operator 'equ?.
  5. This would raise the integer value to a rational and then get and apply the equ? procedure from the rational package, which would return true.
  6. We would now consider the drop to be successful, and so would recurse again. And again. And again...

Anyway, here's drop in all it's glory:

(define (drop x)
  (let* ((dropped (project x))
         (raised (raise dropped)))
    (if (and (not (eq? (type-tag x) (type-tag dropped)))
             (equ? x raised))
        (drop dropped)
        x)))

Let's put it to the test:

> (drop (make-integer 5))
(integer . 5)
> (drop (make-complex-from-real-imag 42 0))
(integer . 42)
> (drop (make-complex-from-real-imag 3/4 0))
(rational 3 . 4)
> (drop (make-real 2.5))
(rational 5 . 2)

Okay, so last step now... Updating apply-generic so it simplifies its answers. The simple way of achieving this is to turn the current apply-generic into an inner procedure, call this, and then drop the result. Of course, we should note that not all installed procedures return a tagged value. After all, we're using equ? as part of drop. So we should only apply drop to the result if we've got a tagged type. We can test that by checking to see if the result is a pair? whose car is in the tower-of-types.

Here's the updated apply-generic:

(define (apply-generic op . args)
  (define (find-and-apply-op)
    (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))))))))
  (let ((result (find-and-apply-op)))
    (if (and (pair? result)
             (memq (type-tag result) tower-of-types))
        (drop result)
        result)))

Let's test it... We'll use addd again, along with other operations:

> (addd (make-rational 1 3) (make-rational 2 3) (make-rational 2 2))
(integer . 2)
> (addd (make-real 3.5) (make-rational 3 2) (make-complex-from-real-imag 5 0))
(integer . 10)
> (add (make-real 4.25) (make-rational 5 2))
(rational 27 . 4)
> (sub (make-complex-from-real-imag 5 2) (make-complex-from-real-imag 2 2))
(integer . 3)

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)))