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