SICP 2.5 exercises cont.

2.81

a) apply-generic will continue to call itself because at the coercion step, it will call itself with the exact same values as before.

b) There is no need to do anything because apply-generic will either raise an error if there is no procedure that deals with the type, or it will apply the procedure that was found on the arguments.

c)

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

I don’t really get the point of this problem though.

2.82
This is extremely confusing even to me, but it works. Basically two helper procedures are defined. One is for coercing a list of numbers to a target type. The second procedure uses the first to coerce the list to the type of each argument. If there isn’t an available coercion procedure, then skip. When everything is coerced, attempt to apply the generic procedure on the new list immediately. This is in order to prevent an infinite loop.

(define (apply-generic op . args)
  (define (coerce-to target arguments)
    (cond ((null? arguments) '())
          ((eq? (type-tag (car arguments)) target) (cons (car arguments) (coerce-to target (cdr arguments))))
          (else (let ((coerce-proc (get-coercion (type-tag (car arguments)) target)))
                  (if coerce-proc
                      (cons (coerce-proc (car arguments))
                            (coerce-to target (cdr arguments)))
                      (cons (car arguments) (coerce-to target (cdr arguments))))))))
  (define (coerce-all arguments targets-left)
    (if (null? targets-left) arguments
      (coerce-all (coerce-to (car targets-left) arguments) (cdr targets-left))))
  (let ((type-tags (map type-tag args)))
    (let ((proc (get op type-tags)))
      (if proc
          (apply proc (map contents args))
        (let ((coerced-args (coerce-all args type-tags)))
          (if coerced-args
              (let ((coerce-proc (get op (map type-tag coerced-args))))
                (if coerce-proc
                    (apply coerce-proc coerced-args)
                    (error "No method for these types"
                         (list op type-tags))))))))))

I found a very good (but different) answer here. The part I cheated was in answering the discussion question about when the above procedure fails. Point 2 I find especially interesting. When there is only a (complex complex) operation defined, it should be possible to coerce a (scheme-number scheme-number) to it and then use the operation. However the above apply-general procedure does not do that.

2.83

The following go in the relevant install procedures. I skipped implementing real numbers because it isn’t in the examples and probably isn’t trivial. I suppose the raise function would not be hard to implement, but it’s no fun when it isn’t testable.

(define (scheme-number->rational n)
    (make-rational (contents n) 1))
(put 'raise '(scheme-number) scheme-number->rational)  

(define (rational->complex n)
    (make-complex-from-real-imag (/ (numer n)
                                    (denom n))
                                 0))
(put 'raise '(rational) rational->complex)

2.84

(define (apply-generic op . args)
  (define (level-iter n current-level)
    (if (not (get 'raise (list (type-tag n))))
        current-level
      (level-iter (raise n) (+ 1 current-level))))
  (define (level n)
    (level-iter n 0))
  (define (coerce args target-level)
    (cond ((null? args) '())
          ((> (level (car args)) target-level)
           (coerce (cons (raise (car args)) (cdr args)) target-level))
          (else (cons (car args) (coerce (cdr args) target-level)))))
  (let ((type-tags (map type-tag args)))
    (let ((proc (get op type-tags)))
      (if proc
          (apply proc (map contents args))
        (let ((target-level (apply min (map level args))))
          (let ((coerced-args (coerce args target-level)))
            (let ((coerce-proc (get op (map type-tag coerced-args))))
              (if coerce-proc
                  (apply apply-generic (cons op coerced-args))
                (error "No method for these types"
                       (list op type-tags))))))))))

This doesn’t deal with the issue in 2.83, but it’s enough to answer the question.

2.85

As above, the specific project procedures go inside their respective install procedures.

(put 'project '(rational) (lambda (x) (quotient (numer x) (denom x))))
(put 'project '(complex) (lambda (z) (make-rational (real-part z) 1)))

(define (project n) (apply-generic 'project n))
(define (drop n)
  (if (not (get 'project (list (type-tag n))))
      n
    (if (not (equ? n (raise (project n))))
        n
        (drop (project n)))))

Once again real numbers are ignored. It’s also kind of silly because complex numbers never drop down to rational numbers without dropping to scheme-number in my code, because they are simply represented as pairs of integers. I feel I understand the general idea of this section though and I really want to move on.

2.86

Never mind my comments above! Turned out that the silliness was part of the exercise.

(define (install-complex-package)
  ;; imported procedures from rectangular and polar packages
  (define (make-from-real-imag x y)
    ((get 'make-from-real-imag 'rectangular) x y))
  (define (make-from-mag-ang r a)
    ((get 'make-from-mag-ang 'polar) r a))
  ;; internal procedures
  (define (add-complex z1 z2)
    (make-from-real-imag (add (real-part z1) (real-part z2))
                         (add (imag-part z1) (imag-part z2))))
  (define (sub-complex z1 z2)
    (make-from-real-imag (sub (real-part z1) (real-part z2))
                         (sub (imag-part z1) (imag-part z2))))
  (define (mul-complex z1 z2)
    (make-from-mag-ang (mul (magnitude z1) (magnitude z2))
                       (add (angle z1) (angle z2))))
  (define (div-complex z1 z2)
    (make-from-mag-ang (div (magnitude z1) (magnitude z2))
                       (sub (angle z1) (angle z2))))
  (define (equ?-complex z1 z2)
    (and (equ? (real-part z1) (real-part z2))
         (equ? (imag-part z1) (imag-part z2))))
  (define (=zero?-complex z)
    (and (equ? (real-part z) 0)
         (equ? (imag-part z) 0)))

(define (install-rational-package)
  ;; internal procedures
  (define (numer x) (car x))
  (define (denom x) (cdr x))
  (define (make-rat n d)
    (if (and (integer? n) (integer? d))
        (let ((g (gcd (inexact->exact n) (inexact->exact d))))
          (cons (/ n g) (/ d g))))
    (cons n d))
  (define (add-rat x y)
    (make-rat (+ (* (numer x) (denom y))
                 (* (numer y) (denom x)))
              (* (denom x) (denom y))))
  (define (sub-rat x y)
    (make-rat (- (* (numer x) (denom y))
                 (* (numer y) (denom x)))
              (* (denom x) (denom y))))
  (define (mul-rat x y)
    (make-rat (* (numer x) (numer y))
              (* (denom x) (denom y))))
  (define (div-rat x y)
    (make-rat (* (numer x) (denom y))
              (* (denom x) (numer y))))
  ;; interface to rest of the system
  (define (tag x) (attach-tag 'rational x))
  (define (equ?-rational x y)
    (= (/ (numer x) (denom x)) (/ (numer y) (denom y))))
  (define (rational->complex n)
    (make-complex-from-real-imag (tag n)
                                 0))
  (put 'add '(rational rational)
       (lambda (x y) (tag (add-rat x y))))
  (put 'sub '(rational rational)
       (lambda (x y) (tag (sub-rat x y))))
  (put 'mul '(rational rational)
       (lambda (x y) (tag (mul-rat x y))))
  (put 'div '(rational rational)
       (lambda (x y) (tag (div-rat x y))))
  (put 'make 'rational
       (lambda (n d) (tag (make-rat n d))))
  (put 'equ? '(rational rational) equ?-rational)
  (put '=zero? '(rational) (lambda (x) (= 0 (numer x))))
  (put 'add-3 '(rational rational rational)
       (lambda (z1 z2 z3) (tag (add-rat (add-rat z1 z2) z3))))
  (put 'raise '(rational) rational->complex)
  (put 'project '(rational) (lambda (x) (quotient (inexact->exact (numer x)) (inexact->exact (denom x)))))
  (put 'cosine '(rational) (lambda (x) (cos (/ (numer x) (denom x)))))
  (put 'sine '(rational) (lambda (x) (sin (/ (numer x) (denom x)))))
  'done)

(define (install-scheme-number-package)
  (define (tag x)
    (attach-tag 'scheme-number x))
  (define (scheme-number->rational n)
    (make-rational (contents n) 1))
  (put 'add '(scheme-number scheme-number)
       (lambda (x y) (tag (+ x y))))
  (put 'sub '(scheme-number scheme-number)
       (lambda (x y) (tag (- x y))))
  (put 'mul '(scheme-number scheme-number)
       (lambda (x y) (tag (* x y))))
  (put 'div '(scheme-number scheme-number)
       (lambda (x y) (tag (/ x y))))
  (put 'make 'scheme-number
       (lambda (x) (tag x)))
  (put 'equ? '(scheme-number scheme-number)
       (lambda (x y) (= x y)))
  (put '=zero? '(scheme-number)
       (lambda (x) (= x 0)))
  (put 'exp '(scheme-number scheme-number)
     (lambda (x y) (tag (expt x y)))) ; using primitive expt
  (put 'add-3 '(scheme-number scheme-number scheme-number)
       (lambda (x y z) (+ x y z)))
  (put 'raise '(scheme-number) scheme-number->rational)
  (put 'cosine '(scheme-number) cos)
  (put 'sine '(scheme-number) sin)
  'done)

(define (cosine x) (apply-generic 'cosine x))
(define (sine x) (apply-generic 'sine x))

Just posting everything because there where a range of changes. Mostly the packages now use the generic operators instead of the native guile ones. I had to use guile’s inexact->exact procedure to keep gcd happy. The cosine and sine generic procedures are straightforward. I also edited make-rat so that decimal numerators and denominators are allowed for simplicity.

---