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