From SICP:
Exercise 2.82
Show how to generalize apply-generic to handle coercion in the general case of multiple arguments. One strategy is to attempt to coerce all the arguments to the type of the first argument, then to the type of the second argument, and so on. Give an example of a situation where this strategy (and likewise the two-argument version given above) is not sufficiently general. (Hint: Consider the case where there are some suitable mixed-type operations present in the table that will not be tried.)
I wrote this part before:
(define fn-registry '())
(define (get op param-types)
(define (rec entry . rest)
(define (all-equal a b)
(if (symbol? a)
(eq? a b)
(and (= (length a) (length b))
(let loop ((x a) (y b))
(or (null? x)
(and (eq? (car x) (car y))
(loop (cdr x) (cdr y))))))))
(let ((op-entry (car entry))
(param-types-entry (cadr entry))
(function-entry (caddr entry)))
(if (and (eq? op-entry op)
(all-equal param-types-entry param-types))
function-entry
(if (null? rest)
false
(apply rec rest)))))
(apply rec fn-registry))
(define (put op param-types fn)
(set! fn-registry (cons (list op param-types fn) fn-registry)))
I wrote this coercion-registry code for this exercise:
(define coercion-registry '())
(define (put-coercion t1 t2 fn) (set! coercion-registry (cons (list t1 t2 fn) coercion-registry)))
(define (get-coercion t1 t2)
(define (rec entry . reg)
(define t1-entry car)
(define t2-entry cadr)
(define fn-entry caddr)
(cond ((and (eq? t1 (t1-entry entry))
(eq? t2 (t2-entry entry))) (fn-entry entry))
((null? reg) false)
(else (apply rec reg))))
(apply rec coercion-registry))
This function takes any set of arguments and coerces them to be the same type:
(define (make-set . args)
(define (rec tested current remains)
(define (coerce-all to-type result items)
(if (null? items)
result
(let ((t1->t2 (get-coercion (type-tag (car items)) to-type)))
(cond ((eq? (type-tag (car items)) to-type)
(coerce-all to-type (cons (car items) result) (cdr items)))
((not t1->t2) false)
(else
(coerce-all to-type (append result (list (t1->t2 (car items)))) (cdr items)))))))
(let ((coerced-all (coerce-all (type-tag current)
'()
(append tested (cons current remains)))))
(cond (coerced-all coerced-all)
((null? remains) false)
(else (rec (append tested (list current)) (car remains) (cdr remains))))))
(rec '() (car args) (cdr args)))
I made some changes to apply-generic as well:
(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))
(let ((coerced-args (apply make-set args)))
(if coerced-args
(apply apply-generic (cons op coerced-args))
(error "No method found for these types" (list op type-tags))))))))
This came from a previous activity:
(define (square x) (* x x))
(define (attach-tag type-tag contents)
(if (or (symbol? contents) (number? contents))
contents
(cons type-tag contents)))
(define (type-tag datum)
(cond ((pair? datum) (car datum))
((number? datum) 'scheme-number)
((symbol? datum) 'scheme-symbol)
(else (error "Bad tagged datum -- TYPE-TAG" datum))))
(define (contents datum)
(cond ((pair? datum) (cdr datum))
((or (number? datum)
(symbol? datum)) datum)
(else (error "Bad tagged datum -- CONTENTS" datum))))
(define (add x y) (apply-generic 'add x y))
(define (sub x y) (apply-generic 'sub x y))
(define (mul x y) (apply-generic 'mul x y))
(define (div x y) (apply-generic 'div x y))
(define (equ? x y) (apply-generic 'equ? x y))
(define (=zero? x) (apply-generic '=zero? x))
(define (install-scheme-number-package)
(define (tag x)
(attach-tag 'scheme-number x))
(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) =)
(put '=zero? '(scheme-number) zero?)
'done)
(define (make-scheme-number n)
((get 'make 'scheme-number) n))
(define (install-rational-package)
;; internal procedures
(define (numer x) (car x))
(define (denom x) (cdr x))
(define (make-rat n d)
(let ((g (gcd n d)))
(cons (/ n g) (/ d g))))
(define (add-rat x y)
(make-rat (+ (* (numer x) (denom y))
(* (numer y) (denom x)))
(* (denom x) (denom y))))
I added just this one function as part of what I needed in order to test apply-generic:
(put 'add-em '(rational rational rational rational) (lambda (a b c d) (add-rat a (add-rat b (add-rat c d)))))
More code from a previous activity:
(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))))
(define (equ?-rat x y)
(and (= (numer x) (numer y))
(= (denom x) (denom y))))
(define (=zero?-rat x) (zero? (numer x)))
;; interface to rest of the system
(define (tag x) (attach-tag 'rational x))
(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 'equ? '(rational rational) equ?-rat)
(put '=zero? '(rational) =zero?-rat)
(put 'make 'rational
(lambda (n d) (tag (make-rat n d))))
'done)
(define (make-rational n d)
((get 'make 'rational) n d))
(define (real-part z) (apply-generic 'real-part z))
(define (imag-part z) (apply-generic 'imag-part z))
(define (magnitude z) (apply-generic 'magnitude z))
(define (angle z) (apply-generic 'angle z))
(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 (+ (real-part z1) (real-part z2))
(+ (imag-part z1) (imag-part z2))))
(define (sub-complex z1 z2)
(make-from-real-imag (- (real-part z1) (real-part z2))
(- (imag-part z1) (imag-part z2))))
(define (mul-complex z1 z2)
(make-from-mag-ang (* (magnitude z1) (magnitude z2))
(+ (angle z1) (angle z2))))
(define (div-complex z1 z2)
(make-from-mag-ang (/ (magnitude z1) (magnitude z2))
(- (angle z1) (angle z2))))
(define (equ?-complex z1 z2)
(and (= (real-part z1) (real-part z2))
(= (imag-part z1) (imag-part z2))))
(define (=zero?-complex z) (and (zero? (real-part z))
(zero? (imag-part z))))
;; interface to rest of the system
(define (tag z) (attach-tag 'complex z))
(put 'add '(complex complex)
(lambda (z1 z2) (tag (add-complex z1 z2))))
(put 'sub '(complex complex)
(lambda (z1 z2) (tag (sub-complex z1 z2))))
(put 'mul '(complex complex)
(lambda (z1 z2) (tag (mul-complex z1 z2))))
(put 'div '(complex complex)
(lambda (z1 z2) (tag (div-complex z1 z2))))
(put 'make-from-real-imag 'complex
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'complex
(lambda (r a) (tag (make-from-mag-ang r a))))
(put 'equ? '(complex complex) equ?-complex)
(put '=zero? '(complex) =zero?-complex)
'done)
(define (install-polar-package)
;; internal procedures
(define (magnitude z) (car z))
(define (angle z) (cdr z))
(define (make-from-mag-ang r a) (cons r a))
(define (real-part z)
(* (magnitude z) (cos (angle z))))
(define (imag-part z)
(* (magnitude z) (sin (angle z))))
(define (make-from-real-imag x y)
(cons (sqrt (+ (square x) (square y)))
(atan y x)))
(define (equ? x y)
(and (= (magnitude x) (magnitude y))
(= (angle x) (angle y))))
(define (=zero? x) (zero? (magnitude x)))
;; interface to the rest of the system
(define (tag x) (attach-tag 'polar x))
(put 'real-part '(polar) real-part)
(put 'imag-part '(polar) imag-part)
(put 'magnitude '(polar) magnitude)
(put 'angle '(polar) angle)
(put 'equ? '(polar polar) equ?)
(put '=zero? '(polar) =zero?)
(put 'make-from-real-imag 'polar
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'polar
(lambda (r a) (tag (make-from-mag-ang r a))))
'done)
(define (install-rectangular-package)
;; internal procedures
(define (real-part z) (car z))
(define (imag-part z) (cdr z))
(define (make-from-real-imag x y) (cons x y))
(define (magnitude z)
(sqrt (+ (square (real-part z))
(square (imag-part z)))))
(define (angle z)
(atan (imag-part z) (real-part z)))
(define (make-from-mag-ang r a)
(cons (* r (cos a)) (* r (sin a))))
(define (equ? x y)
(and (= (real-part x) (real-part y))
(= (imag-part x) (imag-part y))))
(define (=zero? x) (and (zero? (real-part x))
(zero? (imag-part x))))
;; interface to the rest of the system
(define (tag x) (attach-tag 'rectangular x))
(put 'real-part '(rectangular) real-part)
(put 'imag-part '(rectangular) imag-part)
(put 'magnitude '(rectangular) magnitude)
(put 'angle '(rectangular) angle)
(put 'equ? '(rectangular rectangular) equ?)
(put '=zero? '(rectangular) =zero?)
(put 'make-from-real-imag 'rectangular
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'rectangular
(lambda (r a) (tag (make-from-mag-ang r a))))
'done)
(define (make-complex-from-real-imag x y)
((get 'make-from-real-imag 'complex) x y))
(define (make-complex-from-mag-ang r a)
((get 'make-from-mag-ang 'complex) r a))
(install-rational-package)
(install-scheme-number-package)
(install-complex-package)
(install-polar-package)
(install-rectangular-package)
Register the coercion:
(put-coercion 'scheme-number 'rational (lambda (a) (make-rational a 1)))
And finally, the test:
(apply-generic 'add-em (make-rational 3 4) 2 3 4)
There is more code in here than would be necessary to test only the new functionality. I found it easier to test the new apply-generic by including the code from previous examples. I'm sorry that it may make it a bit harder to follow exactly what I'm asking here, but please do your best to give me feedback.
How can I improve this code?
