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)