SICP Exercise 2.81: Coercing to the Same Type

Louis Reasoner has noticed that apply-generic may try to coerce the arguments to each other's type even if they already have the same type. Therefore, he reasons, we need to put procedures in the coercion table to "coerce" arguments of each type to their own type. For example, in addition to the scheme-number->complex coercion shown above, he would do:

(define (scheme-number->scheme-number n) n)
(define (complex->complex z) z)
(put-coercion 'scheme-number 'scheme-number
              scheme-number->scheme-number)
(put-coercion 'complex 'complex complex->complex)

1. With Louis's coercion procedures installed, what happens if apply-generic is called with two arguments of type scheme-number or two arguments of type complex for an operation that is not found in the table for those types? For example, assume that we've defined a generic exponentiation operation:

   (define (exp x y) (apply-generic 'exp x y))
   

   and have put a procedure for exponentiation in the Scheme-number package but not in any other package:

   ;; following added to Scheme-number package
   (put 'exp '(scheme-number scheme-number)
        (lambda (x y) (tag (expt x y)))) ; using primitive expt
   

   What happens if we call exp with two complex numbers as arguments?
2. Is Louis correct that something had to be done about coercion with arguments of the same type, or does apply-generic work correctly as is?
3. Modify apply-generic so that it doesn't try coercion if the two arguments have the same type.

(a) Same-Type Arguments, No Matching Operation - What Happens?

Let's do a manual evaluation to see what happens! First, let's start by defining a couple of complex numbers to work with:

(define z1 (make-complex-from-real-imag 1 2))
(define z2 (make-complex-from-real-imag 3 4))

Now let's evaluate (exp z1 z2). As we've done before we'll simplify this evaluation a bit by skipping the details of map and get.

  (exp z1 z2)
= (apply-generic 'exp z1 z2)
= (let ((type-tags (map type-tag (list z1 z2))))
    (let ((proc (get 'exp type-tags)))
      (if proc
          (apply proc (map contents (list z1 z2)))
          (if (= (length (list z1 z2)) 2)
              (let ((type1 (car type-tags))
                    (type2 (cadr type-tags))
                    (a1 (car (list z1 z2)))
                    (a2 (cadr (list z1 z2))))
                (let ((t1->t2 (get-coercion type1 type2))
                      (t2->t1 (get-coercion type2 type1)))
                  (cond (t1->t2
                         (apply-generic 'exp (t1->t2 a1) a2))
                        (t2->t1
                         (apply-generic 'exp a1 (t2->t1 a2)))
                        (else
                         (error "No method for these types"
                                (list 'exp type-tags))))))
              (error "No method for these types"
                     (list 'exp type-tags))))))
= (let ((type-tags '(complex complex)))
    (let ((proc (get 'exp type-tags)))
      (if proc
          (apply proc (map contents (list z1 z2)))
          (if (= (length (list z1 z2)) 2)
              (let ((type1 (car type-tags))
                    (type2 (cadr type-tags))
                    (a1 (car (list z1 z2)))
                    (a2 (cadr (list z1 z2))))
                (let ((t1->t2 (get-coercion type1 type2))
                      (t2->t1 (get-coercion type2 type1)))
                  (cond (t1->t2
                         (apply-generic 'exp (t1->t2 a1) a2))
                        (t2->t1
                         (apply-generic 'exp a1 (t2->t1 a2)))
                        (else
                         (error "No method for these types"
                                (list 'exp type-tags))))))
              (error "No method for these types"
                     (list 'exp type-tags))))))
= (let ((proc (get 'exp '(complex complex))))
    (if proc
        (apply proc (map contents (list z1 z2)))
        (if (= (length (list z1 z2)) 2)
            (let ((type1 (car '(complex complex)))
                  (type2 (cadr '(complex complex)))
                  (a1 (car (list z1 z2)))
                  (a2 (cadr (list z1 z2))))
              (let ((t1->t2 (get-coercion type1 type2))
                    (t2->t1 (get-coercion type2 type1)))
                (cond (t1->t2
                       (apply-generic 'exp (t1->t2 a1) a2))
                      (t2->t1
                       (apply-generic 'exp a1 (t2->t1 a2)))
                      (else
                       (error "No method for these types"
                              (list 'exp '(complex complex)))))))
            (error "No method for these types"
                   (list 'exp '(complex complex))))))
= (let ((proc false))
    (if proc
        (apply proc (map contents (list z1 z2)))
        (if (= (length (list z1 z2)) 2)
            (let ((type1 (car '(complex complex)))
                  (type2 (cadr '(complex complex)))
                  (a1 (car (list z1 z2)))
                  (a2 (cadr (list z1 z2))))
              (let ((t1->t2 (get-coercion type1 type2))
                    (t2->t1 (get-coercion type2 type1)))
                (cond (t1->t2
                       (apply-generic 'exp (t1->t2 a1) a2))
                      (t2->t1
                       (apply-generic 'exp a1 (t2->t1 a2)))
                      (else
                       (error "No method for these types"
                              (list 'exp '(complex complex)))))))
            (error "No method for these types"
                   (list 'exp '(complex complex))))))
= (if false
      (apply false (map contents (list z1 z2)))
      (if (= (length (list z1 z2)) 2)
          (let ((type1 (car '(complex complex)))
                (type2 (cadr '(complex complex)))
                (a1 (car (list z1 z2)))
                (a2 (cadr (list z1 z2))))
            (let ((t1->t2 (get-coercion type1 type2))
                  (t2->t1 (get-coercion type2 type1)))
              (cond (t1->t2
                     (apply-generic 'exp (t1->t2 a1) a2))
                    (t2->t1
                     (apply-generic 'exp a1 (t2->t1 a2)))
                    (else
                     (error "No method for these types"
                            (list 'exp '(complex complex)))))))
          (error "No method for these types"
                 (list 'exp '(complex complex)))))
= (if (= (length (list z1 z2)) 2)
      (let ((type1 (car '(complex complex)))
            (type2 (cadr '(complex complex)))
            (a1 (car (list z1 z2)))
            (a2 (cadr (list z1 z2))))
        (let ((t1->t2 (get-coercion type1 type2))
              (t2->t1 (get-coercion type2 type1)))
          (cond (t1->t2
                 (apply-generic 'exp (t1->t2 a1) a2))
                (t2->t1
                 (apply-generic 'exp a1 (t2->t1 a2)))
                (else
                 (error "No method for these types"
                        (list 'exp '(complex complex)))))))
      (error "No method for these types"
             (list 'exp '(complex complex)))))
= (if (= 2 2)
      (let ((type1 (car '(complex complex)))
            (type2 (cadr '(complex complex)))
            (a1 (car (list z1 z2)))
            (a2 (cadr (list z1 z2))))
        (let ((t1->t2 (get-coercion type1 type2))
              (t2->t1 (get-coercion type2 type1)))
          (cond (t1->t2
                 (apply-generic 'exp (t1->t2 a1) a2))
                (t2->t1
                 (apply-generic 'exp a1 (t2->t1 a2)))
                (else
                 (error "No method for these types"
                        (list 'exp '(complex complex)))))))
      (error "No method for these types"
             (list 'exp '(complex complex)))))
= (if true
      (let ((type1 (car '(complex complex)))
            (type2 (cadr '(complex complex)))
            (a1 (car (list z1 z2)))
            (a2 (cadr (list z1 z2))))
        (let ((t1->t2 (get-coercion type1 type2))
              (t2->t1 (get-coercion type2 type1)))
          (cond (t1->t2
                 (apply-generic 'exp (t1->t2 a1) a2))
                (t2->t1
                 (apply-generic 'exp a1 (t2->t1 a2)))
                (else
                 (error "No method for these types"
                        (list 'exp '(complex complex)))))))
      (error "No method for these types"
             (list 'exp '(complex complex)))))
= (let ((type1 (car '(complex complex)))
        (type2 (cadr '(complex complex)))
        (a1 (car (list z1 z2)))
        (a2 (cadr (list z1 z2))))
    (let ((t1->t2 (get-coercion type1 type2))
          (t2->t1 (get-coercion type2 type1)))
      (cond (t1->t2
             (apply-generic 'exp (t1->t2 a1) a2))
            (t2->t1
             (apply-generic 'exp a1 (t2->t1 a2)))
            (else
             (error "No method for these types"
                    (list 'exp '(complex complex)))))))
= (let ((type1 'complex)
        (type2 'complex)
        (a1 z1)
        (a2 z2))
    (let ((t1->t2 (get-coercion type1 type2))
          (t2->t1 (get-coercion type2 type1)))
      (cond (t1->t2
             (apply-generic 'exp (t1->t2 a1) a2))
            (t2->t1
             (apply-generic 'exp a1 (t2->t1 a2)))
            (else
             (error "No method for these types"
                    (list 'exp '(complex complex)))))))
= (let ((t1->t2 (get-coercion 'complex 'complex))
        (t2->t1 (get-coercion 'complex 'complex)))
    (cond (t1->t2
           (apply-generic 'exp (t1->t2 z1) z2))
          (t2->t1
           (apply-generic 'exp z1 (t2->t1 z2)))
          (else
           (error "No method for these types"
                  (list 'exp '(complex complex))))))
= (let ((t1->t2 complex->complex)
        (t2->t1 complex->complex))
    (cond (t1->t2
           (apply-generic 'exp (t1->t2 z1) z2))
          (t2->t1
           (apply-generic 'exp z1 (t2->t1 z2)))
          (else
           (error "No method for these types"
                  (list 'exp '(complex complex))))))
= (cond (complex->complex
         (apply-generic 'exp (complex->complex z1) z2))
        (complex->complex
         (apply-generic 'exp z1 (complex->complex z2)))
        (else
         (error "No method for these types"
                (list 'exp '(complex complex)))))
= (apply-generic 'exp (complex->complex z1) z2)
= (apply-generic 'exp z1 z2)

At this point we'll stop the evaluation. We're about evaluate (apply-generic 'exp z1 z2). Now if you recall (or if you have a quick peak back up at the start of the evaluation), this matches the second step in our evaluation. This means that we're about to enter an infinite loop!

So there's our answer. If we install same-type coercion procedures in the system then, if no matching procedure can be found for an operation called with a pair of same-type arguments, apply-generic will enter an infinite evaluation loop.

(b) Do We Need Same-Type Coercion?

Strictly speaking, no we don't need to do anything about coercion with arguments of the same type. If an operation is not found in the table for same-type arguments then apply-generic will correctly raise an error.

Let's prove this to ourselves by tracing through the same example as in part (a), but assuming that Louis has not installed the same-type coercion procedure for complex numbers. We'll skip a large number of the initial steps, as they're identical to the evaluation above, and jump in at the point where we try to obtain the coercion procedures.

  (exp z1 z2)
= (apply-generic 'exp z1 z2)
= …
= (let ((t1->t2 (get-coercion 'complex 'complex))
        (t2->t1 (get-coercion 'complex 'complex)))
    (cond (t1->t2
           (apply-generic 'exp (t1->t2 z1) z2))
          (t2->t1
           (apply-generic 'exp z1 (t2->t1 z2)))
          (else
           (error "No method for these types"
                  (list 'exp '(complex complex))))))
= (let ((t1->t2 false)
        (t2->t1 false))
    (cond (t1->t2
           (apply-generic 'exp (t1->t2 z1) z2))
          (t2->t1
           (apply-generic 'exp z1 (t2->t1 z2)))
          (else
           (error "No method for these types"
                  (list 'exp '(complex complex))))))
= (cond (false
         (apply-generic 'exp (t1->t2 z1) z2))
        (false
         (apply-generic 'exp z1 (t2->t1 z2)))
        (else
         (error "No method for these types"
                (list 'exp '(complex complex)))))
= (error "No method for these types"
         (list 'exp '(complex complex)))

So, as you can see, we get the required behaviour.

Note that I said "strictly speaking" above. The procedure is functionally correct. However, it does perform a number of unnecessary operations, particularly extracting the individual arguments and trying to look up coercion procedures. By eliminating these steps we could make the procedure slightly more efficient in this case.

If only we had some excuse to do this.

Oh look, it's part (c)...

(c) Removing Same-Type Coercion from apply-generic

In order to prevent coercion of same-type arguments we can modify apply-generic so that, after it has determined that there are two arguments and it has extracted the types of those arguments, it checks to see if they are of the same type or not before proceeding. If they are then it should raise an error, otherwise it should continue as before.

Programmatically this can be expressed as:

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

SICP Exercise 2.80: Generic Zero Testing

Define a generic predicate =zero? that tests if its argument is zero, and install it in the generic arithmetic package. This operation should work for ordinary numbers, rational numbers, and complex numbers.

Well, we've just written equ?, so we could get away with simply adding procedures to each package that test for equality using the type-specific equ? procedure, setting one of the values to the type's equivalent of zero. I.e. 0 for scheme-number, (make-rat 0 1) for rational and either (make-complex-from-real-imag 0 0) or (make-complex-from-mag-ang 0 0) for complex.

However, for rational and complex numbers we can have a slightly simpler test. Note that any rational number that is equal to zero will have a numerator of 0. Similarly, any complex number that is equal to zero will have a magnitude of 0. Using this approach we don't need to test the denominator for rational numbers, or the angle (or rectangular form components) for complex numbers.

Here's the generic operation and the modifications I made to the packages:

(define (=zero? x) (apply-generic '=zero? x))

(define (install-scheme-number-package)
  …
  (put '=zero? '(scheme-number)
       (lambda (x) (= 0 x)))
  …
  'done)

(define (install-rational-package)
  ;; internal procedures
  …
  (define (=zero? x) (= (numer x) 0))
  …
  ;; interface to rest of the system
  …
  (put '=zero? '(rational) =zero?)
  …
  'done)

(define (install-complex-package)
  ;; imported procedures from rectangular and polar packages
  …
  ;; internal procedures
  …
  (define (=zero? x) (= (complex-magnitude x) 0))
  …
  ;; interface to rest of the system
  …
  (put '=zero? '(complex) =zero?)
  …
  'done)

Similar to the last exercise, if you're wondering about complex-magnitude then have a read of my solution to exercise 2.77.

Let's give it a spin:

> (=zero? (make-scheme-number 4))
#f
> (=zero? (sub (make-scheme-number 3) (make-scheme-number 3)))
#t
> (=zero? (sub (make-rational 1 2) (make-rational 3 2)))
#f
> (=zero? (add (make-rational 1 2) (make-rational -2 4)))
#t
> (=zero? (make-complex-from-real-imag 0 0))
#t
> (=zero? (make-complex-from-mag-ang 0 42))
#t

SICP Exercise 2.79: Generic Equality Testing

Define a generic equality predicate equ? that tests the equality of two numbers, and install it in the generic arithmetic package. This operation should work for ordinary numbers, rational numbers, and complex numbers.

Before we start on figuring out how to test for equality, we should first note a couple of things:

• We're going to build a generic equality predicate here. Predicate is defined in section 1.1.6 as: "used for procedures that return true or false, as well as for expressions that evaluate to true or false." So, unlike all of the procedures defined so far in the packages, a package's implementation of equ? will not be returning a data object of the package's type. As a result we won't need to tag the result of the predicate. This means we can install these procedures directly into the operations table, rather than wrapping it in a λ-function that performs the tagging.
• We're not going to deal with coercion until the next section. As a result we can assume that "This operation should work for ordinary numbers, rational numbers, and complex numbers" means that the operation should work for any pair of numbers of the same type, but that it doesn't need to work for pairs of numbers of different types. This is identical to the behaviour of the existing generic operations.

Okay, so onto the exercise itself...

Firstly, the generic operation itself is straightforward, following the same pattern as the other generic operations:

(define (equ? x y) (apply-generic 'equ? x y))

Next, let's deal with the scheme-number package. This package uses primitive Scheme numbers as its untagged representation and, as the internal procedure we need here will be dealing with the untagged representation, this means that we can use the primitive = procedure to perform the equality test. This can be installed directly into the operations table without a surrounding λ-function because, as noted above, we don't need to mutate the result of this.

Onto the rational package... The set of rational numbers can be formally defined as sets of equivalence classes where each equivalence class is of infinite size. This means that testing for rational number equality normally takes a little bit more than simply checking that the numerators are equal and the denominators are equal; you need to cope with mathematically equal numbers that have different numerators and denominators (such as 1/2 and 2/4). The usual way of achieving this is, for any given pair of rational numbers, n₁/d₁ and n₂/d₂, testing for equality by testing that n₁d₂ = n₂d₁ holds. However, as make-rat reduces any rational number to its canonical representation we can ignore this necessity and do the simple check.

Finally, let's consider the complex package. We have two internal representations we can use for complex numbers: rectangular and polar form. In order to test for equality here it is enough to pick one of the forms and compare the components of that form for equality. So we can either pick rectangular form and so compare the real and imaginary components for equality, or we can pick polar form and so compare the magnitude and angle components for equality. Let's pick the rectangular form.

Okay, so we know how we're going to do it... Here's the changes we make:

(define (install-scheme-number-package)
  …
  (put 'equ? '(scheme-number scheme-number) =)
  …
  'done)

(define (install-rational-package)
  ;; internal procedures
  …
  (define (equ? x y)
    (and (= (numer x) (numer y))
         (= (denom x) (denom y))))
  …
  ;; interface to rest of the system
  …
  (put 'equ? '(rational rational) equ?)
  …
  'done)

(define (install-complex-package)
  ;; imported procedures from rectangular and polar packages
  …
  ;; internal procedures
  …
  (define (equ? z1 z2)
    (and (= (complex-real-part z1) (complex-real-part z2))
         (= (complex-imag-part z1) (complex-imag-part z2))))
  …
  ;; interface to rest of the system
  …
  (put 'equ? '(complex complex) equ?)
  …
  'done)

If you're wondering about the complex- prefix to real-part and imag-part, then have a read of my solution to exercise 2.77 - there's a name clash with the R6RS complex number support.

Okay, so let's see this in action:

> (equ? (make-scheme-number 3) (make-scheme-number 4))
#f
> (equ? (make-scheme-number 5) (make-scheme-number 5))
#t
> (equ? (make-rational 2 3) (make-rational 3 5))
#f
> (equ? (make-rational 1 2) (make-rational 2 4))
#t
> (equ? (make-complex-from-real-imag 1 2) (make-complex-from-real-imag 3 4))
#f
> (equ? (make-complex-from-real-imag 5 6) (make-complex-from-real-imag 5 6))
#t
> (equ? (make-complex-from-mag-ang 2 4) (make-complex-from-mag-ang 6 8))
#f
> (equ? (make-complex-from-mag-ang 1 3) (make-complex-from-mag-ang 1 3))
#t
> (equ? (make-complex-from-real-imag 3 0) (make-complex-from-mag-ang 3 0))
#t