adrianwong programmer · retired coal miner

SICP section 2.5 - systems with generic operations (incomplete)

Admission: exercise 2.86 is as far as I’ll be taking it for this section. I’ve found it tiresome, as most exercises have felt like a variant of:

Learning how to implement a type-based dispatch system in Scheme has been insightful, but wading through two whole sections of this stuff on repeat has defeated me.

Repetitiveness aside, the “object-orienty” feel to the exercises may have also played a part in curbing my enthusiasm. OO is a paradigm I’m already quite comfortable with (plus I get lots of practice writing Java™ at work), so I don’t see much point in dedicating what little free time I have to learning more of it.

I might revisit the remainder of this section at a later date. For now, I’ll forge ahead with the third chapter.

Selected exercises

Exercise 2.77

Recall the definitions of apply-generic and magnitude:

(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))
          (error
            "No method for these types: APPLY-GENERIC"
            (list op type-tags))))))

(define (magnitude z) (apply-generic 'magnitude z))

When Louis tries to evaluate the expression (magnitude z) where z is the object '(complex rectangular 3 . 4), apply-generic first looks up the magnitude operation for the complex type in the table of operations. An error is thrown because it doesn’t exist.

In evaluating the expression (magnitude z), apply-generic is invoked twice. First dispatch is to the magnitude of complex, second is to the magnitude of rectangular.

Exercise 2.78

(define (attach-tag type-tag contents)
  (if (number? contents)
      contents
      (cons type-tag contents)))

(define (type-tag datum)
  (cond ((number? datum) 'scheme-number)
        ((pair? datum) (car datum))
        (else (error "Bad tagged datum: TYPE-TAG" datum))))

(define (contents datum)
  (cond ((number? datum) datum)
        ((pair? datum) (cdr datum))
        (else (error "Bad tagged datum: CONTENTS" datum))))

Note: in the definition of type-tag, we return 'scheme-number if datum is a number. This is to allow apply-generic to look up the appropriate scheme-number operations.

Tests:

(add 3 142)    ; 145
(sub 1468 131) ; 1337

Exercise 2.79

; (install-scheme-number-package)
(put 'equ? '(scheme-number scheme-number)
     (lambda (x y) (= x y)))

; (install-rational-package)
(define (equ-rat? x y)
  (and (= (numer x) (numer y))
       (= (denom x) (denom y))))
(put 'equ? '(rational rational) equ-rat?)

; (install-complex-package)
(define (equ-complex? x y)
  (and (= (real-part x) (real-part y))
       (= (imag-part x) (imag-part y))))
(put 'equ? '(complex complex) equ-complex?)

Exercise 2.80

; (install-scheme-number-package)
(put '=zero? '(scheme-number)
     (lambda (x) (= x 0)))

; (install-rational-package)
(define (=zero-rat? x)
  (= (numer x) 0))
(put '=zero? '(rational) =zero-rat?)

; (install-complex-package)
(define (=zero-complex? x)
  (and (= (real-part x) 0)
       (= (imag-part x) 0)))
(put '=zero? '(complex) =zero-complex?)

Exercise 2.81

Louis would like to add procedures to the coercion table to coerce arguments of each type to their own type:

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

Part (a): the question asks what would happen if we call exp with two complex numbers as arguments, given the following conditions:

(define (exp x y) (apply-generic 'exp x y))
(put 'exp '(scheme-number scheme-number)
     (lambda (x y) (tag (expt x y))))

If we call exp with two arguments of type scheme-number, Louis’ coercion procedure does nothing - it is never called. However, if we call exp with two arguments of type complex, the apply-generic procedure recurses infinitely.

Part (b): no, Louis is wrong (has Louis ever been correct so far?). apply-generic works correctly as-is.

Part (c):

(define (apply-generic op . args)
  (let ((type-tags (map type-tag args)))
    (let ((proc (get op type-tags)))
      (define (no-method) (error "No method for these types"
                                 (list op type-tags)))
      (if proc
          (apply proc (map contents args))
          (if (= (length args) 2)
              (let ((type1 (car type-tags))
                    (type2 (cadr type-tags))
                    (a1 (car args))
                    (a2 (cadr args)))
                (if (equal? type1 type2)
                    (no-method)
                    (let ((t1->t2 (get-coercion type1 type2))
                          (t2->t1 (get-coercion type2 type1)))
                      (cond (t1->t2
                             (apply-generic op (t1->t2 a1) a2))
                            (t2->t1
                             (apply-generic op a1 (t2->t1 a2)))
                            (else (no-method))))))
              (no-method))))))

Exercise 2.82

Implementing the suggested strategy of coercing all the arguments to the type of the first argument, then to the type of the second argument, and so forth:

(define (apply-generic op . args)
  (define (coerce-args type args)
    (map (lambda (x)
           (let ((t1->t2 (get-coercion (type-tag x) type)))
             (if t1->t2 (t1->t2 x) x)))
         args))
  (define (apply-coerced types)
    (if (null? types)
        (error "No method for these types")
        (let ((coerced-args (coerce-args (car types) args)))
          (let ((proc (get op (map type-tag coerced-args))))
            (if proc
                (apply proc (map contents coerced-args))
                (apply-coerced (cdr types)))))))
  (let ((type-tags (map type-tag args)))
    (apply-coerced type-tags)))

Tests:

(add (make-scheme-number 2) (make-scheme-number 4))
; '(scheme-number . 6)

(add (make-scheme-number 1) (make-complex-from-real-imag 2 7))
; '(complex rectangular 3 . 7)

Exercise 2.83

; (install-scheme-number-package)
(define (scheme-number->rational x)
  (make-rational x 1))
(put 'raise 'scheme-number scheme-number->rational)

; (install-rational-package)
(define (rational->real x)
  (make-real (exact->inexact (/ (numer x) (denom x)))))
(put 'raise 'rational rational->real)

; (install-real-package)
(define (real->complex x)
  (make-complex-from-real-imag x 0))
(put 'raise 'real real->complex)

Exercise 2.84

The method I devised to test which of two types is higher in the tower of types is a simple one: assign each type a value. The greater the value, the higher the type is in the tower.

; Install into respective packages
(put 'level 'scheme-number 1)
(put 'level 'rational 2)
(put 'level 'real 3)
(put 'level 'polar 4)
(put 'level 'rectangular 4)
(put 'level 'complex 4)
(define (apply-generic op . args)
  (define (coerce-to-type type arg)
    (let ((lvl1 (get 'level type))
          (lvl2 (get 'level (type-tag arg))))
      (if (< lvl2 lvl1)
          (coerce-to-type type ((get 'raise (type-tag arg))
                                (contents arg)))
          arg)))
  (define (coerce-args type args)
    (map (lambda (x) (coerce-to-type type x)) args))
  (define (apply-coerced types)
    (if (null? types)
        (error "No method for these types")
        (let ((coerced-args (coerce-args (car types) args)))
          (let ((proc (get op (map type-tag coerced-args))))
            (if proc
                (apply proc (map contents coerced-args))
                (apply-coerced (cdr types)))))))
  (let ((type-tags (map type-tag args)))
    (apply-coerced type-tags)))

Tests:

(mul (make-scheme-number 2) (make-scheme-number 4))
; '(scheme-number . 8)

(sub (make-real 6) (make-rational 3 2))
; '(real . 4.5)

(add (make-scheme-number 1) (make-complex-from-real-imag 2 7))
; '(complex rectangular 3.0 . 7)

Exercise 2.85

; (install-scheme-number-package)
(put 'equ? '(scheme-number scheme-number)
     (lambda (x y) (= x y)))

; (install-rational-package)
(define (equ-rat? x y)
  (and (= (numer x) (numer y))
       (= (denom x) (denom y))))
(put 'equ? '(rational rational) equ-rat?)
(define (project x)
  (make-scheme-number (numer x)))
(put 'project 'rational project)

; (install-real-package)
(put 'equ? '(real real)
     (lambda (x y) (= x y)))
(define (project x)
  (make-rational (inexact->exact (numerator x))
                 (inexact->exact (denominator x))))
(put 'project 'real project)

; (install-complex-package)
(define (equ-complex? x y)
  (and (= (real-part x) (real-part y))
       (= (imag-part x) (imag-part y))))
(put 'equ? '(complex complex) equ-complex?)
(define (project x)
  (make-real (real-part x)))
(put 'project 'complex project)

Providing the generic operations project, raise and equ?:

(define (project x)
  (let ((do-project (get 'project (type-tag x))))
    (if do-project
        (do-project (contents x))
        #f)))

(define (raise x)
  (let ((do-raise (get 'raise (type-tag x))))
    (if do-raise
        (do-raise (contents x))
        #f)))

(define (equ? x y)
  (let ((type-tags (list (type-tag x) (type-tag y))))
    (let ((do-equ? (get 'equ? type-tags)))
      (if do-equ?
          (do-equ? (contents x) (contents y))
          #f))))

Note: all three operations return #f if the operation does not exist for a type.

Defining the drop procedure, with some quick tests:

(define (drop x)
  (let ((projected (project x)))
    (if projected
        (let ((re-raised (raise projected)))
          (if (equ? x re-raised)
              (drop projected)
              x))
        x)))

; Tests
(drop (make-complex-from-real-imag 1 0))
; '(scheme-number . 1)

(drop (make-complex-from-real-imag 1.5 0))
; '(rational 3 . 2)
; Opted to allow conversion of a real number to fractions, hence
; why this drops one more level to 'rational, and not to 'real

Rewriting apply-generic so that it “simplifies” its answers:

(define (apply-generic op . args)
  (define (coerce-to-type type arg)
    (let ((lvl1 (get 'level type))
          (lvl2 (get 'level (type-tag arg))))
      (if (< lvl2 lvl1)
          (coerce-to-type type ((get 'raise (type-tag arg))
                                (contents arg)))
          arg)))
  (define (coerce-args type args)
    (map (lambda (x) (coerce-to-type type x)) args))
  (define (apply-coerced types)
    (if (null? types)
        (error "No method for these types")
        (let ((coerced-args (coerce-args (car types) args)))
          (let ((proc (get op (map type-tag coerced-args))))
            (if proc
                (apply proc (map contents coerced-args))
                (apply-coerced (cdr types)))))))
  (let ((type-tags (map type-tag args)))
    (let ((result (apply-coerced type-tags)))
      ; Have to perform this check, as `apply-generic` is also used to
      ; provide generic selectors for the rectangular and polar packages
      ; which return numbers, and therefore cannot be "dropped"
      (if (pair? result)
          (drop result)
          result))))

Tests:

(mul (make-scheme-number 2) (make-scheme-number 4))
; '(scheme-number . 8)

(sub (make-real 6) (make-rational 3 2))
; '(rational 9 . 2)

(add (make-scheme-number 1) (make-complex-from-real-imag 2 7))
; '(complex rectangular 3.0 . 7)

(add (make-real 1.5) (make-complex-from-real-imag 2 0))
; '(rational 7 . 2)

(add (make-rational 3 2) (make-complex-from-real-imag 2 1))
; '(complex rectangular 3.5 . 1)

(sub (make-complex-from-real-imag 7 4) (make-complex-from-real-imag 2 4))
; '(scheme-number . 5)

Exercise 2.86

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, we have to make the following changes to the system: