1 ;; Exercise 2.79.  Define a generic equality predicate equ? that tests the equality of two numbers, and install it in the generic arithmetic package. This operation should work for ordinary numbers, rational numbers, and complex numbers. 
2 
3 ;; Exercise 2.80.  Define a generic predicate =zero? that tests if its argument is zero, and install it in the generic arithmetic package. This operation should work for ordinary numbers, rational numbers, and complex numbers. 
4 
5 (define (attach-tag type-tag contents)
6   (if (eq? type-tag 'scheme-number)
7       contents
8       (cons type-tag contents)))
9 (define (type-tag datum)
10   (cond ((number? datum) 'scheme-number)
11 	((pair? datum) (car datum))
12 	((error "error -- invalid datum" datum))))
13 (define (contents datum)
14   (cond ((number? datum) datum)
15 	((pair? datum) (cdr datum))
16 	((error "error -- invalid datum" datum))))
17 
18 (define (make-table)
19   (define (assoc key records)
20     (cond ((null? records) false)
21 	  ((equal? key (caar records)) (car records))
22 	  (else (assoc key (cdr records)))))
23   (let ((local-table (list '*table*)))
24     (define (lookup key-1 key-2)
25       (let ((subtable (assoc key-1 (cdr local-table))))
26 	(if subtable
27 	    (let ((record (assoc key-2 (cdr subtable))))
28 	      (if record
29 		  (cdr record)
30 		  false))
31 	    false)))
32     (define (insert! key-1 key-2 value)
33       (let ((subtable (assoc key-1 (cdr local-table))))
34 	(if subtable
35 	    (let ((record (assoc key-2 (cdr subtable))))
36 	      (if record
37 		  (set-cdr! record value)
38 		  (set-cdr! subtable
39 			    (cons (cons key-2 value)
40 				  (cdr subtable)))))
41 	    (set-cdr! local-table
42 		      (cons (list key-1
43 				  (cons key-2 value))
44 			    (cdr local-table)))))
45       'ok)
46     (define (dispatch m)
47       (cond ((eq? m 'lookup-proc) lookup)
48 	    ((eq? m 'insert-proc!) insert!)
49 	    (else (error "Unknown operation -- TABLE" m))))
50     dispatch))
51 
52 (define operation-table (make-table))
53 (define get (operation-table 'lookup-proc))
54 (define put (operation-table 'insert-proc!))
55 
56 (define (apply-generic op . args)
57   (let* ((type-tags (map type-tag args))
58 	 (proc (get op type-tags)))
59     (if proc
60 	(apply proc (map contents args))
61 	(error "error -- procedure not found" (list op args)))))
62 
63 (define (add x y) (apply-generic 'add x y))
64 (define (sub x y) (apply-generic 'sub x y))
65 (define (mul x y) (apply-generic 'mul x y))
66 (define (div x y) (apply-generic 'div x y))
67 (define (equ? x y) (apply-generic 'equ? x y))
68 (define (=zero? x) (apply-generic '=zero? x))
69 
70 (define (install-scheme-number-package)
71   (define (tag x) (attach-tag 'scheme-number x))
72   (put 'add '(scheme-number scheme-number)
73        (lambda (x y) (tag (+ x y))))
74   (put 'sub '(scheme-number scheme-number) 
75        (lambda (x y) (tag (- x y))))
76   (put 'mul '(scheme-number scheme-number)
77        (lambda (x y) (tag (* x y))))
78   (put 'div '(scheme-number scheme-number)
79        (lambda (x y) (tag (/ x y))))
80   (put 'equ? '(scheme-number scheme-number) =)
81   (put '=zero? '(scheme-number) zero?)
82   (put 'make 'scheme-number
83        (lambda (n) (tag n)))
84   'done)
85 
86 (define (install-rational-package)
87   (define (gcd a b)
88     (if (= b 0)
89 	a
90 	(gcd b (remainder a b))))
91   (define (numer x) (car x))
92   (define (denom x) (cdr x))
93   (define (make-rat n d)
94     (let ((g (gcd n d)))
95       (cons (/ n g) (/ d g))))
96   (define (add-rat x y)
97     (make-rat (+ (* (numer x) (denom y))
98 		 (* (numer y) (denom x)))
99 	      (* (denom x) (denom y))))
100   (define (sub-rat x y)
101     (make-rat (- (* (numer x) (denom y))
102 		 (* (numer y) (denom x)))
103 	      (* (denom x) (denom y))))
104   (define (mul-rat x y)
105     (make-rat (* (numer x) (numer y))
106 	      (* (denom x) (denom y))))
107   (define (div-rat x y)
108     (make-rat (* (numer x) (denom y))
109 	      (* (denom x) (numer y))))
110   (define (equ-rat? x y)
111     (and (= (numer x) (numer y))
112 	 (= (denom x) (denom y))))
113   (define (=zero-rat? x) (= (numer x) 0))
114   (define (tag x) (attach-tag 'rational x))
115   (put 'add '(rational rational) 
116        (lambda (x y) (tag (add-rat x y))))
117   (put 'sub '(rational rational) 
118        (lambda (x y) (tag (sub-rat x y))))
119   (put 'mul '(rational rational) 
120        (lambda (x y) (tag (mul-rat x y))))
121   (put 'div '(rational rational) 
122        (lambda (x y) (tag (div-rat x y))))
123   (put 'equ? '(rational rational) equ-rat?)
124   (put '=zero? '(rational) =zero-rat?)
125   (put 'make 'rational
126        (lambda (n d) (tag (make-rat n d))))
127   'done)
128 
129 (define (install-complex-package)
130   (define (make-from-real-imag x y)
131     ((get 'make-from-real-imag 'rectangular) x y))
132   (define (make-from-mag-ang r a)
133     ((get 'make-from-mag-ang 'polar) r a))
134 
135   (define (real-part z) (apply-generic 'real-part z))
136   (define (imag-part z) (apply-generic 'imag-part z))
137   (define (magnitude z) (apply-generic 'magnitude z))
138   (define (angle z) (apply-generic 'angle z))
139 
140   ;; rectangular and polar representations...
141 
142   (define (install-complex-rectangular)
143     (define (make-from-real-imag-rectangular x y)
144       (cons x y))
145     (define (make-from-mag-ang-rectangular r a)
146       (cons (* r (cos a)) (* r (sin a))))
147     (define (real-part z) (car z))
148     (define (imag-part z) (cdr z))
149     (define (magnitude z)
150       (sqrt (+ (square (real-part z)) 
151 	       (square (imag-part z)))))
152     (define (angle z) (atan (imag-part z) (real-part z)))
153     (define (tag x) (attach-tag 'rectangular x))
154     (put 'real-part '(rectangular) real-part)
155     (put 'imag-part '(rectangular) imag-part)
156     (put 'magnitude '(rectangular) magnitude)
157     (put 'angle '(rectangular) angle)
158     (put 'make-from-real-imag 'rectangular
159 	 (lambda (x y) (tag (make-from-real-imag-rectangular x y))))
160     (put 'make-from-mag-ang 'rectangular
161 	 (lambda (r a) (tag (make-from-mag-ang-rectangular r a))))
162     'done)
163   (define (install-complex-polar)
164     (define (make-from-real-imag-polar x y)
165       (cons (sqrt (+ (square x) (square y)))
166 	    (atan y x)))
167     (define (make-from-mag-ang-polar r a)
168       (cons r a))
169     (define (real-part z) (* (magnitude z) (cos (angle z))))
170     (define (imag-part z) (* (magnitude z) (sin (angle z))))
171     (define (magnitude z) (car z))
172     (define (angle z) (cdr z))
173     (define (tag x) (attach-tag 'polar x))
174     (put 'real-part '(polar) real-part)
175     (put 'imag-part '(polar) imag-part)
176     (put 'magnitude '(polar) magnitude)
177     (put 'angle '(polar) angle)
178     (put 'make-from-real-imag 'polar
179 	 (lambda (x y) (tag (make-from-real-imag-polar x y))))
180     (put 'make-from-mag-ang 'polar
181 	 (lambda (r a) (tag (make-from-mag-ang-polar r a))))
182     'done)  
183   (install-complex-rectangular)
184   (install-complex-polar)
185   ;; end rectangular and polar representations
186 
187   (define (add-complex z1 z2)
188     (make-from-real-imag (+ (real-part z1) (real-part z2))
189 			 (+ (imag-part z1) (imag-part z2))))
190   (define (sub-complex z1 z2)
191     (make-from-real-imag (- (real-part z1) (real-part z2))
192 			 (- (imag-part z1) (imag-part z2))))
193   (define (mul-complex z1 z2)
194     (make-from-mag-ang (* (magnitude z1) (magnitude z2))
195 		       (+ (angle z1) (angle z2))))
196   (define (div-complex z1 z2)
197     (make-from-mag-ang (/ (magnitude z1) (magnitude z2))
198 		       (- (angle z1) (angle z2))))
199   (define (equ-complex? z1 z2)
200     (or (and (= (real-part z1) (real-part z2))
201 	     (= (imag-part z1) (imag-part z2))) ;; in case of rounding error
202 	(and (= (magnitude z1) (magnitude z2))
203 	     (= (angle z1) (angle z2)))))
204   (define (=zero-complex? z) 
205     (and (= (real-part z) 0)
206 	 (= (imag-part z) 0)))
207 
208   (define (tag x) (attach-tag 'complex x))
209   (put 'add '(complex complex) 
210        (lambda (z1 z2) (tag (add-complex z1 z2))))
211   (put 'sub '(complex complex) 
212        (lambda (z1 z2) (tag (sub-complex z1 z2))))
213   (put 'mul '(complex complex) 
214        (lambda (z1 z2) (tag (mul-complex z1 z2))))
215   (put 'div '(complex complex) 
216        (lambda (z1 z2) (tag (div-complex z1 z2))))
217   (put 'equ? '(complex complex) equ-complex?)
218   (put '=zero? '(complex) =zero-complex?)
219   (put 'make-from-real-imag 'complex 
220        (lambda (x y) (tag (make-from-real-imag x y))))
221   (put 'make-from-mag-ang 'complex 
222        (lambda (r a) (tag (make-from-mag-ang r a))))
223   'done)
224 
225 (define (make-scheme-number n)
226   ((get 'make 'scheme-number) n))
227 (define (make-rational n d)
228   ((get 'make 'rational) n d))
229 (define (make-complex-from-real-imag x y) 
230   ((get 'make-from-real-imag 'complex) x y))
231 (define (make-complex-from-mag-ang r a) 
232   ((get 'make-from-mag-ang 'complex) r a))
233 
234 
235 ;; install number packages
236 
237 (install-scheme-number-package)
238 (install-rational-package)
239 (install-complex-package)
240 
241 
242 (define (test-case actual expected)
243   (newline)
244   (display "Actual:   ")
245   (display actual)
246   (newline)
247   (display "Expected: ")
248   (display expected)
249   (newline))
250 
251 (test-case (equ? (div (make-scheme-number 81)
252 		      (mul (make-scheme-number 2)
253 			   (make-scheme-number 4.5)))
254 		 (add (make-scheme-number 4)
255 		      (make-scheme-number 5)))
256 	   #t)
257 (test-case (equ? (div (make-rational 4 2)
258 		      (make-rational 1 3))
259 		 (sub (make-rational 9 1)
260 		      (mul (make-rational 4 1)
261 			   (make-rational 3 4))))
262 	   #t)
263 (test-case (equ? (add (make-complex-from-real-imag 3 4)
264 		      (make-complex-from-real-imag -5 -3))
265 		 '(complex rectangular -2 . 1))
266 	   #t)
267 (test-case (equ? (div (make-scheme-number 80)
268 		      (mul (make-scheme-number 2)
269 			   (make-scheme-number 4.5)))
270 		 (add (make-scheme-number 4)
271 		      (make-scheme-number 5)))
272 	   #f)
273 (test-case (equ? (div (make-rational 4 3)
274 		      (make-rational 1 3))
275 		 (sub (make-rational 9 1)
276 		      (mul (make-rational 4 1)
277 			   (make-rational 3 4))))
278 	   #f)
279 (test-case (equ? (add (make-complex-from-real-imag 3 4.5)
280 		      (make-complex-from-real-imag -5 -3))
281 		 '(complex rectangular -2 . 1))
282 	   #f)
283 (test-case (=zero? (sub (div (make-scheme-number 81)
284 			     (mul (make-scheme-number 2)
285 				  (make-scheme-number 4.5)))
286 			(add (make-scheme-number 4)
287 			     (make-scheme-number 5))))
288 	   #t)
289 (test-case (=zero? (sub (div (make-rational 4 2)
290 			     (make-rational 1 3))
291 			(sub (make-rational 9 1)
292 			     (mul (make-rational 4 1)
293 				  (make-rational 3 4)))))
294 	   #t)
295 (test-case (=zero? (sub (add (make-complex-from-real-imag 3 4)
296 			     (make-complex-from-real-imag -5 -3))
297 			'(complex rectangular -2 . 1)))
298 	   #t)
299 (test-case (=zero? (sub (div (make-scheme-number 81)
300 			     (mul (make-scheme-number 2)
301 				  (make-scheme-number 4.5)))
302 			(add (make-scheme-number 3.5)
303 			     (make-scheme-number 5))))
304 	   #f)
305 (test-case (=zero? (sub (div (make-rational 4 3)
306 			     (make-rational 1 3))
307 			(sub (make-rational 9 1)
308 			     (mul (make-rational 4 1)
309 				  (make-rational 3 4)))))
310 	   #f)
311 (test-case (=zero? (sub (add (make-complex-from-real-imag 3 5)
312 			     (make-complex-from-real-imag -5 -3))
313 			'(complex rectangular -2 . 1)))
314 	   #f)