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 (operation-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)))
314 665c255d 2023-08-04 jrmu (define (scheme-number->complex n)
315 665c255d 2023-08-04 jrmu (make-complex-from-real-imag (contents n) 0))
316 665c255d 2023-08-04 jrmu (put-coercion 'scheme-number 'complex scheme-number->complex)
318 665c255d 2023-08-04 jrmu (define (apply-generic op . args)
319 665c255d 2023-08-04 jrmu (let ((type-tags (map type-tag args)))
320 665c255d 2023-08-04 jrmu (let ((proc (get op type-tags)))
322 665c255d 2023-08-04 jrmu (apply proc (map contents args))
323 665c255d 2023-08-04 jrmu (if (= (length args) 2)
324 665c255d 2023-08-04 jrmu (let ((type1 (car type-tags))
325 665c255d 2023-08-04 jrmu (type2 (cadr type-tags))
326 665c255d 2023-08-04 jrmu (a1 (car args))
327 665c255d 2023-08-04 jrmu (a2 (cadr args)))
328 665c255d 2023-08-04 jrmu (let ((t1->t2 (get-coercion type1 type2))
329 665c255d 2023-08-04 jrmu (t2->t1 (get-coercion type2 type1)))
330 665c255d 2023-08-04 jrmu (cond (t1->t2
331 665c255d 2023-08-04 jrmu (apply-generic op (t1->t2 a1) a2))
333 665c255d 2023-08-04 jrmu (apply-generic op a1 (t2->t1 a2)))
335 665c255d 2023-08-04 jrmu (error "No method for these types"
336 665c255d 2023-08-04 jrmu (list op type-tags))))))
337 665c255d 2023-08-04 jrmu (error "No method for these types"
338 665c255d 2023-08-04 jrmu (list op type-tags)))))))
341 665c255d 2023-08-04 jrmu ;; Exercise 2.81. Louis Reasoner has noticed that apply-generic may try to coerce the arguments to each other's type even if they already have the same type. Therefore, he reasons, we need to put procedures in the coercion table to "coerce" arguments of each type to their own type. For example, in addition to the scheme-number->complex coercion shown above, he would do:
343 665c255d 2023-08-04 jrmu (define (scheme-number->scheme-number n) n)
344 665c255d 2023-08-04 jrmu (define (complex->complex z) z)
345 665c255d 2023-08-04 jrmu (put-coercion 'scheme-number 'scheme-number
346 665c255d 2023-08-04 jrmu scheme-number->scheme-number)
347 665c255d 2023-08-04 jrmu (put-coercion 'complex 'complex complex->complex)
349 665c255d 2023-08-04 jrmu ;; a. With Louis's coercion procedures installed, what happens if apply-generic is called with two arguments of type scheme-number or two arguments of type complex for an operation that is not found in the table for those types? For example, assume that we've defined a generic exponentiation operation:
351 665c255d 2023-08-04 jrmu (define (exp x y) (apply-generic 'exp x y))
353 665c255d 2023-08-04 jrmu ;; and have put a procedure for exponentiation in the Scheme-number package but not in any other package:
355 665c255d 2023-08-04 jrmu ;; following added to Scheme-number package
356 665c255d 2023-08-04 jrmu (put 'exp '(scheme-number scheme-number)
357 665c255d 2023-08-04 jrmu (lambda (x y) (tag (expt x y)))) ; using primitive expt
359 665c255d 2023-08-04 jrmu ;; What happens if we call exp with two complex numbers as arguments?
361 665c255d 2023-08-04 jrmu ;; the proper procedure will not be found, so apply-generic will look up the coercion procedure to coerce the first complex number to another complex number, then apply the procedure again. This will result in infinite recursion.
363 665c255d 2023-08-04 jrmu ;; b. Is Louis correct that something had to be done about coercion with arguments of the same type, or does apply-generic work correctly as is?
365 665c255d 2023-08-04 jrmu ;; No, Louis is wrong. Nothing needs to be done abotu coercion with arguments of the same type. His coercion procedures actually cause apply-generic to fail; apply-generic works correctly as-is.
367 665c255d 2023-08-04 jrmu ;; c. Modify apply-generic so that it doesn't try coercion if the two arguments have the same type.
369 665c255d 2023-08-04 jrmu (define (apply-generic op . args)
370 665c255d 2023-08-04 jrmu (let* ((type-tags (map type-tag args))
371 665c255d 2023-08-04 jrmu (proc (get op type-tags)))
373 665c255d 2023-08-04 jrmu (apply proc (map contents args))
374 665c255d 2023-08-04 jrmu (if (= (length args) 2)
375 665c255d 2023-08-04 jrmu (let ((type1 (car type-tags))
376 665c255d 2023-08-04 jrmu (type2 (cadr type-tags)))
377 665c255d 2023-08-04 jrmu (if (equal? type1 type2)
378 665c255d 2023-08-04 jrmu (error "No method for these types"
379 665c255d 2023-08-04 jrmu (list op args))
380 665c255d 2023-08-04 jrmu (let ((a1 (car args))
381 665c255d 2023-08-04 jrmu (a2 (cadr args))
382 665c255d 2023-08-04 jrmu (t1->t2 (get-coercion type1 type2))
383 665c255d 2023-08-04 jrmu (t2->t1 (get-coercion type2 type1)))
384 665c255d 2023-08-04 jrmu (cond ((t1->t2 (apply-generic op (t1->t2 a1) a2))
385 665c255d 2023-08-04 jrmu (t2->t1 (apply-generic op a1 (t2->t1 a2)))
386 665c255d 2023-08-04 jrmu (else (error "No method for these types"
387 665c255d 2023-08-04 jrmu (list op args))))))))
388 665c255d 2023-08-04 jrmu (error "No method for these types"
389 665c255d 2023-08-04 jrmu (list op args))))))
391 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.)
