1 665c255d 2023-08-04 jrmu (define (install-rational-package)
2 665c255d 2023-08-04 jrmu (define (rational->integer r)
3 665c255d 2023-08-04 jrmu (make-integer (quotient (numer r) (denom r))))
4 665c255d 2023-08-04 jrmu (put-coercion 'rational 'integer rational->integer)
6 665c255d 2023-08-04 jrmu (define (install-real-package)
7 665c255d 2023-08-04 jrmu (define (real->rational r)
8 665c255d 2023-08-04 jrmu (make-rational (inexact->exact (numerator r))
9 665c255d 2023-08-04 jrmu (inexact->exact (denominator r))))
10 665c255d 2023-08-04 jrmu (put-coercion 'real 'rational real->rational)
12 665c255d 2023-08-04 jrmu (define (install-complex-package)
13 665c255d 2023-08-04 jrmu (define (complex->real z)
14 665c255d 2023-08-04 jrmu (make-real (complex-real-part z)))
15 665c255d 2023-08-04 jrmu (put-coercion 'complex 'real complex->real)
18 665c255d 2023-08-04 jrmu (define (apply-raise x types)
19 665c255d 2023-08-04 jrmu (cond ((null? types)
20 665c255d 2023-08-04 jrmu (error "Type not found in the tower-of-types"
21 665c255d 2023-08-04 jrmu (list (type-tag x) tower-of-types)))
22 665c255d 2023-08-04 jrmu ((eq? (type-tag x) (car types))
23 665c255d 2023-08-04 jrmu (if (null? (cdr types))
25 665c255d 2023-08-04 jrmu (let ((raiser (get-coercion (type-tag x) (cadr types))))
27 665c255d 2023-08-04 jrmu (raiser (contents x))
28 665c255d 2023-08-04 jrmu (error "No coercion procedure found for types"
29 665c255d 2023-08-04 jrmu (list (type-tag x) (cadr types)))))))
30 665c255d 2023-08-04 jrmu (else (apply-raise x (cdr types)))))
31 665c255d 2023-08-04 jrmu (define (raise x)
32 665c255d 2023-08-04 jrmu (apply-raise x tower-of-types))
33 665c255d 2023-08-04 jrmu (define (project x)
34 665c255d 2023-08-04 jrmu (apply-raise x (reverse tower-of-types)))
35 665c255d 2023-08-04 jrmu (define (project x)
36 665c255d 2023-08-04 jrmu (define (apply-project types)
37 665c255d 2023-08-04 jrmu (cond ((eq? (type-tag x) (car types)) x)
38 665c255d 2023-08-04 jrmu ((or (null? types) (null? (cdr types)))
39 665c255d 2023-08-04 jrmu (error "type not found in the tower-of-types"
40 665c255d 2023-08-04 jrmu (list (type-tag x) tower-of-types)))
41 665c255d 2023-08-04 jrmu ((eq? (type-tag x) (cadr types))
42 665c255d 2023-08-04 jrmu (let ((projector (get-coercion (type-tag x) (car types))))
43 665c255d 2023-08-04 jrmu (if projector
44 665c255d 2023-08-04 jrmu (projector (contents x))
45 665c255d 2023-08-04 jrmu (error "No coercion procedure found for types"
46 665c255d 2023-08-04 jrmu (list (car types) (type-tag x))))))
47 665c255d 2023-08-04 jrmu (else (apply-project (cdr types)))))
48 665c255d 2023-08-04 jrmu (apply-project tower-of-types))
51 665c255d 2023-08-04 jrmu (define (install-rational-package)
52 665c255d 2023-08-04 jrmu (define (rational->integer r)
53 665c255d 2023-08-04 jrmu (make-integer (round (/ (numer r) (denom r)))))
54 665c255d 2023-08-04 jrmu (put-coercion 'rational 'integer rational->integer)
57 665c255d 2023-08-04 jrmu (define (install-real-package)
58 665c255d 2023-08-04 jrmu (define (real->rational r)
59 665c255d 2023-08-04 jrmu (make-rational (inexact->exact (numerator r))
60 665c255d 2023-08-04 jrmu (inexact->exact (denominator r))))
61 665c255d 2023-08-04 jrmu (put-coercion 'real 'rational real->rational)
64 665c255d 2023-08-04 jrmu (define (install-complex-package)
65 665c255d 2023-08-04 jrmu (define (complex->real z)
66 665c255d 2023-08-04 jrmu (make-real (complex-real-part z)))
67 665c255d 2023-08-04 jrmu (put-coercion 'complex 'real complex->real)
70 665c255d 2023-08-04 jrmu (define (apply-raise x types)
71 665c255d 2023-08-04 jrmu (cond ((null? types)
72 665c255d 2023-08-04 jrmu (error "Type not found in the tower-of-types"
73 665c255d 2023-08-04 jrmu (list (type-tag x) tower-of-types)))
74 665c255d 2023-08-04 jrmu ((eq? (type-tag x) (car types))
75 665c255d 2023-08-04 jrmu (if (null? (cdr types))
77 665c255d 2023-08-04 jrmu (let ((raiser (get-coercion (type-tag x) (cadr types))))
79 665c255d 2023-08-04 jrmu (raiser (contents x))
80 665c255d 2023-08-04 jrmu (error "No coercion procedures found for types"
81 665c255d 2023-08-04 jrmu (list (type-tag x) (cadr types)))))))
82 665c255d 2023-08-04 jrmu (else (apply-raise x (cdr types)))))
84 665c255d 2023-08-04 jrmu (define (raise x)
85 665c255d 2023-08-04 jrmu (apply-raise x tower-of-types))
86 665c255d 2023-08-04 jrmu (define (project x)
87 665c255d 2023-08-04 jrmu (apply-raise x (reverse tower-of-types)))
89 665c255d 2023-08-04 jrmu (define (project x)
90 665c255d 2023-08-04 jrmu (define (apply-project types)
91 665c255d 2023-08-04 jrmu (cond ((eq? (type-tag x) (car types)) x)
92 665c255d 2023-08-04 jrmu ((or (null? types) (null? (cdr types)))
93 665c255d 2023-08-04 jrmu (error "type not found in the tower-of-types"
94 665c255d 2023-08-04 jrmu (list (type-tag x) tower-of-types)))
96 665c255d 2023-08-04 jrmu (define (make-rat n d)
97 665c255d 2023-08-04 jrmu (if (and (integer? n) (integer? d))
98 665c255d 2023-08-04 jrmu (let ((g (gcd n d)))
99 665c255d 2023-08-04 jrmu (cons (/ n g) (/ d g)))
100 665c255d 2023-08-04 jrmu (error "non-integer numerator of denominator"
101 665c255d 2023-08-04 jrmu (list n d))))
103 665c255d 2023-08-04 jrmu (define (make-from-real-imag x y)
104 665c255d 2023-08-04 jrmu (if (and (in-tower? x) (in-tower? y))
106 665c255d 2023-08-04 jrmu (error "non-real real or imaginary value" (list x y))))
108 665c255d 2023-08-04 jrmu (define (make-from-mag-ang r a)
109 665c255d 2023-08-04 jrmu (if (and (real? r) (real? a))
110 665c255d 2023-08-04 jrmu (cons (* r (cos a)) (* r (sin a)))
111 665c255d 2023-08-04 jrmu (error "non-real magnitude or angle" (list r a))))
113 665c255d 2023-08-04 jrmu (define (make-from-mag-ang r a)
114 665c255d 2023-08-04 jrmu (if (and (in-tower? r) (in-tower? a))
116 665c255d 2023-08-04 jrmu (error "non-real magnitude or angle" (list r a))))
117 665c255d 2023-08-04 jrmu (define (make-from-real-imag x y)
118 665c255d 2023-08-04 jrmu (if (and (in-tower? x) (in-tower? y))
119 665c255d 2023-08-04 jrmu (cons (sqrt (+ (square x) (square y)))
120 665c255d 2023-08-04 jrmu (atan y x))
121 665c255d 2023-08-04 jrmu (error "non-real real or imaginary value" (list x y))))
123 665c255d 2023-08-04 jrmu (define (integer->rational i) (make-rational i 1))
124 665c255d 2023-08-04 jrmu (define (rational->real r) (make-real (/ (numer r) (denom r))))
125 665c255d 2023-08-04 jrmu (define (real->complex r) (make-complex-from-real-imag r 0))
126 665c255d 2023-08-04 jrmu (define (raise x) (apply-geeric 'raise x))
128 665c255d 2023-08-04 jrmu (define (tower-of-types '(integer rational real complex))
129 665c255d 2023-08-04 jrmu (define (raise x)
130 665c255d 2023-08-04 jrmu (define (apply-raise types)
131 665c255d 2023-08-04 jrmu (cond ((null? types)
132 665c255d 2023-08-04 jrmu (error "Type not found in the tower-of-types"
133 665c255d 2023-08-04 jrmu (list x tower-of-types)))
134 665c255d 2023-08-04 jrmu ((eq? (type-tag x) (car types))
135 665c255d 2023-08-04 jrmu (if (null? (cdr types))
137 665c255d 2023-08-04 jrmu (let ((raiser (get-coercion (type-tag x) (cadr types))))
139 665c255d 2023-08-04 jrmu (raiser (contents x))
140 665c255d 2023-08-04 jrmu (error "No coercion procedure found for types"
141 665c255d 2023-08-04 jrmu (list (type-tag x) (cadr types))))))
142 665c255d 2023-08-04 jrmu (else (apply-raise (cdr types))))))
143 665c255d 2023-08-04 jrmu (apply-raise tower-of-types))
144 665c255d 2023-08-04 jrmu (put-coercion 'integer 'rational integer->rational)
145 665c255d 2023-08-04 jrmu (put-coercion 'rational 'real rational->real)
146 665c255d 2023-08-04 jrmu (put-coercion 'real 'complex real->complex)
148 665c255d 2023-08-04 jrmu (define (find-highest-type l)
149 665c255d 2023-08-04 jrmu (define (filter-type t f)
150 665c255d 2023-08-04 jrmu (cond ((null? f) '())
151 665c255d 2023-08-04 jrmu ((eq? (car f) t) (filter-type t (cdr f)))
152 665c255d 2023-08-04 jrmu (else (cons (car f) (filter-type t (cdr f))))))
153 665c255d 2023-08-04 jrmu (define (find-highest highest remaining-tower remaining-list)
154 665c255d 2023-08-04 jrmu (cond ((null? remaining-list) highest)
155 665c255d 2023-08-04 jrmu ((null? remaining-tower)
156 665c255d 2023-08-04 jrmu (error "Cannot find highest type from non-tower types -- FIND-HIGHEST-TYPE"
157 665c255d 2023-08-04 jrmu remaining-list))
158 665c255d 2023-08-04 jrmu (else (find-highest (car remaining-tower)
159 665c255d 2023-08-04 jrmu (cdr remaining-tower)
160 665c255d 2023-08-04 jrmu (filter-type (car remaining-tower) remaining-list)))))
161 665c255d 2023-08-04 jrmu (find-highest #f tower-of-types l))
163 665c255d 2023-08-04 jrmu (find-highest-type '(integer real ratinoal real))
164 665c255d 2023-08-04 jrmu (find-highest-type '(rational rational rational))
165 665c255d 2023-08-04 jrmu (find-highest-type '(complex real rational integer))
166 665c255d 2023-08-04 jrmu (find-highest-type '())
167 665c255d 2023-08-04 jrmu (find-highest-type '(integer wibble real wobble complex))
168 665c255d 2023-08-04 jrmu (define (raise-to type value)
169 665c255d 2023-08-04 jrmu (cond ((eq? type (type-tag value)) value)
170 665c255d 2023-08-04 jrmu ((memq type tower-of-types) (raise-to type (raise value)))
171 665c255d 2023-08-04 jrmu (else (error "Cannot raise to non-tower type -- RAISE-TO"
172 665c255d 2023-08-04 jrmu (list type tower-of-types)))))
173 665c255d 2023-08-04 jrmu (raise-to 'real (make-integer 4)
174 665c255d 2023-08-04 jrmu (raise-to 'complex (make-rational 3 4))
175 665c255d 2023-08-04 jrmu (raise-to 'real (make-real 3.14159))
176 665c255d 2023-08-04 jrmu (raise-to 'wibble (make-integer 42))
177 665c255d 2023-08-04 jrmu (define (raise-all-to type values)
178 665c255d 2023-08-04 jrmu (if (null? values)
180 665c255d 2023-08-04 jrmu (cons (raise-to type (car values)) (raise-all-to type (cdr values)))))
181 665c255d 2023-08-04 jrmu (raise-all-to 'real (list (make-integer 42) (make-real 3.14159) (make-rational 3 4)))
182 665c255d 2023-08-04 jrmu (raise-all-to 'complex '())
183 665c255d 2023-08-04 jrmu (raise-all-to 'wibble (list (make-integer 123)))
185 665c255d 2023-08-04 jrmu (define (apply-generic op . args)
186 665c255d 2023-08-04 jrmu (let* ((type-tags (map type-tag args))
187 665c255d 2023-08-04 jrmu (proc (get op type-tags)))
189 665c255d 2023-08-04 jrmu (apply proc (map contents args))
190 665c255d 2023-08-04 jrmu (if (> (length args) 1)
191 665c255d 2023-08-04 jrmu (let* ((highest-type (find-highest-type type-tags))
192 665c255d 2023-08-04 jrmu (mapped-args (raise-all-to highest-type args))
193 665c255d 2023-08-04 jrmu (mapped-types (map type-tag mapped-args))
194 665c255d 2023-08-04 jrmu (mapped-proc (get op mapped-types)))
195 665c255d 2023-08-04 jrmu (if mapped-proc
196 665c255d 2023-08-04 jrmu (apply mapped-proc (map contents mapped-args))
197 665c255d 2023-08-04 jrmu (error "No method for these types -- APPLY-GENERIC"
198 665c255d 2023-08-04 jrmu (list op type-tags))))))))
200 665c255d 2023-08-04 jrmu (define (install-integer-package)
201 665c255d 2023-08-04 jrmu (put 'addd '(integer integer integer)
202 665c255d 2023-08-04 jrmu (lambda (x y z) (tag (+ x y z)))))
204 665c255d 2023-08-04 jrmu (put 'addd '(rational rational rational)
205 665c255d 2023-08-04 jrmu (lambda (x y z) (tag (addd x y z))))
206 665c255d 2023-08-04 jrmu (put 'addd '(real real real)
207 665c255d 2023-08-04 jrmu (lambda (x y z) (tag (+ x y z))))
209 665c255d 2023-08-04 jrmu (define (rational->integer r) (make-integer (round (/ (numer r) (denom r)))))
210 665c255d 2023-08-04 jrmu (put-coercion 'rational 'integer rational->integer)
211 665c255d 2023-08-04 jrmu (define (real->rational r) (make-rational (inexact->exact (numerator r))
212 665c255d 2023-08-04 jrmu (inexact->exact (denominator r))))
213 665c255d 2023-08-04 jrmu (put-coercion 'real 'rational real->rational)
215 665c255d 2023-08-04 jrmu (define (complex->real z) (make-real (complex-real-part z)))
216 665c255d 2023-08-04 jrmu (put-coercion 'complex 'real complex->real)
218 665c255d 2023-08-04 jrmu (define (apply-raise x types)
219 665c255d 2023-08-04 jrmu (cond ((null? types)
220 665c255d 2023-08-04 jrmu (error "Type not found in the tower-of-types"
221 665c255d 2023-08-04 jrmu (list (type-tag x) tower-of-types)))
222 665c255d 2023-08-04 jrmu ((eq? (type-tag x) (car types))
223 665c255d 2023-08-04 jrmu (if (null? (cdr types))
225 665c255d 2023-08-04 jrmu (let ((raiser (get-coercion (type-tag x) (cadr types))))
227 665c255d 2023-08-04 jrmu (raiser (contents x))
228 665c255d 2023-08-04 jrmu (error "No coercion procedure found for types"
229 665c255d 2023-08-04 jrmu (list (type-tag x) (cadr types)))))))
230 665c255d 2023-08-04 jrmu (else (apply-raise x (cdr types)))))
232 665c255d 2023-08-04 jrmu (define (raise x)
233 665c255d 2023-08-04 jrmu (apply-raise x tower-of-types))
234 665c255d 2023-08-04 jrmu (define (project x)
235 665c255d 2023-08-04 jrmu (apply-raise x (reverse tower-of-types)))
237 665c255d 2023-08-04 jrmu (define (project x)
238 665c255d 2023-08-04 jrmu (define (apply-project types)
239 665c255d 2023-08-04 jrmu (cond ((eq? (type-tag x) (car types)) x)
240 665c255d 2023-08-04 jrmu ((or (null? types) (null? (cdr types)))
241 665c255d 2023-08-04 jrmu (error "type not found in the tower-of-types"
242 665c255d 2023-08-04 jrmu (list (type-tag x) tower-of-types)))
243 665c255d 2023-08-04 jrmu ((eq? (type-tag x) (cadr types))
244 665c255d 2023-08-04 jrmu (let ((projector (get-coercion (type-tag x) (car types))))
245 665c255d 2023-08-04 jrmu (if projector
246 665c255d 2023-08-04 jrmu (projector (contents x))
247 665c255d 2023-08-04 jrmu (error "No coercion procedure found for types"
248 665c255d 2023-08-04 jrmu (list (car types) (type-tag x))))))
249 665c255d 2023-08-04 jrmu (else (apply-project (cdr types)))))
250 665c255d 2023-08-04 jrmu (apply-project tower-of-types))
251 665c255d 2023-08-04 jrmu (project (make-real 3.5))
252 665c255d 2023-08-04 jrmu (project (Make-rational 7 3))
253 665c255d 2023-08-04 jrmu (raise (project (make-real 3.5)))
254 665c255d 2023-08-04 jrmu (raise (project (make-rational 7 3)))
255 665c255d 2023-08-04 jrmu (define (drop x)
256 665c255d 2023-08-04 jrmu (let* ((dropped (project x))
257 665c255d 2023-08-04 jrmu (raised (raise dropped)))
258 665c255d 2023-08-04 jrmu (if (and (not (eq? (type-tag x) (type-tag dropped)))
259 665c255d 2023-08-04 jrmu (equ? x raised))
260 665c255d 2023-08-04 jrmu (drop dropped)
263 665c255d 2023-08-04 jrmu (define (apply-generic op . args)
264 665c255d 2023-08-04 jrmu (define (find-and-apply-op)
265 665c255d 2023-08-04 jrmu (let* ((type-tags (map type-tag args))
266 665c255d 2023-08-04 jrmu (proc (get op type-tags)))
268 665c255d 2023-08-04 jrmu (apply proc (map contents args))
269 665c255d 2023-08-04 jrmu (if (> (length args) 1)
270 665c255d 2023-08-04 jrmu (let* ((highest-type (find-highest-type type-tags))
271 665c255d 2023-08-04 jrmu (mapped-args (raise-all-to highest-type args))
272 665c255d 2023-08-04 jrmu (mapped-types (map type-tag mapped-args))
273 665c255d 2023-08-04 jrmu (mapped-proc (get op mapped-types)))
274 665c255d 2023-08-04 jrmu (if mapped-proc
275 665c255d 2023-08-04 jrmu (apply mapped-proc (map contents mapped-args))
277 665c255d 2023-08-04 jrmu "No method for these types -- APPLY-GENERIC"
278 665c255d 2023-08-04 jrmu (list op type-tags))))))))
279 665c255d 2023-08-04 jrmu (let ((result (find-and-apply-op)))
280 665c255d 2023-08-04 jrmu (if (and (pair? result)
281 665c255d 2023-08-04 jrmu (memq (type-tag result) tower-of-types))
282 665c255d 2023-08-04 jrmu (drop result)
285 665c255d 2023-08-04 jrmu (define (apply-raise x types)
286 665c255d 2023-08-04 jrmu (cond ((null? types)
287 665c255d 2023-08-04 jrmu (error "Type not found in the tower-of-types"
288 665c255d 2023-08-04 jrmu (list (type-tag x) tower-of-types)))
289 665c255d 2023-08-04 jrmu ((eq? (type-tag x) (car types))
290 665c255d 2023-08-04 jrmu (if (null? (cdr types))
292 665c255d 2023-08-04 jrmu (let ((raiser (get-coercion (type-tag x) (cadr types))))
294 665c255d 2023-08-04 jrmu (raiser (contents x))
295 665c255d 2023-08-04 jrmu (error "No coercion procedure found for types"
296 665c255d 2023-08-04 jrmu (list (type-tag x) (cadr types)))))))
297 665c255d 2023-08-04 jrmu (else (apply-raise x (cdr types)))))
298 665c255d 2023-08-04 jrmu (define (raise x)
299 665c255d 2023-08-04 jrmu (apply-raise x tower-of-types))
300 665c255d 2023-08-04 jrmu (define (project x)
301 665c255d 2023-08-04 jrmu (apply-raise x (reverse tower-of-types)))
302 665c255d 2023-08-04 jrmu (define (project x)
303 665c255d 2023-08-04 jrmu (define (apply-project types)
304 665c255d 2023-08-04 jrmu (cond ((eq? (type-tag x) (car types)) x)
305 665c255d 2023-08-04 jrmu ((or (null? types) (null? (cdr types)))
306 665c255d 2023-08-04 jrmu (error "type not found in the tower-of-types"
307 665c255d 2023-08-04 jrmu (list (type-tag x) tower-of-types)))
308 665c255d 2023-08-04 jrmu ((eq? (type-tag x) (cadr types))
309 665c255d 2023-08-04 jrmu (let ((projector (get-coercion (type-tag x) (car types))))
310 665c255d 2023-08-04 jrmu (if projector
311 665c255d 2023-08-04 jrmu (projector (contents x))
312 665c255d 2023-08-04 jrmu (error "No coercion procedure found for types"
313 665c255d 2023-08-04 jrmu (list (car types) (type-tag x))))))
314 665c255d 2023-08-04 jrmu (else (apply-project (cdr types)))))
315 665c255d 2023-08-04 jrmu (apply-project tower-of-types))
317 665c255d 2023-08-04 jrmu (define (drop x)
318 665c255d 2023-08-04 jrmu (let* ((dropped (project x))
319 665c255d 2023-08-04 jrmu (raised (raise dropped)))
320 665c255d 2023-08-04 jrmu (if (and (not (eq? (type-tag x) (type-tag dropped)))
321 665c255d 2023-08-04 jrmu (equ? x raised))
322 665c255d 2023-08-04 jrmu (drop dropped)
325 665c255d 2023-08-04 jrmu (define (apply-generic op . args)
326 665c255d 2023-08-04 jrmu (define (find-and-apply-op)
327 665c255d 2023-08-04 jrmu (let* ((type-tags (map type-tag args))
328 665c255d 2023-08-04 jrmu (proc (get op type-tags)))
330 665c255d 2023-08-04 jrmu (apply proc (map contents args))
331 665c255d 2023-08-04 jrmu (if (> (length args) 1)
332 665c255d 2023-08-04 jrmu (let* ((highest-type (find-highest-type type-tags))
333 665c255d 2023-08-04 jrmu (mapped-args (raise-all-to highest-type args))
334 665c255d 2023-08-04 jrmu (mapped-types (map type-tag mapped-args))
335 665c255d 2023-08-04 jrmu (mapped-proc (get op mapped-types)))
336 665c255d 2023-08-04 jrmu (if mapped-proc
337 665c255d 2023-08-04 jrmu (apply-mapped-proc (map contents mapped-args))
338 665c255d 2023-08-04 jrmu (error "No method for these types -- APPLY-GENERIC"
339 665c255d 2023-08-04 jrmu (list op type-tags))))))))
340 665c255d 2023-08-04 jrmu (let ((result (find-and-apply-op)))
341 665c255d 2023-08-04 jrmu (if (and (pair? result)
342 665c255d 2023-08-04 jrmu (memq (type-tag result) tower-of-types))
343 665c255d 2023-08-04 jrmu (drop result)
346 665c255d 2023-08-04 jrmu (define (integer->rational n)
347 665c255d 2023-08-04 jrmu (make-rational n 1))
348 665c255d 2023-08-04 jrmu (put 'raise '(integer)
349 665c255d 2023-08-04 jrmu (lambda (i) (integer->rational i)))
350 665c255d 2023-08-04 jrmu (define (rational->real r)
352 665c255d 2023-08-04 jrmu (exact->inexact
353 665c255d 2023-08-04 jrmu (/ (numer r) (denom r)))))
354 665c255d 2023-08-04 jrmu (put 'raise '(rational)
355 665c255d 2023-08-04 jrmu (lambda (r) (rational->real r)))
356 665c255d 2023-08-04 jrmu (define (real->complex r)
357 665c255d 2023-08-04 jrmu (make-complex-from-real-imag r 0))
358 665c255d 2023-08-04 jrmu (put 'raise '(real)
359 665c255d 2023-08-04 jrmu (lambda (r) (real->complex r)))
360 665c255d 2023-08-04 jrmu (define (raise x)
361 665c255d 2023-08-04 jrmu (apply-generic 'raise x))
363 665c255d 2023-08-04 jrmu (define (apply-generic-r op . args)
364 665c255d 2023-08-04 jrmu (define (no-method type-tags)
365 665c255d 2023-08-04 jrmu (error "No method for these types"
366 665c255d 2023-08-04 jrmu (list op type-tags)))
367 665c255d 2023-08-04 jrmu (define (raise-into s t)
368 665c255d 2023-08-04 jrmu (let ((s-type (type-tag s))
369 665c255d 2023-08-04 jrmu (t-type (type-tag t)))
371 665c255d 2023-08-04 jrmu ((equal? s-type t-type) s)
372 665c255d 2023-08-04 jrmu ((get 'raise (list s-type))
373 665c255d 2023-08-04 jrmu (raise-into ((get 'raise (list s-type)) (contents s)) t))
375 665c255d 2023-08-04 jrmu (let ((type-tags (map type-tag args)))
376 665c255d 2023-08-04 jrmu (let ((proc (get op type-tags)))
378 665c255d 2023-08-04 jrmu (apply proc (map contents args))
379 665c255d 2023-08-04 jrmu (if (= (length args) 2)
380 665c255d 2023-08-04 jrmu (let ((o1 (car args))
381 665c255d 2023-08-04 jrmu (o2 (cadr args)))
382 665c255d 2023-08-04 jrmu (cond ((raise-into o1 o2)
383 665c255d 2023-08-04 jrmu (apply-generic-r op (raise-into o1 o2) o2))
384 665c255d 2023-08-04 jrmu ((raise-into o2 o1)
385 665c255d 2023-08-04 jrmu (apply-generic-r op o1 (raise-into o2 o1)))
386 665c255d 2023-08-04 jrmu (t (no-method type-tags))))
387 665c255d 2023-08-04 jrmu (no-method type-tags)))))
389 665c255d 2023-08-04 jrmu (put 'project '(rational)
390 665c255d 2023-08-04 jrmu (lambda (r)
391 665c255d 2023-08-04 jrmu (make-scheme-number
392 665c255d 2023-08-04 jrmu (floor (/ (numer r) (denom r))))))
393 665c255d 2023-08-04 jrmu (put 'project '(real)
394 665c255d 2023-08-04 jrmu (lambda (r)
395 665c255d 2023-08-04 jrmu (let ((scheme-rat
396 665c255d 2023-08-04 jrmu (rationalize
397 665c255d 2023-08-04 jrmu (inexact->exact r) 1/100)))
398 665c255d 2023-08-04 jrmu (make-rational (numerator scheme-rat)
399 665c255d 2023-08-04 jrmu (denominator scheme-rat)))))
400 665c255d 2023-08-04 jrmu (put 'project '(complex)
401 665c255d 2023-08-04 jrmu (lambda (c) (make-real (real-part c))))
403 665c255d 2023-08-04 jrmu (define (drop num)
404 665c255d 2023-08-04 jrmu (let ((project-proc
405 665c255d 2023-08-04 jrmu (get 'project (list (type-tag num)))))
406 665c255d 2023-08-04 jrmu (if project-proc
407 665c255d 2023-08-04 jrmu (let ((dropped (project-proc (contents num))))
408 665c255d 2023-08-04 jrmu (if (equ? num (raise dropped))
409 665c255d 2023-08-04 jrmu (drop dropped)
412 665c255d 2023-08-04 jrmu (define (apply-generic-r op . args)
413 665c255d 2023-08-04 jrmu (define (no-method type-tags)
414 665c255d 2023-08-04 jrmu (error "No method for these types"
415 665c255d 2023-08-04 jrmu (list op type-tags)))
416 665c255d 2023-08-04 jrmu (define (raise-into s t)
417 665c255d 2023-08-04 jrmu "Tries to raise s into the type of t. On success,
418 665c255d 2023-08-04 jrmu returns the raised s. Otherwise, returns #f"
419 665c255d 2023-08-04 jrmu (let ((s-type (type-tag s))
420 665c255d 2023-08-04 jrmu (t-type (type-tag t)))
421 665c255d 2023-08-04 jrmu (cond ((equal? s-type t-type) s)
422 665c255d 2023-08-04 jrmu ((get 'raise (list s-type))
423 665c255d 2023-08-04 jrmu (raise-into ((get 'raise (list s-type))
