There are 3 changes to make. The first is for apply-generic to use the new drop procedure. Note that it doesn’t make sense to drop the result of all generic operations, for example predicates, and that drop is only called after any type coercion using raise has completed.
(define (apply-generic op . args)
; only certain operations will result in an answer that can be
; projected e.g. it makes no sense to project the answer to zero?
(define (reduce-type x)
(cond ((eq? op 'add) (drop x))
((eq? op 'sub) (drop x))
((eq? op 'mul) (drop x))
((eq? op 'div) (drop x))
(else x)))
; find the highest type level of a list of arguments
(define (highest-type-level args)
(if (null? args)
0
(let ((level (type-level (car args)))
(highest (highest-type-level (cdr args))))
(if (> level highest)
level
highest))))
; raise arg to the same level as target-type-level
(define (raise-to arg target-type-level)
(define (raise-iter current-arg)
(let ((arg-level (type-level current-arg)))
(cond ((= arg-level target-type-level) current-arg)
((< arg-level target-type-level) (raise-iter (apply-generic 'raise current-arg)))
(else (error "Cannot raise argument to a lower type target" arg target-type-level)))))
(raise-iter arg))
; raise all args to a common type (the highest in the tower of types)
; and apply the operator to them
(define (apply-with-raised-types args)
(let ((target-type-level (highest-type-level args)))
(apply apply-generic
op
(map (lambda (arg)
(raise-to arg target-type-level))
args))))
(let* ((type-tags (map type-tag args))
(proc (get op type-tags)))
(if proc
(reduce-type (apply proc (map contents args)))
(apply-with-raised-types args))))
Second implement drop and the top-level generic project.
(define (project z) (apply-generic 'project z))
(define (drop z)
(if (= (type-level z) 1)
z
(let ((projected (project z)))
(if (equ? z (raise projected))
(drop projected)
z))))
Third, add type specific project procedures for each type that can project.
; in the rational package
(define (project r)
(make-integer (truncate (/ (numer r) (denom r)))))
(put 'project '(rational) (lambda (x) (project x)))
...
...
; in the real package - this is a bit messy because real numbers can be either integers, rational or irrational.
(define (project r)
(let ((exact (inexact->exact r)))
(cond ((integer? exact) (make-rational exact 1))
((rational? exact) (make-rational (numerator exact) (denominator exact)))
(else (make-rational (truncate exact) 1)))))
(put 'project '(real) (lambda (x) (project x)))
...
...
; in the complex package
(define (project z1)
(make-real (real-part z1)))
(put 'project '(complex) (lambda (x) (project x)))
Finally, some tests.
(display (drop (make-complex-from-real-imag 4 0))) 4 (display (drop (make-complex-from-real-imag 4 2))) (complex rectangular 4 . 2) (display (drop (make-complex-from-real-imag 7.5 0))) (rational 15 . 2) (display (drop (make-complex-from-real-imag 3.1415 0))) (rational 7074029114692207 . 2251799813685248) (display (drop (make-complex-from-real-imag (sqrt 2) 0))) (rational 6369051672525773 . 4503599627370496) (display (drop (make-real (atan 3.1415)))) (rational 2843164624011921 . 2251799813685248) (display (drop (make-rational 7 1))) 7 (display (drop (make-rational 7 3))) (rational 7 . 3) (display (add (make-complex-from-real-imag 4 0) (make-integer 9))) 13 (display (add (make-complex-from-real-imag 4 2) (make-integer 9))) (complex rectangular 13 . 2) (display (sub (make-complex-from-mag-ang 5 0) (make-rational 9 3))) 2 (display (mul (make-real (/ 2 1111111)) (make-rational 9 3))) (rational 6 . 1111111) (display (div (make-real (/ 2 1111111)) (make-rational 9 3))) (rational 2 . 3333333)
I can’t get the real type to fail to drop as the scheme version I’m using seems to convert every real number into a rational. I could write a conversion from real to rational that only works to a certain precision e.g. 4 decimal places, but this exercise was already long enough.
SICP exercises 