1 ;; Exercise 2.83.  Suppose you are designing a generic arithmetic system for dealing with the tower of types shown in figure 2.25: integer, rational, real, complex. For each type (except complex), design a procedure that raises objects of that type one level in the tower. Show how to install a generic raise operation that will work for each type (except complex). 
2 
3 ;; we have to modify our packages so that we have 4 types: integer, rational, real, and complex
4 
5 (define (attach-tag type-tag contents)
6   (if (or (eq? type-tag 'integer)
7 	  (eq? type-tag 'real))
8       contents
9       (cons type-tag contents)))
10 (define (type-tag datum)
11   (cond ((pair? datum) (car datum))
12 	((exact? datum) 'integer)
13 	((number? datum) 'real)
14 	((error "error -- invalid datum" datum))))
15 (define (contents datum)
16   (cond ((pair? datum) (cdr datum))
17 	((exact? datum) datum)
18 	((number? datum) (exact->inexact datum))
19 	((error "error -- invalid datum" datum))))
20 
21 (define (make-table)
22   (define (assoc key records)
23     (cond ((null? records) false)
24 	  ((equal? key (caar records)) (car records))
25 	  (else (assoc key (cdr records)))))
26   (let ((local-table (list '*table*)))
27     (define (lookup key-1 key-2)
28       (let ((subtable (assoc key-1 (cdr local-table))))
29 	(if subtable
30 	    (let ((record (assoc key-2 (cdr subtable))))
31 	      (if record
32 		  (cdr record)
33 		  false))
34 	    false)))
35     (define (insert! key-1 key-2 value)
36       (let ((subtable (assoc key-1 (cdr local-table))))
37 	(if subtable
38 	    (let ((record (assoc key-2 (cdr subtable))))
39 	      (if record
40 		  (set-cdr! record value)
41 		  (set-cdr! subtable
42 			    (cons (cons key-2 value)
43 				  (cdr subtable)))))
44 	    (set-cdr! local-table
45 		      (cons (list key-1
46 				  (cons key-2 value))
47 			    (cdr local-table)))))
48       'ok)
49     (define (dispatch m)
50       (cond ((eq? m 'lookup-proc) lookup)
51 	    ((eq? m 'insert-proc!) insert!)
52 	    (else (error "Unknown operation -- TABLE" m))))
53     dispatch))
54 
55 (define operation-table (make-table))
56 (define get (operation-table 'lookup-proc))
57 (define put (operation-table 'insert-proc!))
58 ;; (define coercion-table (make-table))
59 ;; (define get-coercion (coercion-table 'lookup-proc))
60 ;; (define put-coercion (coercion-table 'insert-proc!))
61 
62 (define (add x y) (apply-generic 'add x y))
63 (define (sub x y) (apply-generic 'sub x y))
64 (define (mul x y) (apply-generic 'mul x y))
65 (define (div x y) (apply-generic 'div x y))
66 (define (equ? x y) (apply-generic 'equ? x y))
67 (define (=zero? x) (apply-generic '=zero? x))
68 (define (raise x) (apply-generic 'raise x))
69 
70 (define (install-integer-package)
71   (define (tag x) (attach-tag 'integer x))
72   (put 'add '(integer integer)
73        (lambda (x y) (tag (+ x y))))
74   (put 'sub '(integer integer) 
75        (lambda (x y) (tag (- x y))))
76   (put 'mul '(integer integer)
77        (lambda (x y) (tag (* x y))))
78   (put 'div '(integer integer)
79        (lambda (x y) (tag (quotient x y))))
80   ;; 	 (if (integer? (/ x y))
81   ;; 	     (tag (/ x y))
82   ;; 	     (div (raise (tag x))
83   ;; 		  (raise (tag y))))))
84   ;; ;; we avoided calling make-rational to avoid dependencies
85   (put 'equ? '(integer integer) =)
86   (put '=zero? '(integer) zero?)
87   (put 'make 'integer
88        (lambda (n) 
89 	 (if (exact? n)
90 	     (tag n)
91 	     (error "Not an exact integer" n))))
92   (put 'raise '(integer)
93        (lambda (x) (make-rational x 1)))
94   'done)
95 
96 (define (install-rational-package)
97   (define (gcd a b)
98     (if (= b 0)
99 	a
100 	(gcd b (remainder a b))))
101   (define (numer x) (car x))
102   (define (denom x) (cdr x))
103   (define (make-rat n d)
104     (if (not (and (integer? n) (integer? d)))
105 	(error "Both numerator and denominator must be integers" 
106 	       (list n d))
107 	(let ((g (gcd n d)))
108 	  (cons (/ n g) (/ d g)))))
109   (define (add-rat x y)
110     (make-rat (+ (* (numer x) (denom y))
111 		 (* (numer y) (denom x)))
112 	      (* (denom x) (denom y))))
113   (define (sub-rat x y)
114     (make-rat (- (* (numer x) (denom y))
115 		 (* (numer y) (denom x)))
116 	      (* (denom x) (denom y))))
117   (define (mul-rat x y)
118     (make-rat (* (numer x) (numer y))
119 	      (* (denom x) (denom y))))
120   (define (div-rat x y)
121     (make-rat (* (numer x) (denom y))
122 	      (* (denom x) (numer y))))
123   (define (equ-rat? x y)
124     (and (= (numer x) (numer y))
125 	 (= (denom x) (denom y))))
126   (define (=zero-rat? x) (= (numer x) 0))
127   (define (tag x) (attach-tag 'rational x))
128   (put 'add '(rational rational) 
129        (lambda (x y) (tag (add-rat x y))))
130   (put 'sub '(rational rational) 
131        (lambda (x y) (tag (sub-rat x y))))
132   (put 'mul '(rational rational) 
133        (lambda (x y) (tag (mul-rat x y))))
134   (put 'div '(rational rational) 
135        (lambda (x y) (tag (div-rat x y))))
136   (put 'equ? '(rational rational) equ-rat?)
137   (put '=zero? '(rational) =zero-rat?)
138   (put 'make 'rational
139        (lambda (n d) (tag (make-rat n d))))
140   (put 'raise '(rational)
141        (lambda (x) (make-real (/ (numer x) (denom x)))))
142 
143   'done)
144 
145 (define (install-real-package)
146   (define (tag x) (attach-tag 'real x))
147   (put 'add '(real real)
148        (lambda (x y) (tag (+ x y))))
149   (put 'sub '(real real) 
150        (lambda (x y) (tag (- x y))))
151   (put 'mul '(real real)
152        (lambda (x y) (tag (* x y))))
153   (put 'div '(real real)
154        (lambda (x y) (tag (/ x y))))
155   (put 'equ? '(real real) =)
156   (put '=zero? '(real) zero?)
157   (put 'make 'real
158        (lambda (n) 
159 	 (if (rational? n)
160 	     (tag (exact->inexact n))
161 	     (tag n))))
162   (put 'raise '(real)
163        (lambda (x) (make-complex-from-real-imag x 0)))
164 
165   'done)
166 
167 (define (install-complex-package)
168   (define (make-from-real-imag x y)
169     ((get 'make-from-real-imag 'rectangular) x y))
170   (define (make-from-mag-ang r a)
171     ((get 'make-from-mag-ang 'polar) r a))
172 
173   (define (real-part z) (apply-generic 'real-part z))
174   (define (imag-part z) (apply-generic 'imag-part z))
175   (define (magnitude z) (apply-generic 'magnitude z))
176   (define (angle z) (apply-generic 'angle z))
177 
178   ;; rectangular and polar representations...
179 
180   (define (install-complex-rectangular)
181     (define (make-from-real-imag-rectangular x y)
182       (cons x y))
183     (define (make-from-mag-ang-rectangular r a)
184       (cons (* r (cos a)) (* r (sin a))))
185     (define (real-part z) (car z))
186     (define (imag-part z) (cdr z))
187     (define (magnitude z)
188       (sqrt (+ (square (real-part z)) 
189 	       (square (imag-part z)))))
190     (define (angle z) (atan (imag-part z) (real-part z)))
191     (define (tag x) (attach-tag 'rectangular x))
192     (put 'real-part '(rectangular) real-part)
193     (put 'imag-part '(rectangular) imag-part)
194     (put 'magnitude '(rectangular) magnitude)
195     (put 'angle '(rectangular) angle)
196     (put 'make-from-real-imag 'rectangular
197 	 (lambda (x y) (tag (make-from-real-imag-rectangular x y))))
198     (put 'make-from-mag-ang 'rectangular
199 	 (lambda (r a) (tag (make-from-mag-ang-rectangular r a))))
200     'done)
201   (define (install-complex-polar)
202     (define (make-from-real-imag-polar x y)
203       (cons (sqrt (+ (square x) (square y)))
204 	    (atan y x)))
205     (define (make-from-mag-ang-polar r a)
206       (cons r a))
207     (define (real-part z) (* (magnitude z) (cos (angle z))))
208     (define (imag-part z) (* (magnitude z) (sin (angle z))))
209     (define (magnitude z) (car z))
210     (define (angle z) (cdr z))
211     (define (tag x) (attach-tag 'polar x))
212     (put 'real-part '(polar) real-part)
213     (put 'imag-part '(polar) imag-part)
214     (put 'magnitude '(polar) magnitude)
215     (put 'angle '(polar) angle)
216     (put 'make-from-real-imag 'polar
217 	 (lambda (x y) (tag (make-from-real-imag-polar x y))))
218     (put 'make-from-mag-ang 'polar
219 	 (lambda (r a) (tag (make-from-mag-ang-polar r a))))
220     'done)  
221   (install-complex-rectangular)
222   (install-complex-polar)
223   ;; end rectangular and polar representations
224 
225   (define (add-complex z1 z2)
226     (make-from-real-imag (+ (real-part z1) (real-part z2))
227 			 (+ (imag-part z1) (imag-part z2))))
228   (define (sub-complex z1 z2)
229     (make-from-real-imag (- (real-part z1) (real-part z2))
230 			 (- (imag-part z1) (imag-part z2))))
231   (define (mul-complex z1 z2)
232     (make-from-mag-ang (* (magnitude z1) (magnitude z2))
233 		       (+ (angle z1) (angle z2))))
234   (define (div-complex z1 z2)
235     (make-from-mag-ang (/ (magnitude z1) (magnitude z2))
236 		       (- (angle z1) (angle z2))))
237   (define (equ-complex? z1 z2)
238     (or (and (= (real-part z1) (real-part z2))
239 	     (= (imag-part z1) (imag-part z2))) ;; in case of rounding error
240 	(and (= (magnitude z1) (magnitude z2))
241 	     (= (angle z1) (angle z2)))))
242   (define (=zero-complex? z) 
243     (and (= (real-part z) 0)
244 	 (= (imag-part z) 0)))
245 
246   (define (tag x) (attach-tag 'complex x))
247   (put 'add '(complex complex) 
248        (lambda (z1 z2) (tag (add-complex z1 z2))))
249   (put 'sub '(complex complex) 
250        (lambda (z1 z2) (tag (sub-complex z1 z2))))
251   (put 'mul '(complex complex) 
252        (lambda (z1 z2) (tag (mul-complex z1 z2))))
253   (put 'div '(complex complex) 
254        (lambda (z1 z2) (tag (div-complex z1 z2))))
255   (put 'equ? '(complex complex) equ-complex?)
256   (put '=zero? '(complex) =zero-complex?)
257   (put 'make-from-real-imag 'complex 
258        (lambda (x y) (tag (make-from-real-imag x y))))
259   (put 'make-from-mag-ang 'complex 
260        (lambda (r a) (tag (make-from-mag-ang r a))))
261   'done)
262 
263 (define (install-polynomial-package)
264   (define (tag x) (attach-tag 'polynomial x))
265   'done)
266 
267 
268 
269 (define (make-integer n)
270   ((get 'make 'integer) n))
271 (define (make-rational n d)
272   ((get 'make 'rational) n d))
273 (define (make-real n)
274   ((get 'make 'real) n))
275 (define (make-complex-from-real-imag x y) 
276   ((get 'make-from-real-imag 'complex) x y))
277 (define (make-complex-from-mag-ang r a) 
278   ((get 'make-from-mag-ang 'complex) r a))
279 
280 ;; (define (apply-generic op . args)
281 ;;   (let ((type-tags (map type-tag args)))
282 ;;     (let ((proc (get op type-tags)))
283 ;;       (if proc
284 ;; 	  (apply proc (map contents args))
285 ;; 	  (if (= (length args) 2)
286 ;; 	      (let ((type1 (car type-tags))
287 ;; 		    (type2 (cadr type-tags))
288 ;; 		    (a1 (car args))
289 ;; 		    (a2 (cadr args)))
290 ;; 		(let ((t1->t2 (get-coercion type1 type2))
291 ;; 		      (t2->t1 (get-coercion type2 type1)))
292 ;; 		  (cond (t1->t2
293 ;; 			 (apply-generic op (t1->t2 a1) a2))
294 ;; 			(t2->t1
295 ;; 			 (apply-generic op a1 (t2->t1 a2)))
296 ;; 			(else
297 ;; 			 (error "No method for these types"
298 ;; 				(list op type-tags))))))			
299 ;; 	      (error "No method for these types"
300 ;; 		     (list op type-tags)))))))
301 
302 ;; install number packages
303 
304 (install-integer-package)
305 (install-rational-package)
306 (install-real-package)
307 (install-complex-package)
308 (install-polynomial-package)
309 
310 (define (test-case actual expected)
311   (newline)
312   (display "Actual:   ")
313   (display actual)
314   (newline)
315   (display "Expected: ")
316   (display expected)
317   (newline))
318 
319 (test-case (equ? (add (make-integer 3) (make-integer 4))
320 		 (sub (make-integer 12) (make-integer 5))) #t)
321 (test-case (equ? (div (make-integer 24) (make-integer 4))
322 		 (mul (make-integer 2) (make-integer 3))) #t)
323 (test-case (equ? (add (make-integer 3) (make-integer 3))
324 		 (sub (make-integer 12) (make-integer 5))) #f)
325 (test-case (equ? (div (make-integer 24) (make-integer 4))
326 		 (mul (make-integer 2) (make-integer 2))) #f)
327 (test-case (=zero? (sub (div (make-integer 24) (make-integer 4))
328 		       (mul (make-integer 2) (make-integer 3)))) #t)
329 (test-case (=zero? (sub (div (make-integer 24) (make-integer 4))
330 		       (mul (make-integer 2) (make-integer 4)))) #f)
331 (test-case (make-integer 5) 5)
332 (test-case (type-tag (make-integer 5)) 'integer)
333 (test-case (type-tag (make-real 5)) 'real)
334 (test-case (make-real 1.66667) 1.66667)
335 (test-case (make-real (/ 5 3)) 1.66667)
336 (test-case (type-tag (make-real (/ 5 3))) 'real)
337 
338 (test-case (div (make-integer 3) (make-integer 4)) 0)
339 (test-case (=zero? (sub (make-rational 4 1)
340 		       (div (add (make-rational 1 2)
341 				 (make-rational 3 2))
342 			    (mul (make-rational 3 2)
343 				 (make-rational 2 6))))) #t)
344 (test-case (=zero? (sub (make-rational 4 1)
345 		       (div (add (make-rational 1 2)
346 				 (make-rational 3 2))
347 			    (mul (make-rational 3 2)
348 				 (make-rational 2 5))))) #f)
349 (test-case (equ? (add (make-rational 7 2)
350 		      (make-rational 2 4))
351 		 (div (add (make-rational 1 2)
352 			   (make-rational 3 2))
353 		      (mul (make-rational 3 2)
354 			   (make-rational 2 6)))) #t)
355 (test-case (equ? (add (make-rational 3 2)
356 		      (make-rational 2 4))
357 		 (div (add (make-rational 1 2)
358 			   (make-rational 3 2))
359 		      (mul (make-rational 3 2)
360 			   (make-rational 1 6)))) #f)
361 (test-case (equ? (div (make-rational 4 2)
362 		      (make-rational 1 3))
363 		 (sub (make-rational 9 1)
364 		      (mul (make-rational 4 1)
365 			   (make-rational 3 4)))) #t)
366 (test-case (equ? (div (make-rational 4 2)
367 		      (make-rational 1 3))
368 		 (sub (make-rational 9 1)
369 		      (mul (make-rational 4 1)
370 			   (make-rational 3 5)))) #f)
371 (test-case (equ? (add (make-complex-from-real-imag 3 4)
372 		      (make-complex-from-real-imag -5 -3))
373 		 '(complex rectangular -2 . 1))
374 	   #t)
375 (test-case (equ? (add (make-complex-from-real-imag 3 4.5)
376 		      (make-complex-from-real-imag -5 -3))
377 		 '(complex rectangular -2 . 1))
378 	   #f)
379 (test-case (=zero? (sub (add (make-complex-from-real-imag 3 4)
380 			     (make-complex-from-real-imag -5 -3))
381 			'(complex rectangular -2 . 1)))
382 	   #t)
383 
384 (test-case (=zero? (sub (add (make-complex-from-real-imag 3 5)
385 			     (make-complex-from-real-imag -5 -3))
386 			'(complex rectangular -2 . 1)))
387 	   #f)
388 
389 
390 (test-case (raise (make-integer 5)) '(rational 5 . 1))
391 (test-case (raise (raise (make-integer 5))) 5.)
392 (test-case (raise (raise (raise (make-integer 5)))) '(complex rectangular 5. . 0))
393 
394 (test-case (raise (make-rational 5 3)) 1.666667)
395 (test-case (raise (raise (make-rational 5 3))) '(complex rectangular 1.666667 . 0))
396 
397 ;; Exercise 2.84.  Using the raise operation of exercise 2.83, modify the apply-generic procedure so that it coerces its arguments to have the same type by the method of successive raising, as discussed in this section. You will need to devise a way to test which of two types is higher in the tower. Do this in a manner that is ``compatible'' with the rest of the system and will not lead to problems in adding new levels to the tower. 
398 
399 ;; (define (raise-to-second-type arg1 arg2)
400 ;;   (if (eq? (type-tag arg1) (type-tag arg2))
401 ;;       (cons arg1 arg2)
402 ;;       (let ((raise-proc (get 'raise (list (type-tag arg1)))))
403 ;; 	(if raise-proc
404 ;; 	    (raise-to-second-type (raise-proc (contents arg1)) arg2)
405 ;; 	    #f))))
406 
407 ;; (test-case (raise-to-second-type (make-integer 5)
408 ;; 				 (make-complex-from-real-imag 4 6))
409 ;; 	   '((complex rectangular 5 . 0) . (complex rectangular 4 . 6)))
410 ;; (test-case (raise-to-second-type (make-complex-from-mag-ang 4 3)
411 ;; 				 (make-complex-from-real-imag 2 3))
412 ;; 	   '((complex polar 4 . 3) . (complex rectangular 2 . 3)))
413 ;; (test-case (raise-to-second-type (make-rational 5 3)
414 ;; 				 (make-integer 2))
415 ;; 	   #f)
416 ;; (test-case (raise-to-second-type (make-complex-from-mag-ang 5 3)
417 ;; 				 (make-rational 2 6))
418 ;; 	   #f)
419 ;; (test-case (raise-to-second-type (make-rational 4 2)
420 ;; 				 (make-real 4.5))
421 ;; 	   '(2. . 4.5))
422 
423 ;; (define (apply-generic op . args)
424 ;;   ;; return arg1 raised to same type as arg2, #f if not possible
425 ;;   (define (raise-to-second-type arg1 arg2)
426 ;;     (if (eq? (type-tag arg1) (type-tag arg2))
427 ;; 	(cons arg1 arg2)
428 ;; 	(let ((raise-proc (get 'raise (list (type-tag arg1)))))
429 ;; 	  (if raise-proc
430 ;; 	      (raise-to-second-type (raise-proc (contents arg1)) arg2)
431 ;; 	      #f))))
432 ;;   (let* ((type-tags (map type-tag args))
433 ;; 	 (proc (get op type-tags)))
434 ;;     (if proc
435 ;; 	(apply proc (map contents args))
436 ;; 	(if (= (length args) 2)
437 ;; 	    (let ((a1 (car args))
438 ;; 		  (a2 (cadr args)))
439 ;; 	      (if (eq? (type-tag a1) (type-tag a2))
440 ;; 		  (error "No method for these common types" (list op type-tags))
441 ;; 		  (let ((raised-pair (or (raise-to-second-type a1 a2) 
442 ;; 					 (raise-to-second-type a2 a1))))
443 ;; 		    (if raised-pair
444 ;; 			(let ((raised1 (car raised-pair))
445 ;; 			      (raised2 (cdr raised-pair)))
446 ;; 			  (apply-generic op raised1 raised2))
447 ;; 			(error "No common supertype"
448 ;; 			       (list op type-tags)))))) ;; error messages may not be accurate
449 ;; 	    (error "No method for these (≠2) types"
450 ;; 		   (list op type-tags))))) ;; error messages may not be accurate
451 	      
452 (test-case (add (make-integer 5) (make-rational 3 1))
453 	   (make-rational 8 1))
454 (test-case (div (make-integer 2) (make-real 5))
455 	   0.4)
456 (test-case (mul (make-complex-from-real-imag 3 4)
457 		(make-integer 2))
458 	   ...)
459