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 ((integer? datum) 'integer)
12 	((number? datum) 'real)
13 	((pair? datum) (car datum))
14 	((error "error -- invalid datum" datum))))
15 (define (contents datum)
16   (cond ((integer? datum) datum)
17 	((number? datum) (exact->inexact datum))
18 	((pair? datum) (cdr 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 
69 (define (install-integer-package)
70   (define (tag x) (attach-tag 'integer x))
71   (put 'add '(integer integer)
72        (lambda (x y) (tag (+ x y))))
73   (put 'sub '(integer integer) 
74        (lambda (x y) (tag (- x y))))
75   (put 'mul '(integer integer)
76        (lambda (x y) (tag (* x y))))
77   (put 'div '(integer integer)
78        (lambda (x y) (tag (quotient x y))))
79   ;; 	 (if (integer? (/ x y))
80   ;; 	     (tag (/ x y))
81   ;; 	     (div (raise (tag x))
82   ;; 		  (raise (tag y))))))
83   ;; ;; we avoided calling make-rational to avoid dependencies
84   (put 'equ? '(integer integer) =)
85   (put '=zero? '(integer) zero?)
86   (put 'make 'integer
87        (lambda (n) 
88 	 (if (integer? n)
89 	     (tag n)
90 	     (error "Not an integer" n))))
91   (put 'raise 'integer
92        (lambda (x) (make-rational x 1)))
93   'done)
94 
95 (define (install-rational-package)
96   (define (gcd a b)
97     (if (= b 0)
98 	a
99 	(gcd b (remainder a b))))
100   (define (numer x) (car x))
101   (define (denom x) (cdr x))
102   (define (make-rat n d)
103     (if (not (and (integer? n) (integer? d)))
104 	(error "Both numerator and denominator must be integers" 
105 	       (list n d))
106 	(let ((g (gcd n d)))
107 	  (cons (/ n g) (/ d g)))))
108   (define (add-rat x y)
109     (make-rat (+ (* (numer x) (denom y))
110 		 (* (numer y) (denom x)))
111 	      (* (denom x) (denom y))))
112   (define (sub-rat x y)
113     (make-rat (- (* (numer x) (denom y))
114 		 (* (numer y) (denom x)))
115 	      (* (denom x) (denom y))))
116   (define (mul-rat x y)
117     (make-rat (* (numer x) (numer y))
118 	      (* (denom x) (denom y))))
119   (define (div-rat x y)
120     (make-rat (* (numer x) (denom y))
121 	      (* (denom x) (numer y))))
122   (define (equ-rat? x y)
123     (and (= (numer x) (numer y))
124 	 (= (denom x) (denom y))))
125   (define (=zero-rat? x) (= (numer x) 0))
126   (define (tag x) (attach-tag 'rational x))
127   (put 'add '(rational rational) 
128        (lambda (x y) (tag (add-rat x y))))
129   (put 'sub '(rational rational) 
130        (lambda (x y) (tag (sub-rat x y))))
131   (put 'mul '(rational rational) 
132        (lambda (x y) (tag (mul-rat x y))))
133   (put 'div '(rational rational) 
134        (lambda (x y) (tag (div-rat x y))))
135   (put 'equ? '(rational rational) equ-rat?)
136   (put '=zero? '(rational) =zero-rat?)
137   (put 'make 'rational
138        (lambda (n d) (tag (make-rat n d))))
139   (put 'raise 'rational
140        (lambda (x) (make-real (/ (numer x) (denom x)))))
141 
142   'done)
143 
144 (define (install-real-package)
145   (define (tag x) (attach-tag 'real x))
146   (put 'add '(real real)
147        (lambda (x y) (tag (+ x y))))
148   (put 'sub '(real real) 
149        (lambda (x y) (tag (- x y))))
150   (put 'mul '(real real)
151        (lambda (x y) (tag (* x y))))
152   (put 'div '(real real)
153        (lambda (x y) (tag (/ x y))))
154   (put 'equ? '(real real) =)
155   (put '=zero? '(real) zero?)
156   (put 'make 'real
157        (lambda (n) 
158 	 (if (integer? n)
159 	     (tag (exact->inexact n))
160 	     (tag n))))
161 (put 'raise 'real (lambda (x) (make-complex-from-real-imag x 0)))
162 
163   'done)
164 
165 (define (install-complex-package)
166   (define (make-from-real-imag x y)
167     ((get 'make-from-real-imag 'rectangular) x y))
168   (define (make-from-mag-ang r a)
169     ((get 'make-from-mag-ang 'polar) r a))
170 
171   (define (real-part z) (apply-generic 'real-part z))
172   (define (imag-part z) (apply-generic 'imag-part z))
173   (define (magnitude z) (apply-generic 'magnitude z))
174   (define (angle z) (apply-generic 'angle z))
175 
176   ;; rectangular and polar representations...
177 
178   (define (install-complex-rectangular)
179     (define (make-from-real-imag-rectangular x y)
180       (cons x y))
181     (define (make-from-mag-ang-rectangular r a)
182       (cons (* r (cos a)) (* r (sin a))))
183     (define (real-part z) (car z))
184     (define (imag-part z) (cdr z))
185     (define (magnitude z)
186       (sqrt (+ (square (real-part z)) 
187 	       (square (imag-part z)))))
188     (define (angle z) (atan (imag-part z) (real-part z)))
189     (define (tag x) (attach-tag 'rectangular x))
190     (put 'real-part '(rectangular) real-part)
191     (put 'imag-part '(rectangular) imag-part)
192     (put 'magnitude '(rectangular) magnitude)
193     (put 'angle '(rectangular) angle)
194     (put 'make-from-real-imag 'rectangular
195 	 (lambda (x y) (tag (make-from-real-imag-rectangular x y))))
196     (put 'make-from-mag-ang 'rectangular
197 	 (lambda (r a) (tag (make-from-mag-ang-rectangular r a))))
198     'done)
199   (define (install-complex-polar)
200     (define (make-from-real-imag-polar x y)
201       (cons (sqrt (+ (square x) (square y)))
202 	    (atan y x)))
203     (define (make-from-mag-ang-polar r a)
204       (cons r a))
205     (define (real-part z) (* (magnitude z) (cos (angle z))))
206     (define (imag-part z) (* (magnitude z) (sin (angle z))))
207     (define (magnitude z) (car z))
208     (define (angle z) (cdr z))
209     (define (tag x) (attach-tag 'polar x))
210     (put 'real-part '(polar) real-part)
211     (put 'imag-part '(polar) imag-part)
212     (put 'magnitude '(polar) magnitude)
213     (put 'angle '(polar) angle)
214     (put 'make-from-real-imag 'polar
215 	 (lambda (x y) (tag (make-from-real-imag-polar x y))))
216     (put 'make-from-mag-ang 'polar
217 	 (lambda (r a) (tag (make-from-mag-ang-polar r a))))
218     'done)  
219   (install-complex-rectangular)
220   (install-complex-polar)
221   ;; end rectangular and polar representations
222 
223   (define (add-complex z1 z2)
224     (make-from-real-imag (+ (real-part z1) (real-part z2))
225 			 (+ (imag-part z1) (imag-part z2))))
226   (define (sub-complex z1 z2)
227     (make-from-real-imag (- (real-part z1) (real-part z2))
228 			 (- (imag-part z1) (imag-part z2))))
229   (define (mul-complex z1 z2)
230     (make-from-mag-ang (* (magnitude z1) (magnitude z2))
231 		       (+ (angle z1) (angle z2))))
232   (define (div-complex z1 z2)
233     (make-from-mag-ang (/ (magnitude z1) (magnitude z2))
234 		       (- (angle z1) (angle z2))))
235   (define (equ-complex? z1 z2)
236     (or (and (= (real-part z1) (real-part z2))
237 	     (= (imag-part z1) (imag-part z2))) ;; in case of rounding error
238 	(and (= (magnitude z1) (magnitude z2))
239 	     (= (angle z1) (angle z2)))))
240   (define (=zero-complex? z) 
241     (and (= (real-part z) 0)
242 	 (= (imag-part z) 0)))
243 
244   (define (tag x) (attach-tag 'complex x))
245   (put 'add '(complex complex) 
246        (lambda (z1 z2) (tag (add-complex z1 z2))))
247   (put 'sub '(complex complex) 
248        (lambda (z1 z2) (tag (sub-complex z1 z2))))
249   (put 'mul '(complex complex) 
250        (lambda (z1 z2) (tag (mul-complex z1 z2))))
251   (put 'div '(complex complex) 
252        (lambda (z1 z2) (tag (div-complex z1 z2))))
253   (put 'equ? '(complex complex) equ-complex?)
254   (put '=zero? '(complex) =zero-complex?)
255   (put 'make-from-real-imag 'complex 
256        (lambda (x y) (tag (make-from-real-imag x y))))
257   (put 'make-from-mag-ang 'complex 
258        (lambda (r a) (tag (make-from-mag-ang r a))))
259   'done)
260 
261 (define (make-integer n)
262   ((get 'make 'integer) n))
263 (define (make-rational n d)
264   ((get 'make 'rational) n d))
265 (define (make-real n)
266   ((get 'make 'real) n))
267 (define (make-complex-from-real-imag x y) 
268   ((get 'make-from-real-imag 'complex) x y))
269 (define (make-complex-from-mag-ang r a) 
270   ((get 'make-from-mag-ang 'complex) r a))
271 
272 
273 ;; install number packages
274 
275 (install-integer-package)
276 (install-rational-package)
277 (install-real-package)
278 (install-complex-package)
279 
280 
281 (define (test-case actual expected)
282   (newline)
283   (display "Actual:   ")
284   (display actual)
285   (newline)
286   (display "Expected: ")
287   (display expected)
288   (newline))
289 
290 (test-case (equ? (add (make-integer 3) (make-integer 4))
291 		 (sub (make-integer 12) (make-integer 5))) #t)
292 (test-case (equ? (div (make-integer 24) (make-integer 4))
293 		 (mul (make-integer 2) (make-integer 3))) #t)
294 (test-case (equ? (add (make-integer 3) (make-integer 3))
295 		 (sub (make-integer 12) (make-integer 5))) #f)
296 (test-case (equ? (div (make-integer 24) (make-integer 4))
297 		 (mul (make-integer 2) (make-integer 2))) #f)
298 (test-case (=zero? (sub (div (make-integer 24) (make-integer 4))
299 		       (mul (make-integer 2) (make-integer 3)))) #t)
300 (test-case (=zero? (sub (div (make-integer 24) (make-integer 4))
301 		       (mul (make-integer 2) (make-integer 4)))) #f)
302 (test-case (make-integer 5) 5)
303 (test-case (type-tag (make-integer 5)) 'integer)
304 (test-case (type-tag (make-real 5)) 'integer) ;; automatically drops
305 (test-case (make-real 1.66667) 1.66667)
306 ;; (test-case (make-real (/ 5 3)) 1.66667) fails
307 
308 (test-case (div (make-integer 3) (make-integer 4)) 0)
309 (test-case (=zero? (sub (make-rational 4 1)
310 		       (div (add (make-rational 1 2)
311 				 (make-rational 3 2))
312 			    (mul (make-rational 3 2)
313 				 (make-rational 2 6))))) #t)
314 (test-case (=zero? (sub (make-rational 4 1)
315 		       (div (add (make-rational 1 2)
316 				 (make-rational 3 2))
317 			    (mul (make-rational 3 2)
318 				 (make-rational 2 5))))) #f)
319 (test-case (equ? (add (make-rational 7 2)
320 		      (make-rational 2 4))
321 		 (div (add (make-rational 1 2)
322 			   (make-rational 3 2))
323 		      (mul (make-rational 3 2)
324 			   (make-rational 2 6)))) #t)
325 (test-case (equ? (add (make-rational 3 2)
326 		      (make-rational 2 4))
327 		 (div (add (make-rational 1 2)
328 			   (make-rational 3 2))
329 		      (mul (make-rational 3 2)
330 			   (make-rational 1 6)))) #f)
331 (test-case (equ? (div (make-rational 4 2)
332 		      (make-rational 1 3))
333 		 (sub (make-rational 9 1)
334 		      (mul (make-rational 4 1)
335 			   (make-rational 3 4)))) #t)
336 (test-case (equ? (div (make-rational 4 2)
337 		      (make-rational 1 3))
338 		 (sub (make-rational 9 1)
339 		      (mul (make-rational 4 1)
340 			   (make-rational 3 5)))) #f)
341 (test-case (equ? (add (make-complex-from-real-imag 3 4)
342 		      (make-complex-from-real-imag -5 -3))
343 		 '(complex rectangular -2 . 1))
344 	   #t)
345 (test-case (equ? (add (make-complex-from-real-imag 3 4.5)
346 		      (make-complex-from-real-imag -5 -3))
347 		 '(complex rectangular -2 . 1))
348 	   #f)
349 (test-case (=zero? (sub (add (make-complex-from-real-imag 3 4)
350 			     (make-complex-from-real-imag -5 -3))
351 			'(complex rectangular -2 . 1)))
352 	   #t)
353 
354 (test-case (=zero? (sub (add (make-complex-from-real-imag 3 5)
355 			     (make-complex-from-real-imag -5 -3))
356 			'(complex rectangular -2 . 1)))
357 	   #f)
358 
359 
360 ;; (test-case (=zero? (sub (div (make-rational 4 3)
361 ;; 			     (make-rational 1 3))
362 ;; 			(sub (make-rational 9 1)
363 ;; 			     (mul (make-rational 4 1)
364 ;; 				  (make-rational 3 4)))))
365 ;; 	   #f)
366 ;; (test-case (=zero? (sub (add (make-complex-from-real-imag 3 5)
367 ;; 			     (make-complex-from-real-imag -5 -3))
368 ;; 			'(complex rectangular -2 . 1)))
369 ;; 	   #f)
370 
371 ;; (define (scheme-number->complex n)
372 ;;   (make-complex-from-real-imag (contents n) 0))
373 ;; (put-coercion 'scheme-number 'complex scheme-number->complex)
374 
375 (define (apply-generic op . args)
376   (let ((type-tags (map type-tag args)))
377     (let ((proc (get op type-tags)))
378       (if proc
379 	  (apply proc (map contents args))
380 	  (if (= (length args) 2)
381 	      (let ((type1 (car type-tags))
382 		    (type2 (cadr type-tags))
383 		    (a1 (car args))
384 		    (a2 (cadr args)))
385 		(let ((t1->t2 (get-coercion type1 type2))
386 		      (t2->t1 (get-coercion type2 type1)))
387 		  (cond (t1->t2
388 			 (apply-generic op (t1->t2 a1) a2))
389 			(t2->t1
390 			 (apply-generic op a1 (t2->t1 a2)))
391 			(else
392 			 (error "No method for these types"
393 				(list op type-tags))))))			
394 	      (error "No method for these types"
395 		     (list op type-tags)))))))
396 
397 
398 ;; (test-case (add (make-scheme-number 5)
399 ;; 		(make-complex-from-real-imag 3 2))
400 ;; 	   '(complex rectangular 8 . 2))
401 ;; (test-case (add (make-complex-from-mag-ang 5 0.927295218)
402 ;; 		(make-scheme-number 2))
403 ;; 	   '(complex rectangular 5 . 4))
404 
405 
406 (define (raise x) (apply-generic 'raise x))
407