1 (define (attach-tag type-tag contents)
2 (if (or (eq? type-tag 'integer)
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))))
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))))
26 (let ((record (assoc key-2 (cdr subtable))))
31 (define (insert! key-1 key-2 value)
32 (let ((subtable (assoc key-1 (cdr local-table))))
34 (let ((record (assoc key-2 (cdr subtable))))
36 (set-cdr! record value)
38 (cons (cons key-2 value)
46 (cond ((eq? m 'lookup-proc) lookup)
47 ((eq? m 'insert-proc!) insert!)
48 (else (error "Unknown operation -- TABLE" m))))
51 (define operation-table (make-table))
52 (define get (operation-table 'lookup-proc))
53 (define put (operation-table 'insert-proc!))
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))
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))
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?)
84 (error "Not an exact integer" n))))
85 (put 'raise '(integer)
86 (lambda (x) (make-rational x 1)))
89 (define (install-rational-package)
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"
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?)
132 (lambda (n d) (tag (make-rat n d))))
133 (put 'raise '(rational)
134 (lambda (x) (make-real (/ (numer x) (denom x)))))
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?)
153 (tag (exact->inexact n))
156 (lambda (x) (make-complex-from-real-imag x 0)))
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))
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))
171 ;; rectangular and polar representations...
173 (define (install-complex-rectangular)
174 (define (make-from-real-imag-rectangular 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))))
194 (define (install-complex-polar)
195 (define (make-from-real-imag-polar x y)
196 (cons (sqrt (+ (square x) (square y)))
198 (define (make-from-mag-ang-polar 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))))
214 (install-complex-rectangular)
215 (install-complex-polar)
216 ;; end rectangular and polar representations
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)))
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))))
256 (define (install-polynomial-package)
257 (define (tag x) (attach-tag 'polynomial x))
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))
271 ;; install number packages
273 (install-integer-package)
274 (install-rational-package)
275 (install-real-package)
276 (install-complex-package)
277 (install-polynomial-package)
279 (define (test-case actual expected)
284 (display "Expected: ")
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.
290 ;; not going to call apply-generic recursively so we can get more informative error messages
291 ;; 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.
293 (define (apply-generic op . args)
294 ;; return arg1 raised to same type as arg2, #f if not possible
295 (define (raise-to-second-type arg1 arg2)
296 (if (eq? (type-tag arg1) (type-tag arg2))
298 (let ((raise-proc (get 'raise (list (type-tag arg1)))))
300 (raise-to-second-type (raise-proc (contents arg1)) arg2)
302 (let* ((type-tags (map type-tag args))
303 (proc (get op type-tags)))
305 (apply proc (map contents args))
306 (if (= (length args) 2)
307 (let ((a1 (car args))
309 (if (eq? (type-tag a1) (type-tag a2))
310 (list "No method for these common types" (list op type-tags))
311 (let ((raised1 (raise-to-second-type a1 a2))
312 (raised2 (raise-to-second-type a2 a1)))
314 (let ((proc (get op (list (type-tag raised1) (type-tag a2)))))
316 (apply-generic proc raised1 a2)
317 (list "No procedure, even after raising first argument"
318 (list op type-tags)))))
320 (let ((proc (get op (list a1 (type-tag raised2)))))
322 (apply-generic proc a1 raised2)
323 (list "No procedure, even after raising second argument"
324 (list op type-tags)))))
325 (else (list "No common supertype" (list op type-tags)))))))))))
329 (test-case (add (make-integer 4) '(nonsense-type . 3))
330 '("No common supertype" (add (integer nonsense-type))))
331 (test-case (apply-generic 'dummy (make-integer 3) (make-real 4.))
332 '("No procedure, even after raising first argument" (dummy (integer real))))
333 (test-case (apply-generic 'dummy (make-real 4.) (make-integer 3))
334 '("No procedure, even after raising second argument" (dummy (real integer))))
337 (test-case (add (make-integer 5) (make-rational 3 1))
339 (test-case (div (make-integer 2) (make-real 5))
341 (test-case (mul (make-complex-from-real-imag 3 4)
346 ;; begin previous tests
347 (test-case (equ? (add (make-integer 3) (make-integer 4))
348 (sub (make-integer 12) (make-integer 5))) #t)
349 (test-case (equ? (div (make-integer 24) (make-integer 4))
350 (mul (make-integer 2) (make-integer 3))) #t)
351 (test-case (equ? (add (make-integer 3) (make-integer 3))
352 (sub (make-integer 12) (make-integer 5))) #f)
353 (test-case (equ? (div (make-integer 24) (make-integer 4))
354 (mul (make-integer 2) (make-integer 2))) #f)
355 (test-case (=zero? (sub (div (make-integer 24) (make-integer 4))
356 (mul (make-integer 2) (make-integer 3)))) #t)
357 (test-case (=zero? (sub (div (make-integer 24) (make-integer 4))
358 (mul (make-integer 2) (make-integer 4)))) #f)
359 (test-case (make-integer 5) 5)
360 (test-case (type-tag (make-integer 5)) 'integer)
361 (test-case (type-tag (make-real 5)) 'real)
362 (test-case (make-real 1.66667) 1.66667)
363 (test-case (make-real (/ 5 3)) 1.66667)
364 (test-case (type-tag (make-real (/ 5 3))) 'real)
366 (test-case (div (make-integer 3) (make-integer 4)) 0)
367 (test-case (=zero? (sub (make-rational 4 1)
368 (div (add (make-rational 1 2)
370 (mul (make-rational 3 2)
371 (make-rational 2 6))))) #t)
372 (test-case (=zero? (sub (make-rational 4 1)
373 (div (add (make-rational 1 2)
375 (mul (make-rational 3 2)
376 (make-rational 2 5))))) #f)
377 (test-case (equ? (add (make-rational 7 2)
379 (div (add (make-rational 1 2)
381 (mul (make-rational 3 2)
382 (make-rational 2 6)))) #t)
383 (test-case (equ? (add (make-rational 3 2)
385 (div (add (make-rational 1 2)
387 (mul (make-rational 3 2)
388 (make-rational 1 6)))) #f)
389 (test-case (equ? (div (make-rational 4 2)
391 (sub (make-rational 9 1)
392 (mul (make-rational 4 1)
393 (make-rational 3 4)))) #t)
394 (test-case (equ? (div (make-rational 4 2)
396 (sub (make-rational 9 1)
397 (mul (make-rational 4 1)
398 (make-rational 3 5)))) #f)
399 (test-case (equ? (add (make-complex-from-real-imag 3 4)
400 (make-complex-from-real-imag -5 -3))
401 '(complex rectangular -2 . 1))
403 (test-case (equ? (add (make-complex-from-real-imag 3 4.5)
404 (make-complex-from-real-imag -5 -3))
405 '(complex rectangular -2 . 1))
407 (test-case (=zero? (sub (add (make-complex-from-real-imag 3 4)
408 (make-complex-from-real-imag -5 -3))
409 '(complex rectangular -2 . 1)))
412 (test-case (=zero? (sub (add (make-complex-from-real-imag 3 5)
413 (make-complex-from-real-imag -5 -3))
414 '(complex rectangular -2 . 1)))
418 (test-case (raise (make-integer 5)) '(rational 5 . 1))
419 (test-case (raise (raise (make-integer 5))) 5.)
420 (test-case (raise (raise (raise (make-integer 5)))) '(complex rectangular 5. . 0))
422 (test-case (raise (make-rational 5 3)) 1.666667)
423 (test-case (raise (raise (make-rational 5 3))) '(complex rectangular 1.666667 . 0))
424 ;; end previous tests
