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