1 ;; 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. 
2 
3 ;; 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. 
4 
5 (define (attach-tag type-tag contents)
6   (if (eq? type-tag 'scheme-number)
7       contents
8       (cons type-tag contents)))
9 (define (type-tag datum)
10   (cond ((number? datum) 'scheme-number)
11 	((pair? datum) (car datum))
12 	((error "error -- invalid datum" datum))))
13 (define (contents datum)
14   (cond ((number? datum) datum)
15 	((pair? datum) (cdr datum))
16 	((error "error -- invalid datum" datum))))
17 
18 (define (make-table)
19   (define (assoc key records)
20     (cond ((null? records) false)
21 	  ((equal? key (caar records)) (car records))
22 	  (else (assoc key (cdr records)))))
23   (let ((local-table (list '*table*)))
24     (define (lookup key-1 key-2)
25       (let ((subtable (assoc key-1 (cdr local-table))))
26 	(if subtable
27 	    (let ((record (assoc key-2 (cdr subtable))))
28 	      (if record
29 		  (cdr record)
30 		  false))
31 	    false)))
32     (define (insert! key-1 key-2 value)
33       (let ((subtable (assoc key-1 (cdr local-table))))
34 	(if subtable
35 	    (let ((record (assoc key-2 (cdr subtable))))
36 	      (if record
37 		  (set-cdr! record value)
38 		  (set-cdr! subtable
39 			    (cons (cons key-2 value)
40 				  (cdr subtable)))))
41 	    (set-cdr! local-table
42 		      (cons (list key-1
43 				  (cons key-2 value))
44 			    (cdr local-table)))))
45       'ok)
46     (define (dispatch m)
47       (cond ((eq? m 'lookup-proc) lookup)
48 	    ((eq? m 'insert-proc!) insert!)
49 	    (else (error "Unknown operation -- TABLE" m))))
50     dispatch))
51 
52 (define operation-table (make-table))
53 (define get (operation-table 'lookup-proc))
54 (define put (operation-table 'insert-proc!))
55 (define coercion-table (make-table))
56 (define get-coercion (coercion-table 'lookup-proc))
57 (define put-coercion (operation-table 'insert-proc!))
58 
59 (define (add x y) (apply-generic 'add x y))
60 (define (sub x y) (apply-generic 'sub x y))
61 (define (mul x y) (apply-generic 'mul x y))
62 (define (div x y) (apply-generic 'div x y))
63 (define (equ? x y) (apply-generic 'equ? x y))
64 (define (=zero? x) (apply-generic '=zero? x))
65 
66 (define (install-scheme-number-package)
67   (define (tag x) (attach-tag 'scheme-number x))
68   (put 'add '(scheme-number scheme-number)
69        (lambda (x y) (tag (+ x y))))
70   (put 'sub '(scheme-number scheme-number) 
71        (lambda (x y) (tag (- x y))))
72   (put 'mul '(scheme-number scheme-number)
73        (lambda (x y) (tag (* x y))))
74   (put 'div '(scheme-number scheme-number)
75        (lambda (x y) (tag (/ x y))))
76   (put 'equ? '(scheme-number scheme-number) =)
77   (put '=zero? '(scheme-number) zero?)
78   (put 'make 'scheme-number
79        (lambda (n) (tag n)))
80   'done)
81 
82 (define (install-rational-package)
83   (define (gcd a b)
84     (if (= b 0)
85 	a
86 	(gcd b (remainder a b))))
87   (define (numer x) (car x))
88   (define (denom x) (cdr x))
89   (define (make-rat n d)
90     (let ((g (gcd n d)))
91       (cons (/ n g) (/ d g))))
92   (define (add-rat x y)
93     (make-rat (+ (* (numer x) (denom y))
94 		 (* (numer y) (denom x)))
95 	      (* (denom x) (denom y))))
96   (define (sub-rat x y)
97     (make-rat (- (* (numer x) (denom y))
98 		 (* (numer y) (denom x)))
99 	      (* (denom x) (denom y))))
100   (define (mul-rat x y)
101     (make-rat (* (numer x) (numer y))
102 	      (* (denom x) (denom y))))
103   (define (div-rat x y)
104     (make-rat (* (numer x) (denom y))
105 	      (* (denom x) (numer y))))
106   (define (equ-rat? x y)
107     (and (= (numer x) (numer y))
108 	 (= (denom x) (denom y))))
109   (define (=zero-rat? x) (= (numer x) 0))
110   (define (tag x) (attach-tag 'rational x))
111   (put 'add '(rational rational) 
112        (lambda (x y) (tag (add-rat x y))))
113   (put 'sub '(rational rational) 
114        (lambda (x y) (tag (sub-rat x y))))
115   (put 'mul '(rational rational) 
116        (lambda (x y) (tag (mul-rat x y))))
117   (put 'div '(rational rational) 
118        (lambda (x y) (tag (div-rat x y))))
119   (put 'equ? '(rational rational) equ-rat?)
120   (put '=zero? '(rational) =zero-rat?)
121   (put 'make 'rational
122        (lambda (n d) (tag (make-rat n d))))
123   'done)
124 
125 (define (install-complex-package)
126   (define (make-from-real-imag x y)
127     ((get 'make-from-real-imag 'rectangular) x y))
128   (define (make-from-mag-ang r a)
129     ((get 'make-from-mag-ang 'polar) r a))
130 
131   (define (real-part z) (apply-generic 'real-part z))
132   (define (imag-part z) (apply-generic 'imag-part z))
133   (define (magnitude z) (apply-generic 'magnitude z))
134   (define (angle z) (apply-generic 'angle z))
135 
136   ;; rectangular and polar representations...
137 
138   (define (install-complex-rectangular)
139     (define (make-from-real-imag-rectangular x y)
140       (cons x y))
141     (define (make-from-mag-ang-rectangular r a)
142       (cons (* r (cos a)) (* r (sin a))))
143     (define (real-part z) (car z))
144     (define (imag-part z) (cdr z))
145     (define (magnitude z)
146       (sqrt (+ (square (real-part z)) 
147 	       (square (imag-part z)))))
148     (define (angle z) (atan (imag-part z) (real-part z)))
149     (define (tag x) (attach-tag 'rectangular x))
150     (put 'real-part '(rectangular) real-part)
151     (put 'imag-part '(rectangular) imag-part)
152     (put 'magnitude '(rectangular) magnitude)
153     (put 'angle '(rectangular) angle)
154     (put 'make-from-real-imag 'rectangular
155 	 (lambda (x y) (tag (make-from-real-imag-rectangular x y))))
156     (put 'make-from-mag-ang 'rectangular
157 	 (lambda (r a) (tag (make-from-mag-ang-rectangular r a))))
158     'done)
159   (define (install-complex-polar)
160     (define (make-from-real-imag-polar x y)
161       (cons (sqrt (+ (square x) (square y)))
162 	    (atan y x)))
163     (define (make-from-mag-ang-polar r a)
164       (cons r a))
165     (define (real-part z) (* (magnitude z) (cos (angle z))))
166     (define (imag-part z) (* (magnitude z) (sin (angle z))))
167     (define (magnitude z) (car z))
168     (define (angle z) (cdr z))
169     (define (tag x) (attach-tag 'polar x))
170     (put 'real-part '(polar) real-part)
171     (put 'imag-part '(polar) imag-part)
172     (put 'magnitude '(polar) magnitude)
173     (put 'angle '(polar) angle)
174     (put 'make-from-real-imag 'polar
175 	 (lambda (x y) (tag (make-from-real-imag-polar x y))))
176     (put 'make-from-mag-ang 'polar
177 	 (lambda (r a) (tag (make-from-mag-ang-polar r a))))
178     'done)  
179   (install-complex-rectangular)
180   (install-complex-polar)
181   ;; end rectangular and polar representations
182 
183   (define (add-complex z1 z2)
184     (make-from-real-imag (+ (real-part z1) (real-part z2))
185 			 (+ (imag-part z1) (imag-part z2))))
186   (define (sub-complex z1 z2)
187     (make-from-real-imag (- (real-part z1) (real-part z2))
188 			 (- (imag-part z1) (imag-part z2))))
189   (define (mul-complex z1 z2)
190     (make-from-mag-ang (* (magnitude z1) (magnitude z2))
191 		       (+ (angle z1) (angle z2))))
192   (define (div-complex z1 z2)
193     (make-from-mag-ang (/ (magnitude z1) (magnitude z2))
194 		       (- (angle z1) (angle z2))))
195   (define (equ-complex? z1 z2)
196     (or (and (= (real-part z1) (real-part z2))
197 	     (= (imag-part z1) (imag-part z2))) ;; in case of rounding error
198 	(and (= (magnitude z1) (magnitude z2))
199 	     (= (angle z1) (angle z2)))))
200   (define (=zero-complex? z) 
201     (and (= (real-part z) 0)
202 	 (= (imag-part z) 0)))
203 
204   (define (tag x) (attach-tag 'complex x))
205   (put 'add '(complex complex) 
206        (lambda (z1 z2) (tag (add-complex z1 z2))))
207   (put 'sub '(complex complex) 
208        (lambda (z1 z2) (tag (sub-complex z1 z2))))
209   (put 'mul '(complex complex) 
210        (lambda (z1 z2) (tag (mul-complex z1 z2))))
211   (put 'div '(complex complex) 
212        (lambda (z1 z2) (tag (div-complex z1 z2))))
213   (put 'equ? '(complex complex) equ-complex?)
214   (put '=zero? '(complex) =zero-complex?)
215   (put 'make-from-real-imag 'complex 
216        (lambda (x y) (tag (make-from-real-imag x y))))
217   (put 'make-from-mag-ang 'complex 
218        (lambda (r a) (tag (make-from-mag-ang r a))))
219   'done)
220 
221 (define (make-scheme-number n)
222   ((get 'make 'scheme-number) n))
223 (define (make-rational n d)
224   ((get 'make 'rational) n d))
225 (define (make-complex-from-real-imag x y) 
226   ((get 'make-from-real-imag 'complex) x y))
227 (define (make-complex-from-mag-ang r a) 
228   ((get 'make-from-mag-ang 'complex) r a))
229 
230 
231 ;; install number packages
232 
233 (install-scheme-number-package)
234 (install-rational-package)
235 (install-complex-package)
236 
237 
238 (define (test-case actual expected)
239   (newline)
240   (display "Actual:   ")
241   (display actual)
242   (newline)
243   (display "Expected: ")
244   (display expected)
245   (newline))
246 
247 (test-case (equ? (div (make-scheme-number 81)
248 		      (mul (make-scheme-number 2)
249 			   (make-scheme-number 4.5)))
250 		 (add (make-scheme-number 4)
251 		      (make-scheme-number 5)))
252 	   #t)
253 (test-case (equ? (div (make-rational 4 2)
254 		      (make-rational 1 3))
255 		 (sub (make-rational 9 1)
256 		      (mul (make-rational 4 1)
257 			   (make-rational 3 4))))
258 	   #t)
259 (test-case (equ? (add (make-complex-from-real-imag 3 4)
260 		      (make-complex-from-real-imag -5 -3))
261 		 '(complex rectangular -2 . 1))
262 	   #t)
263 (test-case (equ? (div (make-scheme-number 80)
264 		      (mul (make-scheme-number 2)
265 			   (make-scheme-number 4.5)))
266 		 (add (make-scheme-number 4)
267 		      (make-scheme-number 5)))
268 	   #f)
269 (test-case (equ? (div (make-rational 4 3)
270 		      (make-rational 1 3))
271 		 (sub (make-rational 9 1)
272 		      (mul (make-rational 4 1)
273 			   (make-rational 3 4))))
274 	   #f)
275 (test-case (equ? (add (make-complex-from-real-imag 3 4.5)
276 		      (make-complex-from-real-imag -5 -3))
277 		 '(complex rectangular -2 . 1))
278 	   #f)
279 (test-case (=zero? (sub (div (make-scheme-number 81)
280 			     (mul (make-scheme-number 2)
281 				  (make-scheme-number 4.5)))
282 			(add (make-scheme-number 4)
283 			     (make-scheme-number 5))))
284 	   #t)
285 (test-case (=zero? (sub (div (make-rational 4 2)
286 			     (make-rational 1 3))
287 			(sub (make-rational 9 1)
288 			     (mul (make-rational 4 1)
289 				  (make-rational 3 4)))))
290 	   #t)
291 (test-case (=zero? (sub (add (make-complex-from-real-imag 3 4)
292 			     (make-complex-from-real-imag -5 -3))
293 			'(complex rectangular -2 . 1)))
294 	   #t)
295 (test-case (=zero? (sub (div (make-scheme-number 81)
296 			     (mul (make-scheme-number 2)
297 				  (make-scheme-number 4.5)))
298 			(add (make-scheme-number 3.5)
299 			     (make-scheme-number 5))))
300 	   #f)
301 (test-case (=zero? (sub (div (make-rational 4 3)
302 			     (make-rational 1 3))
303 			(sub (make-rational 9 1)
304 			     (mul (make-rational 4 1)
305 				  (make-rational 3 4)))))
306 	   #f)
307 (test-case (=zero? (sub (add (make-complex-from-real-imag 3 5)
308 			     (make-complex-from-real-imag -5 -3))
309 			'(complex rectangular -2 . 1)))
310 	   #f)
311 
312 
313 
314 (define (scheme-number->complex n)
315   (make-complex-from-real-imag (contents n) 0))
316 (put-coercion 'scheme-number 'complex scheme-number->complex)
317 
318 (define (apply-generic op . args)
319   (let ((type-tags (map type-tag args)))
320     (let ((proc (get op type-tags)))
321       (if proc
322 	  (apply proc (map contents args))
323 	  (if (= (length args) 2)
324 	      (let ((type1 (car type-tags))
325 		    (type2 (cadr type-tags))
326 		    (a1 (car args))
327 		    (a2 (cadr args)))
328 		(let ((t1->t2 (get-coercion type1 type2))
329 		      (t2->t1 (get-coercion type2 type1)))
330 		  (cond (t1->t2
331 			 (apply-generic op (t1->t2 a1) a2))
332 			(t2->t1
333 			 (apply-generic op a1 (t2->t1 a2)))
334 			(else
335 			 (error "No method for these types"
336 				(list op type-tags))))))			
337 	      (error "No method for these types"
338 		     (list op type-tags)))))))
339 
340 
341 ;; 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:
342 
343 (define (scheme-number->scheme-number n) n)
344 (define (complex->complex z) z)
345 (put-coercion 'scheme-number 'scheme-number
346               scheme-number->scheme-number)
347 (put-coercion 'complex 'complex complex->complex)
348 
349 ;; 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:
350 
351 (define (exp x y) (apply-generic 'exp x y))
352 
353 ;; and have put a procedure for exponentiation in the Scheme-number package but not in any other package:
354 
355 ;; following added to Scheme-number package
356 (put 'exp '(scheme-number scheme-number)
357      (lambda (x y) (tag (expt x y)))) ; using primitive expt
358 
359 ;; What happens if we call exp with two complex numbers as arguments?
360 
361 ;; 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.
362 
363 ;; 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?
364 
365 ;; 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.
366 
367 ;; c. Modify apply-generic so that it doesn't try coercion if the two arguments have the same type. 
368 
369 (define (apply-generic op . args)
370   (let* ((type-tags (map type-tag args))
371 	 (proc (get op type-tags)))
372     (if proc
373 	(apply proc (map contents args))
374 	(if (and (= (length args) 2)
375 		 (let* ((type1 (car type-tags))
376 			(type2 (cadr type-tags))
377 			(a1 (car args))
378 			(a2 (cadr args))
379 			(t1->t2 (get-coercion type1 type2))
380 			(t2->t1 (get-coercion type2 type1)))
381 		   (cond ((eq? type1 type2) (error "No method for these types"
382 						   (list op args)))
383 			 ;; probably should do some data abstraction instead
384 			 ;; of this ugly hack
385 			 (t1->t2 (apply-generic op (t1->t2 a1) a2))
386 			 (t2->t1 (apply-generic op a1 (t2->t1 a2)))
387 			 (else (error "No method for these types"
388 				      (list op args)))))
389 		 (error "No method for these types"
390 			(list op args))))))
391 
392 ;; 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.)