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 (coercion-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 (define (scheme-number->complex n)
313   (make-complex-from-real-imag (contents n) 0))
314 (put-coercion 'scheme-number 'complex scheme-number->complex)
315 
316 (define (apply-generic op . args)
317   (let ((type-tags (map type-tag args)))
318     (let ((proc (get op type-tags)))
319       (if proc
320 	  (apply proc (map contents args))
321 	  (if (= (length args) 2)
322 	      (let ((type1 (car type-tags))
323 		    (type2 (cadr type-tags))
324 		    (a1 (car args))
325 		    (a2 (cadr args)))
326 		(let ((t1->t2 (get-coercion type1 type2))
327 		      (t2->t1 (get-coercion type2 type1)))
328 		  (cond (t1->t2
329 			 (apply-generic op (t1->t2 a1) a2))
330 			(t2->t1
331 			 (apply-generic op a1 (t2->t1 a2)))
332 			(else
333 			 (display "test")
334 			 (error "No method for these types"
335 				(list op type-tags))))))			
336 	      (error "No method for these types"
337 		     (list op type-tags)))))))
338 
339 
340 (test-case (add (make-scheme-number 5)
341 		(make-complex-from-real-imag 3 2))
342 	   '(complex rectangular 8 . 2))
343 (test-case (add (make-complex-from-mag-ang 5 0.927295218)
344 		(make-scheme-number 2))
345 	   '(complex rectangular 5 . 4))
346 
347 ;; 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.) 
348 
349 (define (apply-generic op . args)
350   (let* ((type-tags (map type-tag args))
351 	 (proc (get op type-tags)))
352       (if proc
353 	  (apply proc (map contents args))
354 	  (let* ((all-coercions ;; 2d-list of coercion procedures
355 		  (map (lambda (to-tag)
356 			 (map (lambda (from-tag)
357 				(if (equal? from-tag to-tag)
358 				    #t
359 				    (get-coercion from-tag to-tag)))
360 			      type-tags)) 
361 		       type-tags))
362 		 (valid-coercions 
363 		  (filter (lambda (coercions) 
364 			    (fold-left and #t coercions))
365 			  all-coercions)))
366 	    ;; #t if same type or if coercion procedure exists
367 	    (if (null? valid-coercions)
368 		(error "No method for these types"
369 		       (list op type-tags))
370 		(apply apply-generic 
371 		       (cons op 
372 			     (map (lambda (coerce arg)
373 				    (if (equal? coerce 'same-tag)
374 					arg
375 					(coerce arg)))
376 				  (car valid-coercions)
377 				  args))))))))
378                        ;; use the first to-type that all arguments can be coerced to
379 
380 ;; 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). 
381 
382 ;; or maybe a supertype might work. Say we want to add '(imaginary real), then we might want to promote both to complex then add