1 665c255d 2023-08-04 jrmu ;; Exercise 2.83. Suppose you are designing a generic arithmetic system for dealing with the tower of types shown in figure 2.25: integer, rational, real, complex. For each type (except complex), design a procedure that raises objects of that type one level in the tower. Show how to install a generic raise operation that will work for each type (except complex).
3 665c255d 2023-08-04 jrmu ;; we have to modify our packages so that we have 4 types: integer, rational, real, and complex
5 665c255d 2023-08-04 jrmu (define (attach-tag type-tag contents)
6 665c255d 2023-08-04 jrmu (if (or (eq? type-tag 'integer)
7 665c255d 2023-08-04 jrmu (eq? type-tag 'real))
9 665c255d 2023-08-04 jrmu (cons type-tag contents)))
10 665c255d 2023-08-04 jrmu (define (type-tag datum)
11 665c255d 2023-08-04 jrmu (cond ((integer? datum) 'integer)
12 665c255d 2023-08-04 jrmu ((number? datum) 'real)
13 665c255d 2023-08-04 jrmu ((pair? datum) (car datum))
14 665c255d 2023-08-04 jrmu ((error "error -- invalid datum" datum))))
15 665c255d 2023-08-04 jrmu (define (contents datum)
16 665c255d 2023-08-04 jrmu (cond ((integer? datum) datum)
17 665c255d 2023-08-04 jrmu ((number? datum) (exact->inexact datum))
18 665c255d 2023-08-04 jrmu ((pair? datum) (cdr datum))
19 665c255d 2023-08-04 jrmu ((error "error -- invalid datum" datum))))
21 665c255d 2023-08-04 jrmu (define (make-table)
22 665c255d 2023-08-04 jrmu (define (assoc key records)
23 665c255d 2023-08-04 jrmu (cond ((null? records) false)
24 665c255d 2023-08-04 jrmu ((equal? key (caar records)) (car records))
25 665c255d 2023-08-04 jrmu (else (assoc key (cdr records)))))
26 665c255d 2023-08-04 jrmu (let ((local-table (list '*table*)))
27 665c255d 2023-08-04 jrmu (define (lookup key-1 key-2)
28 665c255d 2023-08-04 jrmu (let ((subtable (assoc key-1 (cdr local-table))))
29 665c255d 2023-08-04 jrmu (if subtable
30 665c255d 2023-08-04 jrmu (let ((record (assoc key-2 (cdr subtable))))
32 665c255d 2023-08-04 jrmu (cdr record)
35 665c255d 2023-08-04 jrmu (define (insert! key-1 key-2 value)
36 665c255d 2023-08-04 jrmu (let ((subtable (assoc key-1 (cdr local-table))))
37 665c255d 2023-08-04 jrmu (if subtable
38 665c255d 2023-08-04 jrmu (let ((record (assoc key-2 (cdr subtable))))
40 665c255d 2023-08-04 jrmu (set-cdr! record value)
41 665c255d 2023-08-04 jrmu (set-cdr! subtable
42 665c255d 2023-08-04 jrmu (cons (cons key-2 value)
43 665c255d 2023-08-04 jrmu (cdr subtable)))))
44 665c255d 2023-08-04 jrmu (set-cdr! local-table
45 665c255d 2023-08-04 jrmu (cons (list key-1
46 665c255d 2023-08-04 jrmu (cons key-2 value))
47 665c255d 2023-08-04 jrmu (cdr local-table)))))
49 665c255d 2023-08-04 jrmu (define (dispatch m)
50 665c255d 2023-08-04 jrmu (cond ((eq? m 'lookup-proc) lookup)
51 665c255d 2023-08-04 jrmu ((eq? m 'insert-proc!) insert!)
52 665c255d 2023-08-04 jrmu (else (error "Unknown operation -- TABLE" m))))
55 665c255d 2023-08-04 jrmu (define operation-table (make-table))
56 665c255d 2023-08-04 jrmu (define get (operation-table 'lookup-proc))
57 665c255d 2023-08-04 jrmu (define put (operation-table 'insert-proc!))
58 665c255d 2023-08-04 jrmu (define coercion-table (make-table))
59 665c255d 2023-08-04 jrmu (define get-coercion (coercion-table 'lookup-proc))
60 665c255d 2023-08-04 jrmu (define put-coercion (coercion-table 'insert-proc!))
62 665c255d 2023-08-04 jrmu (define (add x y) (apply-generic 'add x y))
63 665c255d 2023-08-04 jrmu (define (sub x y) (apply-generic 'sub x y))
64 665c255d 2023-08-04 jrmu (define (mul x y) (apply-generic 'mul x y))
65 665c255d 2023-08-04 jrmu (define (div x y) (apply-generic 'div x y))
66 665c255d 2023-08-04 jrmu (define (equ? x y) (apply-generic 'equ? x y))
67 665c255d 2023-08-04 jrmu (define (=zero? x) (apply-generic '=zero? x))
69 665c255d 2023-08-04 jrmu (define (install-integer-package)
70 665c255d 2023-08-04 jrmu (define (tag x) (attach-tag 'integer x))
71 665c255d 2023-08-04 jrmu (put 'add '(integer integer)
72 665c255d 2023-08-04 jrmu (lambda (x y) (tag (+ x y))))
73 665c255d 2023-08-04 jrmu (put 'sub '(integer integer)
74 665c255d 2023-08-04 jrmu (lambda (x y) (tag (- x y))))
75 665c255d 2023-08-04 jrmu (put 'mul '(integer integer)
76 665c255d 2023-08-04 jrmu (lambda (x y) (tag (* x y))))
77 665c255d 2023-08-04 jrmu (put 'div '(integer integer)
78 665c255d 2023-08-04 jrmu (lambda (x y) (tag (quotient x y))))
79 665c255d 2023-08-04 jrmu ;; (if (integer? (/ x y))
80 665c255d 2023-08-04 jrmu ;; (tag (/ x y))
81 665c255d 2023-08-04 jrmu ;; (div (raise (tag x))
82 665c255d 2023-08-04 jrmu ;; (raise (tag y))))))
83 665c255d 2023-08-04 jrmu ;; ;; we avoided calling make-rational to avoid dependencies
84 665c255d 2023-08-04 jrmu (put 'equ? '(integer integer) =)
85 665c255d 2023-08-04 jrmu (put '=zero? '(integer) zero?)
86 665c255d 2023-08-04 jrmu (put 'make 'integer
88 665c255d 2023-08-04 jrmu (if (integer? n)
90 665c255d 2023-08-04 jrmu (error "Not an integer" n))))
91 665c255d 2023-08-04 jrmu (put 'raise 'integer
92 665c255d 2023-08-04 jrmu (lambda (x) (make-rational x 1)))
95 665c255d 2023-08-04 jrmu (define (install-rational-package)
96 665c255d 2023-08-04 jrmu (define (gcd a b)
99 665c255d 2023-08-04 jrmu (gcd b (remainder a b))))
100 665c255d 2023-08-04 jrmu (define (numer x) (car x))
101 665c255d 2023-08-04 jrmu (define (denom x) (cdr x))
102 665c255d 2023-08-04 jrmu (define (make-rat n d)
103 665c255d 2023-08-04 jrmu (if (not (and (integer? n) (integer? d)))
104 665c255d 2023-08-04 jrmu (error "Both numerator and denominator must be integers"
105 665c255d 2023-08-04 jrmu (list n d))
106 665c255d 2023-08-04 jrmu (let ((g (gcd n d)))
107 665c255d 2023-08-04 jrmu (cons (/ n g) (/ d g)))))
108 665c255d 2023-08-04 jrmu (define (add-rat x y)
109 665c255d 2023-08-04 jrmu (make-rat (+ (* (numer x) (denom y))
110 665c255d 2023-08-04 jrmu (* (numer y) (denom x)))
111 665c255d 2023-08-04 jrmu (* (denom x) (denom y))))
112 665c255d 2023-08-04 jrmu (define (sub-rat x y)
113 665c255d 2023-08-04 jrmu (make-rat (- (* (numer x) (denom y))
114 665c255d 2023-08-04 jrmu (* (numer y) (denom x)))
115 665c255d 2023-08-04 jrmu (* (denom x) (denom y))))
116 665c255d 2023-08-04 jrmu (define (mul-rat x y)
117 665c255d 2023-08-04 jrmu (make-rat (* (numer x) (numer y))
118 665c255d 2023-08-04 jrmu (* (denom x) (denom y))))
119 665c255d 2023-08-04 jrmu (define (div-rat x y)
120 665c255d 2023-08-04 jrmu (make-rat (* (numer x) (denom y))
121 665c255d 2023-08-04 jrmu (* (denom x) (numer y))))
122 665c255d 2023-08-04 jrmu (define (equ-rat? x y)
123 665c255d 2023-08-04 jrmu (and (= (numer x) (numer y))
124 665c255d 2023-08-04 jrmu (= (denom x) (denom y))))
125 665c255d 2023-08-04 jrmu (define (=zero-rat? x) (= (numer x) 0))
126 665c255d 2023-08-04 jrmu (define (tag x) (attach-tag 'rational x))
127 665c255d 2023-08-04 jrmu (put 'add '(rational rational)
128 665c255d 2023-08-04 jrmu (lambda (x y) (tag (add-rat x y))))
129 665c255d 2023-08-04 jrmu (put 'sub '(rational rational)
130 665c255d 2023-08-04 jrmu (lambda (x y) (tag (sub-rat x y))))
131 665c255d 2023-08-04 jrmu (put 'mul '(rational rational)
132 665c255d 2023-08-04 jrmu (lambda (x y) (tag (mul-rat x y))))
133 665c255d 2023-08-04 jrmu (put 'div '(rational rational)
134 665c255d 2023-08-04 jrmu (lambda (x y) (tag (div-rat x y))))
135 665c255d 2023-08-04 jrmu (put 'equ? '(rational rational) equ-rat?)
136 665c255d 2023-08-04 jrmu (put '=zero? '(rational) =zero-rat?)
137 665c255d 2023-08-04 jrmu (put 'make 'rational
138 665c255d 2023-08-04 jrmu (lambda (n d) (tag (make-rat n d))))
139 665c255d 2023-08-04 jrmu (put 'raise 'rational
140 665c255d 2023-08-04 jrmu (lambda (x) (make-real (/ (numer x) (denom x)))))
144 665c255d 2023-08-04 jrmu (define (install-real-package)
145 665c255d 2023-08-04 jrmu (define (tag x) (attach-tag 'real x))
146 665c255d 2023-08-04 jrmu (put 'add '(real real)
147 665c255d 2023-08-04 jrmu (lambda (x y) (tag (+ x y))))
148 665c255d 2023-08-04 jrmu (put 'sub '(real real)
149 665c255d 2023-08-04 jrmu (lambda (x y) (tag (- x y))))
150 665c255d 2023-08-04 jrmu (put 'mul '(real real)
151 665c255d 2023-08-04 jrmu (lambda (x y) (tag (* x y))))
152 665c255d 2023-08-04 jrmu (put 'div '(real real)
153 665c255d 2023-08-04 jrmu (lambda (x y) (tag (/ x y))))
154 665c255d 2023-08-04 jrmu (put 'equ? '(real real) =)
155 665c255d 2023-08-04 jrmu (put '=zero? '(real) zero?)
156 665c255d 2023-08-04 jrmu (put 'make 'real
157 665c255d 2023-08-04 jrmu (lambda (n)
158 665c255d 2023-08-04 jrmu (if (integer? n)
159 665c255d 2023-08-04 jrmu (tag (exact->inexact n))
161 665c255d 2023-08-04 jrmu (put 'raise 'real (lambda (x) (make-complex-from-real-imag x 0)))
165 665c255d 2023-08-04 jrmu (define (install-complex-package)
166 665c255d 2023-08-04 jrmu (define (make-from-real-imag x y)
167 665c255d 2023-08-04 jrmu ((get 'make-from-real-imag 'rectangular) x y))
168 665c255d 2023-08-04 jrmu (define (make-from-mag-ang r a)
169 665c255d 2023-08-04 jrmu ((get 'make-from-mag-ang 'polar) r a))
171 665c255d 2023-08-04 jrmu (define (real-part z) (apply-generic 'real-part z))
172 665c255d 2023-08-04 jrmu (define (imag-part z) (apply-generic 'imag-part z))
173 665c255d 2023-08-04 jrmu (define (magnitude z) (apply-generic 'magnitude z))
174 665c255d 2023-08-04 jrmu (define (angle z) (apply-generic 'angle z))
176 665c255d 2023-08-04 jrmu ;; rectangular and polar representations...
178 665c255d 2023-08-04 jrmu (define (install-complex-rectangular)
179 665c255d 2023-08-04 jrmu (define (make-from-real-imag-rectangular x y)
180 665c255d 2023-08-04 jrmu (cons x y))
181 665c255d 2023-08-04 jrmu (define (make-from-mag-ang-rectangular r a)
182 665c255d 2023-08-04 jrmu (cons (* r (cos a)) (* r (sin a))))
183 665c255d 2023-08-04 jrmu (define (real-part z) (car z))
184 665c255d 2023-08-04 jrmu (define (imag-part z) (cdr z))
185 665c255d 2023-08-04 jrmu (define (magnitude z)
186 665c255d 2023-08-04 jrmu (sqrt (+ (square (real-part z))
187 665c255d 2023-08-04 jrmu (square (imag-part z)))))
188 665c255d 2023-08-04 jrmu (define (angle z) (atan (imag-part z) (real-part z)))
189 665c255d 2023-08-04 jrmu (define (tag x) (attach-tag 'rectangular x))
190 665c255d 2023-08-04 jrmu (put 'real-part '(rectangular) real-part)
191 665c255d 2023-08-04 jrmu (put 'imag-part '(rectangular) imag-part)
192 665c255d 2023-08-04 jrmu (put 'magnitude '(rectangular) magnitude)
193 665c255d 2023-08-04 jrmu (put 'angle '(rectangular) angle)
194 665c255d 2023-08-04 jrmu (put 'make-from-real-imag 'rectangular
195 665c255d 2023-08-04 jrmu (lambda (x y) (tag (make-from-real-imag-rectangular x y))))
196 665c255d 2023-08-04 jrmu (put 'make-from-mag-ang 'rectangular
197 665c255d 2023-08-04 jrmu (lambda (r a) (tag (make-from-mag-ang-rectangular r a))))
199 665c255d 2023-08-04 jrmu (define (install-complex-polar)
200 665c255d 2023-08-04 jrmu (define (make-from-real-imag-polar x y)
201 665c255d 2023-08-04 jrmu (cons (sqrt (+ (square x) (square y)))
202 665c255d 2023-08-04 jrmu (atan y x)))
203 665c255d 2023-08-04 jrmu (define (make-from-mag-ang-polar r a)
204 665c255d 2023-08-04 jrmu (cons r a))
205 665c255d 2023-08-04 jrmu (define (real-part z) (* (magnitude z) (cos (angle z))))
206 665c255d 2023-08-04 jrmu (define (imag-part z) (* (magnitude z) (sin (angle z))))
207 665c255d 2023-08-04 jrmu (define (magnitude z) (car z))
208 665c255d 2023-08-04 jrmu (define (angle z) (cdr z))
209 665c255d 2023-08-04 jrmu (define (tag x) (attach-tag 'polar x))
210 665c255d 2023-08-04 jrmu (put 'real-part '(polar) real-part)
211 665c255d 2023-08-04 jrmu (put 'imag-part '(polar) imag-part)
212 665c255d 2023-08-04 jrmu (put 'magnitude '(polar) magnitude)
213 665c255d 2023-08-04 jrmu (put 'angle '(polar) angle)
214 665c255d 2023-08-04 jrmu (put 'make-from-real-imag 'polar
215 665c255d 2023-08-04 jrmu (lambda (x y) (tag (make-from-real-imag-polar x y))))
216 665c255d 2023-08-04 jrmu (put 'make-from-mag-ang 'polar
217 665c255d 2023-08-04 jrmu (lambda (r a) (tag (make-from-mag-ang-polar r a))))
219 665c255d 2023-08-04 jrmu (install-complex-rectangular)
220 665c255d 2023-08-04 jrmu (install-complex-polar)
221 665c255d 2023-08-04 jrmu ;; end rectangular and polar representations
223 665c255d 2023-08-04 jrmu (define (add-complex z1 z2)
224 665c255d 2023-08-04 jrmu (make-from-real-imag (+ (real-part z1) (real-part z2))
225 665c255d 2023-08-04 jrmu (+ (imag-part z1) (imag-part z2))))
226 665c255d 2023-08-04 jrmu (define (sub-complex z1 z2)
227 665c255d 2023-08-04 jrmu (make-from-real-imag (- (real-part z1) (real-part z2))
228 665c255d 2023-08-04 jrmu (- (imag-part z1) (imag-part z2))))
229 665c255d 2023-08-04 jrmu (define (mul-complex z1 z2)
230 665c255d 2023-08-04 jrmu (make-from-mag-ang (* (magnitude z1) (magnitude z2))
231 665c255d 2023-08-04 jrmu (+ (angle z1) (angle z2))))
232 665c255d 2023-08-04 jrmu (define (div-complex z1 z2)
233 665c255d 2023-08-04 jrmu (make-from-mag-ang (/ (magnitude z1) (magnitude z2))
234 665c255d 2023-08-04 jrmu (- (angle z1) (angle z2))))
235 665c255d 2023-08-04 jrmu (define (equ-complex? z1 z2)
236 665c255d 2023-08-04 jrmu (or (and (= (real-part z1) (real-part z2))
237 665c255d 2023-08-04 jrmu (= (imag-part z1) (imag-part z2))) ;; in case of rounding error
238 665c255d 2023-08-04 jrmu (and (= (magnitude z1) (magnitude z2))
239 665c255d 2023-08-04 jrmu (= (angle z1) (angle z2)))))
240 665c255d 2023-08-04 jrmu (define (=zero-complex? z)
241 665c255d 2023-08-04 jrmu (and (= (real-part z) 0)
242 665c255d 2023-08-04 jrmu (= (imag-part z) 0)))
244 665c255d 2023-08-04 jrmu (define (tag x) (attach-tag 'complex x))
245 665c255d 2023-08-04 jrmu (put 'add '(complex complex)
246 665c255d 2023-08-04 jrmu (lambda (z1 z2) (tag (add-complex z1 z2))))
247 665c255d 2023-08-04 jrmu (put 'sub '(complex complex)
248 665c255d 2023-08-04 jrmu (lambda (z1 z2) (tag (sub-complex z1 z2))))
249 665c255d 2023-08-04 jrmu (put 'mul '(complex complex)
250 665c255d 2023-08-04 jrmu (lambda (z1 z2) (tag (mul-complex z1 z2))))
251 665c255d 2023-08-04 jrmu (put 'div '(complex complex)
252 665c255d 2023-08-04 jrmu (lambda (z1 z2) (tag (div-complex z1 z2))))
253 665c255d 2023-08-04 jrmu (put 'equ? '(complex complex) equ-complex?)
254 665c255d 2023-08-04 jrmu (put '=zero? '(complex) =zero-complex?)
255 665c255d 2023-08-04 jrmu (put 'make-from-real-imag 'complex
256 665c255d 2023-08-04 jrmu (lambda (x y) (tag (make-from-real-imag x y))))
257 665c255d 2023-08-04 jrmu (put 'make-from-mag-ang 'complex
258 665c255d 2023-08-04 jrmu (lambda (r a) (tag (make-from-mag-ang r a))))
261 665c255d 2023-08-04 jrmu (define (make-integer n)
262 665c255d 2023-08-04 jrmu ((get 'make 'integer) n))
263 665c255d 2023-08-04 jrmu (define (make-rational n d)
264 665c255d 2023-08-04 jrmu ((get 'make 'rational) n d))
265 665c255d 2023-08-04 jrmu (define (make-real n)
266 665c255d 2023-08-04 jrmu ((get 'make 'real) n))
267 665c255d 2023-08-04 jrmu (define (make-complex-from-real-imag x y)
268 665c255d 2023-08-04 jrmu ((get 'make-from-real-imag 'complex) x y))
269 665c255d 2023-08-04 jrmu (define (make-complex-from-mag-ang r a)
270 665c255d 2023-08-04 jrmu ((get 'make-from-mag-ang 'complex) r a))
273 665c255d 2023-08-04 jrmu ;; install number packages
275 665c255d 2023-08-04 jrmu (install-integer-package)
276 665c255d 2023-08-04 jrmu (install-rational-package)
277 665c255d 2023-08-04 jrmu (install-real-package)
278 665c255d 2023-08-04 jrmu (install-complex-package)
281 665c255d 2023-08-04 jrmu (define (test-case actual expected)
283 665c255d 2023-08-04 jrmu (display "Actual: ")
284 665c255d 2023-08-04 jrmu (display actual)
286 665c255d 2023-08-04 jrmu (display "Expected: ")
287 665c255d 2023-08-04 jrmu (display expected)
290 665c255d 2023-08-04 jrmu (test-case (equ? (add (make-integer 3) (make-integer 4))
291 665c255d 2023-08-04 jrmu (sub (make-integer 12) (make-integer 5))) #t)
292 665c255d 2023-08-04 jrmu (test-case (equ? (div (make-integer 24) (make-integer 4))
293 665c255d 2023-08-04 jrmu (mul (make-integer 2) (make-integer 3))) #t)
294 665c255d 2023-08-04 jrmu (test-case (equ? (add (make-integer 3) (make-integer 3))
295 665c255d 2023-08-04 jrmu (sub (make-integer 12) (make-integer 5))) #f)
296 665c255d 2023-08-04 jrmu (test-case (equ? (div (make-integer 24) (make-integer 4))
297 665c255d 2023-08-04 jrmu (mul (make-integer 2) (make-integer 2))) #f)
298 665c255d 2023-08-04 jrmu (test-case (=zero? (sub (div (make-integer 24) (make-integer 4))
299 665c255d 2023-08-04 jrmu (mul (make-integer 2) (make-integer 3)))) #t)
300 665c255d 2023-08-04 jrmu (test-case (=zero? (sub (div (make-integer 24) (make-integer 4))
301 665c255d 2023-08-04 jrmu (mul (make-integer 2) (make-integer 4)))) #f)
302 665c255d 2023-08-04 jrmu (test-case (make-integer 5) 5)
303 665c255d 2023-08-04 jrmu (test-case (type-tag (make-integer 5)) 'integer)
304 665c255d 2023-08-04 jrmu (test-case (type-tag (make-real 5)) 'integer) ;; automatically drops
305 665c255d 2023-08-04 jrmu (test-case (make-real 1.66667) 1.66667)
306 665c255d 2023-08-04 jrmu ;; (test-case (make-real (/ 5 3)) 1.66667) fails
308 665c255d 2023-08-04 jrmu (test-case (div (make-integer 3) (make-integer 4)) 0)
309 665c255d 2023-08-04 jrmu (test-case (=zero? (sub (make-rational 4 1)
310 665c255d 2023-08-04 jrmu (div (add (make-rational 1 2)
311 665c255d 2023-08-04 jrmu (make-rational 3 2))
312 665c255d 2023-08-04 jrmu (mul (make-rational 3 2)
313 665c255d 2023-08-04 jrmu (make-rational 2 6))))) #t)
314 665c255d 2023-08-04 jrmu (test-case (=zero? (sub (make-rational 4 1)
315 665c255d 2023-08-04 jrmu (div (add (make-rational 1 2)
316 665c255d 2023-08-04 jrmu (make-rational 3 2))
317 665c255d 2023-08-04 jrmu (mul (make-rational 3 2)
318 665c255d 2023-08-04 jrmu (make-rational 2 5))))) #f)
319 665c255d 2023-08-04 jrmu (test-case (equ? (add (make-rational 7 2)
320 665c255d 2023-08-04 jrmu (make-rational 2 4))
321 665c255d 2023-08-04 jrmu (div (add (make-rational 1 2)
322 665c255d 2023-08-04 jrmu (make-rational 3 2))
323 665c255d 2023-08-04 jrmu (mul (make-rational 3 2)
324 665c255d 2023-08-04 jrmu (make-rational 2 6)))) #t)
325 665c255d 2023-08-04 jrmu (test-case (equ? (add (make-rational 3 2)
326 665c255d 2023-08-04 jrmu (make-rational 2 4))
327 665c255d 2023-08-04 jrmu (div (add (make-rational 1 2)
328 665c255d 2023-08-04 jrmu (make-rational 3 2))
329 665c255d 2023-08-04 jrmu (mul (make-rational 3 2)
330 665c255d 2023-08-04 jrmu (make-rational 1 6)))) #f)
331 665c255d 2023-08-04 jrmu (test-case (equ? (div (make-rational 4 2)
332 665c255d 2023-08-04 jrmu (make-rational 1 3))
333 665c255d 2023-08-04 jrmu (sub (make-rational 9 1)
334 665c255d 2023-08-04 jrmu (mul (make-rational 4 1)
335 665c255d 2023-08-04 jrmu (make-rational 3 4)))) #t)
336 665c255d 2023-08-04 jrmu (test-case (equ? (div (make-rational 4 2)
337 665c255d 2023-08-04 jrmu (make-rational 1 3))
338 665c255d 2023-08-04 jrmu (sub (make-rational 9 1)
339 665c255d 2023-08-04 jrmu (mul (make-rational 4 1)
340 665c255d 2023-08-04 jrmu (make-rational 3 5)))) #f)
341 665c255d 2023-08-04 jrmu (test-case (equ? (add (make-complex-from-real-imag 3 4)
342 665c255d 2023-08-04 jrmu (make-complex-from-real-imag -5 -3))
343 665c255d 2023-08-04 jrmu '(complex rectangular -2 . 1))
345 665c255d 2023-08-04 jrmu (test-case (equ? (add (make-complex-from-real-imag 3 4.5)
346 665c255d 2023-08-04 jrmu (make-complex-from-real-imag -5 -3))
347 665c255d 2023-08-04 jrmu '(complex rectangular -2 . 1))
349 665c255d 2023-08-04 jrmu (test-case (=zero? (sub (add (make-complex-from-real-imag 3 4)
350 665c255d 2023-08-04 jrmu (make-complex-from-real-imag -5 -3))
351 665c255d 2023-08-04 jrmu '(complex rectangular -2 . 1)))
354 665c255d 2023-08-04 jrmu (test-case (=zero? (sub (add (make-complex-from-real-imag 3 5)
355 665c255d 2023-08-04 jrmu (make-complex-from-real-imag -5 -3))
356 665c255d 2023-08-04 jrmu '(complex rectangular -2 . 1)))
360 665c255d 2023-08-04 jrmu ;; (test-case (=zero? (sub (div (make-rational 4 3)
361 665c255d 2023-08-04 jrmu ;; (make-rational 1 3))
362 665c255d 2023-08-04 jrmu ;; (sub (make-rational 9 1)
363 665c255d 2023-08-04 jrmu ;; (mul (make-rational 4 1)
364 665c255d 2023-08-04 jrmu ;; (make-rational 3 4)))))
366 665c255d 2023-08-04 jrmu ;; (test-case (=zero? (sub (add (make-complex-from-real-imag 3 5)
367 665c255d 2023-08-04 jrmu ;; (make-complex-from-real-imag -5 -3))
368 665c255d 2023-08-04 jrmu ;; '(complex rectangular -2 . 1)))
371 665c255d 2023-08-04 jrmu ;; (define (scheme-number->complex n)
372 665c255d 2023-08-04 jrmu ;; (make-complex-from-real-imag (contents n) 0))
373 665c255d 2023-08-04 jrmu ;; (put-coercion 'scheme-number 'complex scheme-number->complex)
375 665c255d 2023-08-04 jrmu (define (apply-generic op . args)
376 665c255d 2023-08-04 jrmu (let ((type-tags (map type-tag args)))
377 665c255d 2023-08-04 jrmu (let ((proc (get op type-tags)))
379 665c255d 2023-08-04 jrmu (apply proc (map contents args))
380 665c255d 2023-08-04 jrmu (if (= (length args) 2)
381 665c255d 2023-08-04 jrmu (let ((type1 (car type-tags))
382 665c255d 2023-08-04 jrmu (type2 (cadr type-tags))
383 665c255d 2023-08-04 jrmu (a1 (car args))
384 665c255d 2023-08-04 jrmu (a2 (cadr args)))
385 665c255d 2023-08-04 jrmu (let ((t1->t2 (get-coercion type1 type2))
386 665c255d 2023-08-04 jrmu (t2->t1 (get-coercion type2 type1)))
387 665c255d 2023-08-04 jrmu (cond (t1->t2
388 665c255d 2023-08-04 jrmu (apply-generic op (t1->t2 a1) a2))
390 665c255d 2023-08-04 jrmu (apply-generic op a1 (t2->t1 a2)))
392 665c255d 2023-08-04 jrmu (error "No method for these types"
393 665c255d 2023-08-04 jrmu (list op type-tags))))))
394 665c255d 2023-08-04 jrmu (error "No method for these types"
395 665c255d 2023-08-04 jrmu (list op type-tags)))))))
398 665c255d 2023-08-04 jrmu ;; (test-case (add (make-scheme-number 5)
399 665c255d 2023-08-04 jrmu ;; (make-complex-from-real-imag 3 2))
400 665c255d 2023-08-04 jrmu ;; '(complex rectangular 8 . 2))
401 665c255d 2023-08-04 jrmu ;; (test-case (add (make-complex-from-mag-ang 5 0.927295218)
402 665c255d 2023-08-04 jrmu ;; (make-scheme-number 2))
403 665c255d 2023-08-04 jrmu ;; '(complex rectangular 5 . 4))
406 665c255d 2023-08-04 jrmu (define (raise x) (apply-generic 'raise x))
