1 665c255d 2023-08-04 jrmu ;; Exercise 2.79. Define a generic equality predicate equ? that tests the equality of two numbers, and install it in the generic arithmetic package. This operation should work for ordinary numbers, rational numbers, and complex numbers.
3 665c255d 2023-08-04 jrmu ;; Exercise 2.80. Define a generic predicate =zero? that tests if its argument is zero, and install it in the generic arithmetic package. This operation should work for ordinary numbers, rational numbers, and complex numbers.
5 665c255d 2023-08-04 jrmu (define (attach-tag type-tag contents)
6 665c255d 2023-08-04 jrmu (if (eq? type-tag 'scheme-number)
8 665c255d 2023-08-04 jrmu (cons type-tag contents)))
9 665c255d 2023-08-04 jrmu (define (type-tag datum)
10 665c255d 2023-08-04 jrmu (cond ((number? datum) 'scheme-number)
11 665c255d 2023-08-04 jrmu ((pair? datum) (car datum))
12 665c255d 2023-08-04 jrmu ((error "error -- invalid datum" datum))))
13 665c255d 2023-08-04 jrmu (define (contents datum)
14 665c255d 2023-08-04 jrmu (cond ((number? datum) datum)
15 665c255d 2023-08-04 jrmu ((pair? datum) (cdr datum))
16 665c255d 2023-08-04 jrmu ((error "error -- invalid datum" datum))))
18 665c255d 2023-08-04 jrmu (define (make-table)
19 665c255d 2023-08-04 jrmu (define (assoc key records)
20 665c255d 2023-08-04 jrmu (cond ((null? records) false)
21 665c255d 2023-08-04 jrmu ((equal? key (caar records)) (car records))
22 665c255d 2023-08-04 jrmu (else (assoc key (cdr records)))))
23 665c255d 2023-08-04 jrmu (let ((local-table (list '*table*)))
24 665c255d 2023-08-04 jrmu (define (lookup key-1 key-2)
25 665c255d 2023-08-04 jrmu (let ((subtable (assoc key-1 (cdr local-table))))
26 665c255d 2023-08-04 jrmu (if subtable
27 665c255d 2023-08-04 jrmu (let ((record (assoc key-2 (cdr subtable))))
29 665c255d 2023-08-04 jrmu (cdr record)
32 665c255d 2023-08-04 jrmu (define (insert! key-1 key-2 value)
33 665c255d 2023-08-04 jrmu (let ((subtable (assoc key-1 (cdr local-table))))
34 665c255d 2023-08-04 jrmu (if subtable
35 665c255d 2023-08-04 jrmu (let ((record (assoc key-2 (cdr subtable))))
37 665c255d 2023-08-04 jrmu (set-cdr! record value)
38 665c255d 2023-08-04 jrmu (set-cdr! subtable
39 665c255d 2023-08-04 jrmu (cons (cons key-2 value)
40 665c255d 2023-08-04 jrmu (cdr subtable)))))
41 665c255d 2023-08-04 jrmu (set-cdr! local-table
42 665c255d 2023-08-04 jrmu (cons (list key-1
43 665c255d 2023-08-04 jrmu (cons key-2 value))
44 665c255d 2023-08-04 jrmu (cdr local-table)))))
46 665c255d 2023-08-04 jrmu (define (dispatch m)
47 665c255d 2023-08-04 jrmu (cond ((eq? m 'lookup-proc) lookup)
48 665c255d 2023-08-04 jrmu ((eq? m 'insert-proc!) insert!)
49 665c255d 2023-08-04 jrmu (else (error "Unknown operation -- TABLE" m))))
52 665c255d 2023-08-04 jrmu (define operation-table (make-table))
53 665c255d 2023-08-04 jrmu (define get (operation-table 'lookup-proc))
54 665c255d 2023-08-04 jrmu (define put (operation-table 'insert-proc!))
55 665c255d 2023-08-04 jrmu (define coercion-table (make-table))
56 665c255d 2023-08-04 jrmu (define get-coercion (coercion-table 'lookup-proc))
57 665c255d 2023-08-04 jrmu (define put-coercion (coercion-table 'insert-proc!))
59 665c255d 2023-08-04 jrmu (define (add x y) (apply-generic 'add x y))
60 665c255d 2023-08-04 jrmu (define (sub x y) (apply-generic 'sub x y))
61 665c255d 2023-08-04 jrmu (define (mul x y) (apply-generic 'mul x y))
62 665c255d 2023-08-04 jrmu (define (div x y) (apply-generic 'div x y))
63 665c255d 2023-08-04 jrmu (define (equ? x y) (apply-generic 'equ? x y))
64 665c255d 2023-08-04 jrmu (define (=zero? x) (apply-generic '=zero? x))
66 665c255d 2023-08-04 jrmu (define (install-scheme-number-package)
67 665c255d 2023-08-04 jrmu (define (tag x) (attach-tag 'scheme-number x))
68 665c255d 2023-08-04 jrmu (put 'add '(scheme-number scheme-number)
69 665c255d 2023-08-04 jrmu (lambda (x y) (tag (+ x y))))
70 665c255d 2023-08-04 jrmu (put 'sub '(scheme-number scheme-number)
71 665c255d 2023-08-04 jrmu (lambda (x y) (tag (- x y))))
72 665c255d 2023-08-04 jrmu (put 'mul '(scheme-number scheme-number)
73 665c255d 2023-08-04 jrmu (lambda (x y) (tag (* x y))))
74 665c255d 2023-08-04 jrmu (put 'div '(scheme-number scheme-number)
75 665c255d 2023-08-04 jrmu (lambda (x y) (tag (/ x y))))
76 665c255d 2023-08-04 jrmu (put 'equ? '(scheme-number scheme-number) =)
77 665c255d 2023-08-04 jrmu (put '=zero? '(scheme-number) zero?)
78 665c255d 2023-08-04 jrmu (put 'make 'scheme-number
79 665c255d 2023-08-04 jrmu (lambda (n) (tag n)))
82 665c255d 2023-08-04 jrmu (define (install-rational-package)
83 665c255d 2023-08-04 jrmu (define (gcd a b)
86 665c255d 2023-08-04 jrmu (gcd b (remainder a b))))
87 665c255d 2023-08-04 jrmu (define (numer x) (car x))
88 665c255d 2023-08-04 jrmu (define (denom x) (cdr x))
89 665c255d 2023-08-04 jrmu (define (make-rat n d)
90 665c255d 2023-08-04 jrmu (let ((g (gcd n d)))
91 665c255d 2023-08-04 jrmu (cons (/ n g) (/ d g))))
92 665c255d 2023-08-04 jrmu (define (add-rat x y)
93 665c255d 2023-08-04 jrmu (make-rat (+ (* (numer x) (denom y))
94 665c255d 2023-08-04 jrmu (* (numer y) (denom x)))
95 665c255d 2023-08-04 jrmu (* (denom x) (denom y))))
96 665c255d 2023-08-04 jrmu (define (sub-rat x y)
97 665c255d 2023-08-04 jrmu (make-rat (- (* (numer x) (denom y))
98 665c255d 2023-08-04 jrmu (* (numer y) (denom x)))
99 665c255d 2023-08-04 jrmu (* (denom x) (denom y))))
100 665c255d 2023-08-04 jrmu (define (mul-rat x y)
101 665c255d 2023-08-04 jrmu (make-rat (* (numer x) (numer y))
102 665c255d 2023-08-04 jrmu (* (denom x) (denom y))))
103 665c255d 2023-08-04 jrmu (define (div-rat x y)
104 665c255d 2023-08-04 jrmu (make-rat (* (numer x) (denom y))
105 665c255d 2023-08-04 jrmu (* (denom x) (numer y))))
106 665c255d 2023-08-04 jrmu (define (equ-rat? x y)
107 665c255d 2023-08-04 jrmu (and (= (numer x) (numer y))
108 665c255d 2023-08-04 jrmu (= (denom x) (denom y))))
109 665c255d 2023-08-04 jrmu (define (=zero-rat? x) (= (numer x) 0))
110 665c255d 2023-08-04 jrmu (define (tag x) (attach-tag 'rational x))
111 665c255d 2023-08-04 jrmu (put 'add '(rational rational)
112 665c255d 2023-08-04 jrmu (lambda (x y) (tag (add-rat x y))))
113 665c255d 2023-08-04 jrmu (put 'sub '(rational rational)
114 665c255d 2023-08-04 jrmu (lambda (x y) (tag (sub-rat x y))))
115 665c255d 2023-08-04 jrmu (put 'mul '(rational rational)
116 665c255d 2023-08-04 jrmu (lambda (x y) (tag (mul-rat x y))))
117 665c255d 2023-08-04 jrmu (put 'div '(rational rational)
118 665c255d 2023-08-04 jrmu (lambda (x y) (tag (div-rat x y))))
119 665c255d 2023-08-04 jrmu (put 'equ? '(rational rational) equ-rat?)
120 665c255d 2023-08-04 jrmu (put '=zero? '(rational) =zero-rat?)
121 665c255d 2023-08-04 jrmu (put 'make 'rational
122 665c255d 2023-08-04 jrmu (lambda (n d) (tag (make-rat n d))))
125 665c255d 2023-08-04 jrmu (define (install-complex-package)
126 665c255d 2023-08-04 jrmu (define (make-from-real-imag x y)
127 665c255d 2023-08-04 jrmu ((get 'make-from-real-imag 'rectangular) x y))
128 665c255d 2023-08-04 jrmu (define (make-from-mag-ang r a)
129 665c255d 2023-08-04 jrmu ((get 'make-from-mag-ang 'polar) r a))
131 665c255d 2023-08-04 jrmu (define (real-part z) (apply-generic 'real-part z))
132 665c255d 2023-08-04 jrmu (define (imag-part z) (apply-generic 'imag-part z))
133 665c255d 2023-08-04 jrmu (define (magnitude z) (apply-generic 'magnitude z))
134 665c255d 2023-08-04 jrmu (define (angle z) (apply-generic 'angle z))
136 665c255d 2023-08-04 jrmu ;; rectangular and polar representations...
138 665c255d 2023-08-04 jrmu (define (install-complex-rectangular)
139 665c255d 2023-08-04 jrmu (define (make-from-real-imag-rectangular x y)
140 665c255d 2023-08-04 jrmu (cons x y))
141 665c255d 2023-08-04 jrmu (define (make-from-mag-ang-rectangular r a)
142 665c255d 2023-08-04 jrmu (cons (* r (cos a)) (* r (sin a))))
143 665c255d 2023-08-04 jrmu (define (real-part z) (car z))
144 665c255d 2023-08-04 jrmu (define (imag-part z) (cdr z))
145 665c255d 2023-08-04 jrmu (define (magnitude z)
146 665c255d 2023-08-04 jrmu (sqrt (+ (square (real-part z))
147 665c255d 2023-08-04 jrmu (square (imag-part z)))))
148 665c255d 2023-08-04 jrmu (define (angle z) (atan (imag-part z) (real-part z)))
149 665c255d 2023-08-04 jrmu (define (tag x) (attach-tag 'rectangular x))
150 665c255d 2023-08-04 jrmu (put 'real-part '(rectangular) real-part)
151 665c255d 2023-08-04 jrmu (put 'imag-part '(rectangular) imag-part)
152 665c255d 2023-08-04 jrmu (put 'magnitude '(rectangular) magnitude)
153 665c255d 2023-08-04 jrmu (put 'angle '(rectangular) angle)
154 665c255d 2023-08-04 jrmu (put 'make-from-real-imag 'rectangular
155 665c255d 2023-08-04 jrmu (lambda (x y) (tag (make-from-real-imag-rectangular x y))))
156 665c255d 2023-08-04 jrmu (put 'make-from-mag-ang 'rectangular
157 665c255d 2023-08-04 jrmu (lambda (r a) (tag (make-from-mag-ang-rectangular r a))))
159 665c255d 2023-08-04 jrmu (define (install-complex-polar)
160 665c255d 2023-08-04 jrmu (define (make-from-real-imag-polar x y)
161 665c255d 2023-08-04 jrmu (cons (sqrt (+ (square x) (square y)))
162 665c255d 2023-08-04 jrmu (atan y x)))
163 665c255d 2023-08-04 jrmu (define (make-from-mag-ang-polar r a)
164 665c255d 2023-08-04 jrmu (cons r a))
165 665c255d 2023-08-04 jrmu (define (real-part z) (* (magnitude z) (cos (angle z))))
166 665c255d 2023-08-04 jrmu (define (imag-part z) (* (magnitude z) (sin (angle z))))
167 665c255d 2023-08-04 jrmu (define (magnitude z) (car z))
168 665c255d 2023-08-04 jrmu (define (angle z) (cdr z))
169 665c255d 2023-08-04 jrmu (define (tag x) (attach-tag 'polar x))
170 665c255d 2023-08-04 jrmu (put 'real-part '(polar) real-part)
171 665c255d 2023-08-04 jrmu (put 'imag-part '(polar) imag-part)
172 665c255d 2023-08-04 jrmu (put 'magnitude '(polar) magnitude)
173 665c255d 2023-08-04 jrmu (put 'angle '(polar) angle)
174 665c255d 2023-08-04 jrmu (put 'make-from-real-imag 'polar
175 665c255d 2023-08-04 jrmu (lambda (x y) (tag (make-from-real-imag-polar x y))))
176 665c255d 2023-08-04 jrmu (put 'make-from-mag-ang 'polar
177 665c255d 2023-08-04 jrmu (lambda (r a) (tag (make-from-mag-ang-polar r a))))
179 665c255d 2023-08-04 jrmu (install-complex-rectangular)
180 665c255d 2023-08-04 jrmu (install-complex-polar)
181 665c255d 2023-08-04 jrmu ;; end rectangular and polar representations
183 665c255d 2023-08-04 jrmu (define (add-complex z1 z2)
184 665c255d 2023-08-04 jrmu (make-from-real-imag (+ (real-part z1) (real-part z2))
185 665c255d 2023-08-04 jrmu (+ (imag-part z1) (imag-part z2))))
186 665c255d 2023-08-04 jrmu (define (sub-complex z1 z2)
187 665c255d 2023-08-04 jrmu (make-from-real-imag (- (real-part z1) (real-part z2))
188 665c255d 2023-08-04 jrmu (- (imag-part z1) (imag-part z2))))
189 665c255d 2023-08-04 jrmu (define (mul-complex z1 z2)
190 665c255d 2023-08-04 jrmu (make-from-mag-ang (* (magnitude z1) (magnitude z2))
191 665c255d 2023-08-04 jrmu (+ (angle z1) (angle z2))))
192 665c255d 2023-08-04 jrmu (define (div-complex z1 z2)
193 665c255d 2023-08-04 jrmu (make-from-mag-ang (/ (magnitude z1) (magnitude z2))
194 665c255d 2023-08-04 jrmu (- (angle z1) (angle z2))))
195 665c255d 2023-08-04 jrmu (define (equ-complex? z1 z2)
196 665c255d 2023-08-04 jrmu (or (and (= (real-part z1) (real-part z2))
197 665c255d 2023-08-04 jrmu (= (imag-part z1) (imag-part z2))) ;; in case of rounding error
198 665c255d 2023-08-04 jrmu (and (= (magnitude z1) (magnitude z2))
199 665c255d 2023-08-04 jrmu (= (angle z1) (angle z2)))))
200 665c255d 2023-08-04 jrmu (define (=zero-complex? z)
201 665c255d 2023-08-04 jrmu (and (= (real-part z) 0)
202 665c255d 2023-08-04 jrmu (= (imag-part z) 0)))
204 665c255d 2023-08-04 jrmu (define (tag x) (attach-tag 'complex x))
205 665c255d 2023-08-04 jrmu (put 'add '(complex complex)
206 665c255d 2023-08-04 jrmu (lambda (z1 z2) (tag (add-complex z1 z2))))
207 665c255d 2023-08-04 jrmu (put 'sub '(complex complex)
208 665c255d 2023-08-04 jrmu (lambda (z1 z2) (tag (sub-complex z1 z2))))
209 665c255d 2023-08-04 jrmu (put 'mul '(complex complex)
210 665c255d 2023-08-04 jrmu (lambda (z1 z2) (tag (mul-complex z1 z2))))
211 665c255d 2023-08-04 jrmu (put 'div '(complex complex)
212 665c255d 2023-08-04 jrmu (lambda (z1 z2) (tag (div-complex z1 z2))))
213 665c255d 2023-08-04 jrmu (put 'equ? '(complex complex) equ-complex?)
214 665c255d 2023-08-04 jrmu (put '=zero? '(complex) =zero-complex?)
215 665c255d 2023-08-04 jrmu (put 'make-from-real-imag 'complex
216 665c255d 2023-08-04 jrmu (lambda (x y) (tag (make-from-real-imag x y))))
217 665c255d 2023-08-04 jrmu (put 'make-from-mag-ang 'complex
218 665c255d 2023-08-04 jrmu (lambda (r a) (tag (make-from-mag-ang r a))))
221 665c255d 2023-08-04 jrmu (define (make-scheme-number n)
222 665c255d 2023-08-04 jrmu ((get 'make 'scheme-number) n))
223 665c255d 2023-08-04 jrmu (define (make-rational n d)
224 665c255d 2023-08-04 jrmu ((get 'make 'rational) n d))
225 665c255d 2023-08-04 jrmu (define (make-complex-from-real-imag x y)
226 665c255d 2023-08-04 jrmu ((get 'make-from-real-imag 'complex) x y))
227 665c255d 2023-08-04 jrmu (define (make-complex-from-mag-ang r a)
228 665c255d 2023-08-04 jrmu ((get 'make-from-mag-ang 'complex) r a))
231 665c255d 2023-08-04 jrmu ;; install number packages
233 665c255d 2023-08-04 jrmu (install-scheme-number-package)
234 665c255d 2023-08-04 jrmu (install-rational-package)
235 665c255d 2023-08-04 jrmu (install-complex-package)
238 665c255d 2023-08-04 jrmu (define (test-case actual expected)
240 665c255d 2023-08-04 jrmu (display "Actual: ")
241 665c255d 2023-08-04 jrmu (display actual)
243 665c255d 2023-08-04 jrmu (display "Expected: ")
244 665c255d 2023-08-04 jrmu (display expected)
247 665c255d 2023-08-04 jrmu (test-case (equ? (div (make-scheme-number 81)
248 665c255d 2023-08-04 jrmu (mul (make-scheme-number 2)
249 665c255d 2023-08-04 jrmu (make-scheme-number 4.5)))
250 665c255d 2023-08-04 jrmu (add (make-scheme-number 4)
251 665c255d 2023-08-04 jrmu (make-scheme-number 5)))
253 665c255d 2023-08-04 jrmu (test-case (equ? (div (make-rational 4 2)
254 665c255d 2023-08-04 jrmu (make-rational 1 3))
255 665c255d 2023-08-04 jrmu (sub (make-rational 9 1)
256 665c255d 2023-08-04 jrmu (mul (make-rational 4 1)
257 665c255d 2023-08-04 jrmu (make-rational 3 4))))
259 665c255d 2023-08-04 jrmu (test-case (equ? (add (make-complex-from-real-imag 3 4)
260 665c255d 2023-08-04 jrmu (make-complex-from-real-imag -5 -3))
261 665c255d 2023-08-04 jrmu '(complex rectangular -2 . 1))
263 665c255d 2023-08-04 jrmu (test-case (equ? (div (make-scheme-number 80)
264 665c255d 2023-08-04 jrmu (mul (make-scheme-number 2)
265 665c255d 2023-08-04 jrmu (make-scheme-number 4.5)))
266 665c255d 2023-08-04 jrmu (add (make-scheme-number 4)
267 665c255d 2023-08-04 jrmu (make-scheme-number 5)))
269 665c255d 2023-08-04 jrmu (test-case (equ? (div (make-rational 4 3)
270 665c255d 2023-08-04 jrmu (make-rational 1 3))
271 665c255d 2023-08-04 jrmu (sub (make-rational 9 1)
272 665c255d 2023-08-04 jrmu (mul (make-rational 4 1)
273 665c255d 2023-08-04 jrmu (make-rational 3 4))))
275 665c255d 2023-08-04 jrmu (test-case (equ? (add (make-complex-from-real-imag 3 4.5)
276 665c255d 2023-08-04 jrmu (make-complex-from-real-imag -5 -3))
277 665c255d 2023-08-04 jrmu '(complex rectangular -2 . 1))
279 665c255d 2023-08-04 jrmu (test-case (=zero? (sub (div (make-scheme-number 81)
280 665c255d 2023-08-04 jrmu (mul (make-scheme-number 2)
281 665c255d 2023-08-04 jrmu (make-scheme-number 4.5)))
282 665c255d 2023-08-04 jrmu (add (make-scheme-number 4)
283 665c255d 2023-08-04 jrmu (make-scheme-number 5))))
285 665c255d 2023-08-04 jrmu (test-case (=zero? (sub (div (make-rational 4 2)
286 665c255d 2023-08-04 jrmu (make-rational 1 3))
287 665c255d 2023-08-04 jrmu (sub (make-rational 9 1)
288 665c255d 2023-08-04 jrmu (mul (make-rational 4 1)
289 665c255d 2023-08-04 jrmu (make-rational 3 4)))))
291 665c255d 2023-08-04 jrmu (test-case (=zero? (sub (add (make-complex-from-real-imag 3 4)
292 665c255d 2023-08-04 jrmu (make-complex-from-real-imag -5 -3))
293 665c255d 2023-08-04 jrmu '(complex rectangular -2 . 1)))
295 665c255d 2023-08-04 jrmu (test-case (=zero? (sub (div (make-scheme-number 81)
296 665c255d 2023-08-04 jrmu (mul (make-scheme-number 2)
297 665c255d 2023-08-04 jrmu (make-scheme-number 4.5)))
298 665c255d 2023-08-04 jrmu (add (make-scheme-number 3.5)
299 665c255d 2023-08-04 jrmu (make-scheme-number 5))))
301 665c255d 2023-08-04 jrmu (test-case (=zero? (sub (div (make-rational 4 3)
302 665c255d 2023-08-04 jrmu (make-rational 1 3))
303 665c255d 2023-08-04 jrmu (sub (make-rational 9 1)
304 665c255d 2023-08-04 jrmu (mul (make-rational 4 1)
305 665c255d 2023-08-04 jrmu (make-rational 3 4)))))
307 665c255d 2023-08-04 jrmu (test-case (=zero? (sub (add (make-complex-from-real-imag 3 5)
308 665c255d 2023-08-04 jrmu (make-complex-from-real-imag -5 -3))
309 665c255d 2023-08-04 jrmu '(complex rectangular -2 . 1)))
312 665c255d 2023-08-04 jrmu (define (scheme-number->complex n)
313 665c255d 2023-08-04 jrmu (make-complex-from-real-imag (contents n) 0))
314 665c255d 2023-08-04 jrmu (put-coercion 'scheme-number 'complex scheme-number->complex)
316 665c255d 2023-08-04 jrmu (define (apply-generic op . args)
317 665c255d 2023-08-04 jrmu (let ((type-tags (map type-tag args)))
318 665c255d 2023-08-04 jrmu (let ((proc (get op type-tags)))
320 665c255d 2023-08-04 jrmu (apply proc (map contents args))
321 665c255d 2023-08-04 jrmu (if (= (length args) 2)
322 665c255d 2023-08-04 jrmu (let ((type1 (car type-tags))
323 665c255d 2023-08-04 jrmu (type2 (cadr type-tags))
324 665c255d 2023-08-04 jrmu (a1 (car args))
325 665c255d 2023-08-04 jrmu (a2 (cadr args)))
326 665c255d 2023-08-04 jrmu (let ((t1->t2 (get-coercion type1 type2))
327 665c255d 2023-08-04 jrmu (t2->t1 (get-coercion type2 type1)))
328 665c255d 2023-08-04 jrmu (cond (t1->t2
329 665c255d 2023-08-04 jrmu (apply-generic op (t1->t2 a1) a2))
331 665c255d 2023-08-04 jrmu (apply-generic op a1 (t2->t1 a2)))
333 665c255d 2023-08-04 jrmu (display "test")
334 665c255d 2023-08-04 jrmu (error "No method for these types"
335 665c255d 2023-08-04 jrmu (list op type-tags))))))
336 665c255d 2023-08-04 jrmu (error "No method for these types"
337 665c255d 2023-08-04 jrmu (list op type-tags)))))))
340 665c255d 2023-08-04 jrmu (test-case (add (make-scheme-number 5)
341 665c255d 2023-08-04 jrmu (make-complex-from-real-imag 3 2))
342 665c255d 2023-08-04 jrmu '(complex rectangular 8 . 2))
343 665c255d 2023-08-04 jrmu (test-case (add (make-complex-from-mag-ang 5 0.927295218)
344 665c255d 2023-08-04 jrmu (make-scheme-number 2))
345 665c255d 2023-08-04 jrmu '(complex rectangular 5 . 4))
347 665c255d 2023-08-04 jrmu ;; 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.)
349 665c255d 2023-08-04 jrmu (define (apply-generic op . args)
350 665c255d 2023-08-04 jrmu (let* ((type-tags (map type-tag args))
351 665c255d 2023-08-04 jrmu (proc (get op type-tags)))
353 665c255d 2023-08-04 jrmu (apply proc (map contents args))
354 665c255d 2023-08-04 jrmu (let* ((all-coercions ;; 2d-list of coercion procedures
355 665c255d 2023-08-04 jrmu (map (lambda (to-tag)
356 665c255d 2023-08-04 jrmu (map (lambda (from-tag)
357 665c255d 2023-08-04 jrmu (if (equal? from-tag to-tag)
359 665c255d 2023-08-04 jrmu (get-coercion from-tag to-tag)))
360 665c255d 2023-08-04 jrmu type-tags))
361 665c255d 2023-08-04 jrmu type-tags))
362 665c255d 2023-08-04 jrmu (valid-coercions
363 665c255d 2023-08-04 jrmu (filter (lambda (coercions)
364 665c255d 2023-08-04 jrmu (fold-left and #t coercions))
365 665c255d 2023-08-04 jrmu all-coercions)))
366 665c255d 2023-08-04 jrmu ;; #t if same type or if coercion procedure exists
367 665c255d 2023-08-04 jrmu (if (null? valid-coercions)
368 665c255d 2023-08-04 jrmu (error "No method for these types"
369 665c255d 2023-08-04 jrmu (list op type-tags))
370 665c255d 2023-08-04 jrmu (apply apply-generic
372 665c255d 2023-08-04 jrmu (map (lambda (coerce arg)
373 665c255d 2023-08-04 jrmu (if (equal? coerce 'same-tag)
375 665c255d 2023-08-04 jrmu (coerce arg)))
376 665c255d 2023-08-04 jrmu (car valid-coercions)
377 665c255d 2023-08-04 jrmu args))))))))
378 665c255d 2023-08-04 jrmu ;; use the first to-type that all arguments can be coerced to
380 665c255d 2023-08-04 jrmu ;; It might be the case that a mixed-type operation would work where trying to force everything to the same type might not. For example, a contrived operation might work for data types '(float complex int) if we coerce float to complex to get '(complex complex int) but may not work with '(complex complex complex) or '(int int int).
382 665c255d 2023-08-04 jrmu ;; or maybe a supertype might work. Say we want to add '(imaginary real), then we might want to promote both to complex then add
