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