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 (define (project x) (apply-generic 'project x))
63 
64 
65 (define (install-integer-package)
66   (define (tag x) (attach-tag 'integer x))
67   (put 'add '(integer integer)
68        (lambda (x y) (tag (+ x y))))
69   (put 'sub '(integer integer) 
70        (lambda (x y) (tag (- x y))))
71   (put 'mul '(integer integer)
72        (lambda (x y) (tag (* x y))))
73   (put 'div '(integer integer)
74        (lambda (x y) (tag (quotient x y))))
75   ;; 	 (if (integer? (/ x y))
76   ;; 	     (tag (/ x y))
77   ;; 	     (div (raise (tag x))
78   ;; 		  (raise (tag y))))))
79   ;; ;; we avoided calling make-rational to avoid dependencies
80   (put 'equ? '(integer integer) =)
81   (put '=zero? '(integer) zero?)
82   (put 'make 'integer
83        (lambda (n) 
84 	 (if (exact? n)
85 	     (tag n)
86 	     (error "Not an exact integer" n))))
87   (put 'raise '(integer)
88        (lambda (x) (make-rational x 1)))
89   (put 'project '(integer)
90        (lambda (x) #f))
91   'done)
92 
93 (define (install-rational-package)
94   (define (gcd a b)
95     (if (= b 0)
96 	a
97 	(gcd b (remainder a b))))
98   (define (numer x) (car x))
99   (define (denom x) (cdr x))
100   (define (make-rat n d)
101     (if (not (and (integer? n) (integer? d)))
102 	(error "Both numerator and denominator must be integers" 
103 	       (list n d))
104 	(let ((g (gcd n d)))
105 	  (cons (/ n g) (/ d g)))))
106   (define (add-rat x y)
107     (make-rat (+ (* (numer x) (denom y))
108 		 (* (numer y) (denom x)))
109 	      (* (denom x) (denom y))))
110   (define (sub-rat x y)
111     (make-rat (- (* (numer x) (denom y))
112 		 (* (numer y) (denom x)))
113 	      (* (denom x) (denom y))))
114   (define (mul-rat x y)
115     (make-rat (* (numer x) (numer y))
116 	      (* (denom x) (denom y))))
117   (define (div-rat x y)
118     (make-rat (* (numer x) (denom y))
119 	      (* (denom x) (numer y))))
120   (define (equ-rat? x y)
121     (and (= (numer x) (numer y))
122 	 (= (denom x) (denom y))))
123   (define (=zero-rat? x) (= (numer x) 0))
124   (define (tag x) (attach-tag 'rational x))
125   (put 'add '(rational rational) 
126        (lambda (x y) (tag (add-rat x y))))
127   (put 'sub '(rational rational) 
128        (lambda (x y) (tag (sub-rat x y))))
129   (put 'mul '(rational rational) 
130        (lambda (x y) (tag (mul-rat x y))))
131   (put 'div '(rational rational) 
132        (lambda (x y) (tag (div-rat x y))))
133   (put 'equ? '(rational rational) equ-rat?)
134   (put '=zero? '(rational) =zero-rat?)
135   (put 'make 'rational
136        (lambda (n d) (tag (make-rat n d))))
137   (put 'raise '(rational)
138        (lambda (x) (make-real (/ (numer x) (denom x)))))
139   (put 'project '(rational)
140        (lambda (x) (make-integer (quotient (numer x) (denom x)))))
141   'done)
142 
143 (define (install-real-package)
144   (define (tag x) (attach-tag 'real x))
145   (put 'add '(real real)
146        (lambda (x y) (tag (+ x y))))
147   (put 'sub '(real real) 
148        (lambda (x y) (tag (- x y))))
149   (put 'mul '(real real)
150        (lambda (x y) (tag (* x y))))
151   (put 'div '(real real)
152        (lambda (x y) (tag (/ x y))))
153   (put 'equ? '(real real) =)
154   (put '=zero? '(real) zero?)
155   (put 'make 'real
156        (lambda (n) 
157 	 (if (rational? n)
158 	     (tag (exact->inexact n))
159 	     (tag n))))
160   (put 'raise '(real)
161        (lambda (x) (make-complex-from-real-imag x 0)))
162   (put 'project '(real)
163        (lambda (x) (make-rational (inexact->exact (numerator x))
164 				  (inexact->exact (denominator x)))))
165   'done)
166 
167 
168 (define (install-complex-package)
169   (define (make-from-real-imag x y)
170     ((get 'make-from-real-imag 'rectangular) x y))
171   (define (make-from-mag-ang r a)
172     ((get 'make-from-mag-ang 'polar) r a))
173 
174   (define (real-part z) (apply-generic 'real-part z))
175   (define (imag-part z) (apply-generic 'imag-part z))
176   (define (magnitude z) (apply-generic 'magnitude z))
177   (define (angle z) (apply-generic 'angle z))
178 
179   ;; rectangular and polar representations...
180 
181   (define (install-complex-rectangular)
182     (define (make-from-real-imag-rectangular x y)
183       (cons x y))
184     (define (make-from-mag-ang-rectangular r a)
185       (cons (* r (cos a)) (* r (sin a))))
186     (define (real-part z) (car z))
187     (define (imag-part z) (cdr z))
188     (define (magnitude z)
189       (sqrt (+ (square (real-part z)) 
190 	       (square (imag-part z)))))
191     (define (angle z) (atan (imag-part z) (real-part z)))
192     (define (tag x) (attach-tag 'rectangular x))
193     (put 'real-part '(rectangular) real-part)
194     (put 'imag-part '(rectangular) imag-part)
195     (put 'magnitude '(rectangular) magnitude)
196     (put 'angle '(rectangular) angle)
197     (put 'make-from-real-imag 'rectangular
198 	 (lambda (x y) (tag (make-from-real-imag-rectangular x y))))
199     (put 'make-from-mag-ang 'rectangular
200 	 (lambda (r a) (tag (make-from-mag-ang-rectangular r a))))
201     'done)
202   (define (install-complex-polar)
203     (define (make-from-real-imag-polar x y)
204       (cons (sqrt (+ (square x) (square y)))
205 	    (atan y x)))
206     (define (make-from-mag-ang-polar r a)
207       (cons r a))
208     (define (real-part z) (* (magnitude z) (cos (angle z))))
209     (define (imag-part z) (* (magnitude z) (sin (angle z))))
210     (define (magnitude z) (car z))
211     (define (angle z) (cdr z))
212     (define (tag x) (attach-tag 'polar x))
213     (put 'real-part '(polar) real-part)
214     (put 'imag-part '(polar) imag-part)
215     (put 'magnitude '(polar) magnitude)
216     (put 'angle '(polar) angle)
217     (put 'make-from-real-imag 'polar
218 	 (lambda (x y) (tag (make-from-real-imag-polar x y))))
219     (put 'make-from-mag-ang 'polar
220 	 (lambda (r a) (tag (make-from-mag-ang-polar r a))))
221     'done)  
222   (install-complex-rectangular)
223   (install-complex-polar)
224   ;; end rectangular and polar representations
225 
226   (define (add-complex z1 z2)
227     (make-from-real-imag (+ (real-part z1) (real-part z2))
228 			 (+ (imag-part z1) (imag-part z2))))
229   (define (sub-complex z1 z2)
230     (make-from-real-imag (- (real-part z1) (real-part z2))
231 			 (- (imag-part z1) (imag-part z2))))
232   (define (mul-complex z1 z2)
233     (make-from-mag-ang (* (magnitude z1) (magnitude z2))
234 		       (+ (angle z1) (angle z2))))
235   (define (div-complex z1 z2)
236     (make-from-mag-ang (/ (magnitude z1) (magnitude z2))
237 		       (- (angle z1) (angle z2))))
238   (define (equ-complex? z1 z2)
239     (or (and (= (real-part z1) (real-part z2))
240 	     (= (imag-part z1) (imag-part z2))) ;; in case of rounding error
241 	(and (= (magnitude z1) (magnitude z2))
242 	     (= (angle z1) (angle z2)))))
243   (define (=zero-complex? z) 
244     (and (= (real-part z) 0)
245 	 (= (imag-part z) 0)))
246 
247   (define (tag x) (attach-tag 'complex x))
248   (put 'add '(complex complex) 
249        (lambda (z1 z2) (tag (add-complex z1 z2))))
250   (put 'sub '(complex complex) 
251        (lambda (z1 z2) (tag (sub-complex z1 z2))))
252   (put 'mul '(complex complex) 
253        (lambda (z1 z2) (tag (mul-complex z1 z2))))
254   (put 'div '(complex complex) 
255        (lambda (z1 z2) (tag (div-complex z1 z2))))
256   (put 'equ? '(complex complex) equ-complex?)
257   (put '=zero? '(complex) =zero-complex?)
258   (put 'make-from-real-imag 'complex 
259        (lambda (x y) (tag (make-from-real-imag x y))))
260   (put 'make-from-mag-ang 'complex 
261        (lambda (r a) (tag (make-from-mag-ang r a))))
262   (put 'project '(complex)
263        (lambda (z) (make-real (real-part z))))
264   'done)
265 
266 (define (make-integer n)
267   ((get 'make 'integer) n))
268 (define (make-rational n d)
269   ((get 'make 'rational) n d))
270 (define (make-real n)
271   ((get 'make 'real) n))
272 (define (make-complex-from-real-imag x y) 
273   ((get 'make-from-real-imag 'complex) x y))
274 (define (make-complex-from-mag-ang r a) 
275   ((get 'make-from-mag-ang 'complex) r a))
276 
277 ;; install number packages
278 
279 (install-integer-package)
280 (install-rational-package)
281 (install-real-package)
282 (install-complex-package)
283 
284 (define (test-case actual expected)
285   (newline)
286   (display "Actual:   ")
287   (display actual)
288   (newline)
289   (display "Expected: ")
290   (display expected)
291   (newline))
292 
293 ;; Exercise 2.85.  This section mentioned a method for ``simplifying'' a data object by lowering it in the tower of types as far as possible. 
294 
295 ;; Design a procedure drop that accomplishes this for the tower described in exercise 2.83. The key is to decide, in some general way, whether an object can be lowered. For example, the complex number 1.5 + 0i can be lowered as far as real, the complex number 1 + 0i can be lowered as far as integer, and the complex number 2 + 3i cannot be lowered at all. Here is a plan for determining whether an object can be lowered: 
296 
297 ;; Begin by defining a generic operation project that ``pushes'' an object down in the tower. For example, projecting a complex number would involve throwing away the imaginary part. Then a number can be dropped if, when we project it and raise the result back to the type we started with, we end up with something equal to what we started with. Show how to implement this idea in detail, by writing a drop procedure that drops an object as far as possible. You will need to design the various projection operations and install project as a generic operation in the system. You will also need to make use of a generic equality predicate, such as described in exercise 2.79. Finally, use drop to rewrite apply-generic from exercise 2.84 so that it ``simplifies'' its answers. 
298 
299 (define (drop x) 
300   (let ((projected-x (project x)))
301     (if (and projected-x
302 	     (equ? x (raise projected-x)))
303 	(drop projected-x)
304 	x)))
305 
306 (test-case (drop (make-complex-from-mag-ang 5 0))
307 	   5)
308 (test-case (drop (make-rational 3 5))
309 	   '(rational 3 . 5))
310 (test-case (drop (make-complex-from-real-imag 5/3 0))
311 	   '(rational 5 . 3))
312 (test-case (drop (make-complex-from-mag-ang (sqrt 5) 0))
313 	   2.23606797749979)
314 
315 (define (apply-generic op . args)
316   ;; return arg1 raised to same type as arg2, #f if not possible
317   (define (raise-to-second-type arg1 arg2)
318     (if (eq? (type-tag arg1) (type-tag arg2))
319 	arg1
320 	(let ((raise-proc (get 'raise (list (type-tag arg1)))))
321 	  (if raise-proc
322 	      (raise-to-second-type (raise-proc (contents arg1)) arg2)
323 	      #f))))
324   (let* ((type-tags (map type-tag args))
325 	 (proc (get op type-tags)))
326     (if proc
327 	(drop (apply proc (map contents args)))
328 	(if (= (length args) 2)
329 	    (let ((a1 (car args))
330 		  (a2 (cadr args)))
331 	      (if (eq? (type-tag a1) (type-tag a2))
332 		  (list "No method for these (raised) types" (list op type-tags))
333 		  (let ((raised1 (raise-to-second-type a1 a2))
334 			(raised2 (raise-to-second-type a2 a1)))
335 		    (cond (raised1 (apply-generic op raised1 a2))
336 			  (raised2 (apply-generic op a1 raised2))
337 			  (else (list "No common supertype" (list op type-tags)))))))))))
338 					  
339 
340 
341 (test-case (add (make-integer 4) '(nonsense-type . 3)) 
342 	   '("No common supertype" (add (integer nonsense-type))))
343 (test-case (apply-generic 'dummy (make-integer 3) (make-real 4.))
344 	   '("No method for these (raised) types" (dummy (real real))))
345 (test-case (apply-generic 'dummy (make-real 4.) (make-integer 3))
346 	   '("No method for these (raised) types" (dummy (real real))))
347 
348 	      
349 (test-case (add (make-integer 5) (make-rational 3 1))
350 	   (make-integer 8))
351 (test-case (div (make-integer 2) (make-real 5))
352 	   (make-rational 2 5))
353 (test-case (div (make-real 5) (make-integer 2))
354 	   (make-rationa 1 2))
355 (test-case (mul (div (make-complex-from-mag-ang 3 2)
356 		     (make-integer 3))
357 		(add (make-real 2.4)
358 		     (make-rational 4 3)))
359 	   '(complex polar 3.733333333334 . 2.))