1 665c255d 2023-08-04 jrmu (define (find-highest-type l)
  2 665c255d 2023-08-04 jrmu   (define (filter-type t f)
  3 665c255d 2023-08-04 jrmu     (cond ((null? f) '())
  4 665c255d 2023-08-04 jrmu 	  ((eq? (car f) t) (filter-type t (cdr f)))
  5 665c255d 2023-08-04 jrmu 	  (else (cons (car f) (filter-type t (cdr f))))))
  6 665c255d 2023-08-04 jrmu   (define (find-highest highest remaining-tower remaining-list)
  7 665c255d 2023-08-04 jrmu     (cond ((null? remaining-list) highest)
  8 665c255d 2023-08-04 jrmu 	  ((null? remaining-tower)
  9 665c255d 2023-08-04 jrmu 	   (error "Cannot find highest type from non-tower types -- FIND-HIGHEST-TYPE"
 10 665c255d 2023-08-04 jrmu 		  remaining-list))
 11 665c255d 2023-08-04 jrmu 	  (else (find-highest (car remaining-tower)
 12 665c255d 2023-08-04 jrmu 			      (cdr remaining-tower)
 13 665c255d 2023-08-04 jrmu 			      (filter-type (car remaining-tower) remaining-list)))))
 14 665c255d 2023-08-04 jrmu   (find-highest #f tower-of-types l))
 15 665c255d 2023-08-04 jrmu 
 16 665c255d 2023-08-04 jrmu (find-highest-type '(integer real rational real))
 17 665c255d 2023-08-04 jrmu (find-highest-type '(rational rational rational))
 18 665c255d 2023-08-04 jrmu (find-highest-type '(complex real rational integer))
 19 665c255d 2023-08-04 jrmu (find-highest-type '())
 20 665c255d 2023-08-04 jrmu (find-highest-type '(integer wibble real wobble complex))
 21 665c255d 2023-08-04 jrmu 
 22 665c255d 2023-08-04 jrmu (define (raise-to type value)
 23 665c255d 2023-08-04 jrmu   (cond ((eq? type (type-tag value)) value)
 24 665c255d 2023-08-04 jrmu 	((memq type tower-of-types) (raise-to type (raise value)))
 25 665c255d 2023-08-04 jrmu 	(else (error "Cannot raise to non-tower type -- RAISE-TO"
 26 665c255d 2023-08-04 jrmu 		     (list type tower-of-types)))))
 27 665c255d 2023-08-04 jrmu (raise-to 'real (make-integer 4))
 28 665c255d 2023-08-04 jrmu (raise-to 'complex (make-rational 3 4))
 29 665c255d 2023-08-04 jrmu (raise-to 'real (make-real 3.14159))
 30 665c255d 2023-08-04 jrmu (raise-to 'wibble (make-integer 42))
 31 665c255d 2023-08-04 jrmu 
 32 665c255d 2023-08-04 jrmu (define (raise-all-to type values)
 33 665c255d 2023-08-04 jrmu   (if (null? values)
 34 665c255d 2023-08-04 jrmu       '()
 35 665c255d 2023-08-04 jrmu       (cons (raise-to-type (car values)) (raise-all-to type (cdr values)))))
 36 665c255d 2023-08-04 jrmu 
 37 665c255d 2023-08-04 jrmu (define (apply-generic op . args)
 38 665c255d 2023-08-04 jrmu   (let* ((type-tags (map type-tag args))
 39 665c255d 2023-08-04 jrmu 	 (proc (get op type-tags)))
 40 665c255d 2023-08-04 jrmu     (if proc
 41 665c255d 2023-08-04 jrmu 	(apply proc (map contents args))
 42 665c255d 2023-08-04 jrmu 	(if (> (length args) 1)
 43 665c255d 2023-08-04 jrmu 	    (let* ((highest-type (find-highest-type type-tags))
 44 665c255d 2023-08-04 jrmu 		   (mapped-args (raise-all-to highest-type args))
 45 665c255d 2023-08-04 jrmu 		   (mapped-types (map type-tag mapped-args))
 46 665c255d 2023-08-04 jrmu 		   (mapped-proc (get op mapped-types)))
 47 665c255d 2023-08-04 jrmu 	      (if mapped-proc
 48 665c255d 2023-08-04 jrmu 		  (apply mapped-proc (map contents mapped-args))
 49 665c255d 2023-08-04 jrmu 		  (error
 50 665c255d 2023-08-04 jrmu 		   "No method for these types -- APPLY-GENERIC"
 51 665c255d 2023-08-04 jrmu 		   (list op type-tags))))))))
 52 665c255d 2023-08-04 jrmu (put 'addd '(integer integer integer)
 53 665c255d 2023-08-04 jrmu      (lambda (x y z) (tag (+ x y z))))
 54 665c255d 2023-08-04 jrmu (define (addd x y z)
 55 665c255d 2023-08-04 jrmu   (make-rat (+ (* (numer x) (denom y) (denom z))
 56 665c255d 2023-08-04 jrmu 	       (* (denom x) (numer y) (denom z))
 57 665c255d 2023-08-04 jrmu 	       (* (denom x) (denom y) (numer z)))
 58 665c255d 2023-08-04 jrmu 	    (* (denom x) (denom y) (denom z))))
 59 665c255d 2023-08-04 jrmu (put 'addd '(rational rational rational)
 60 665c255d 2023-08-04 jrmu      (lambda (x y z) (tag (addd x y z))))
 61 665c255d 2023-08-04 jrmu (put 'add '(real real real)
 62 665c255d 2023-08-04 jrmu      (lambda (x y z) (tag (+ x y z))))
 63 665c255d 2023-08-04 jrmu (addd (make-real 3.14159) (make-rational 3 4) (make-complex-from-real-imag 1 7))
 64 665c255d 2023-08-04 jrmu 
 65 665c255d 2023-08-04 jrmu (define (raise x) (apply-generic 'raise x))
 66 665c255d 2023-08-04 jrmu (put 'raise '(scheme-number)
 67 665c255d 2023-08-04 jrmu      (lambda (x)
 68 665c255d 2023-08-04 jrmu        (if (exact-integer? x)
 69 665c255d 2023-08-04 jrmu 	   (make-rational x 1)
 70 665c255d 2023-08-04 jrmu 	   (make-complex-from-real-imag x 0))))
 71 665c255d 2023-08-04 jrmu (put 'raise '(rational)
 72 665c255d 2023-08-04 jrmu      (lambda (r)
 73 665c255d 2023-08-04 jrmu        (make-scheme-number (exact->inexact (/ (numer r) (denom r))))))
 74 665c255d 2023-08-04 jrmu 
 75 665c255d 2023-08-04 jrmu (define (tower-level x)
 76 665c255d 2023-08-04 jrmu   (let ((typex (type-tag x)))
 77 665c255d 2023-08-04 jrmu     (cond ((eq? typex 'rational) 1)
 78 665c255d 2023-08-04 jrmu 	  ((eq? typex 'complex) 3)
 79 665c255d 2023-08-04 jrmu 	  (else
 80 665c255d 2023-08-04 jrmu 	   (let ((y (contents x)))
 81 665c255d 2023-08-04 jrmu 	     (if (exact-integer? y)
 82 665c255d 2023-08-04 jrmu 		 0
 83 665c255d 2023-08-04 jrmu 		 2))))))
 84 665c255d 2023-08-04 jrmu (define (raise-to level x)
 85 665c255d 2023-08-04 jrmu   (if (= level (tower-level x))
 86 665c255d 2023-08-04 jrmu       x
 87 665c255d 2023-08-04 jrmu       (raise-to level (raise x))))
 88 665c255d 2023-08-04 jrmu 
 89 665c255d 2023-08-04 jrmu (define (apply-generic op . args)
 90 665c255d 2023-08-04 jrmu   (let ((typetags (map type-tag args)))
 91 665c255d 2023-08-04 jrmu     (let ((proc (get op type-tags)))
 92 665c255d 2023-08-04 jrmu       (if proc
 93 665c255d 2023-08-04 jrmu 	  (apply proc (map contents args))
 94 665c255d 2023-08-04 jrmu 	  (if (= (length args) 2)
 95 665c255d 2023-08-04 jrmu 	      (let* ((a1 (car args))
 96 665c255d 2023-08-04 jrmu 		     (a2 (cadr args))
 97 665c255d 2023-08-04 jrmu 		     (level1 (tower-level a1))
 98 665c255d 2023-08-04 jrmu 		     (level2 (tower-level a2)))
 99 665c255d 2023-08-04 jrmu 		(cond ((< level1 level2)
100 665c255d 2023-08-04 jrmu 		       (apply-generic op (raise-to level2 a1) a2))
101 665c255d 2023-08-04 jrmu 		      ((< level2 level1)
102 665c255d 2023-08-04 jrmu 		       (apply-generic op a1 (raise-to level1 a2)))
103 665c255d 2023-08-04 jrmu 		      (else
104 665c255d 2023-08-04 jrmu 		       (error "No method for these types"
105 665c255d 2023-08-04 jrmu 			      (list op type-tags)))))
106 665c255d 2023-08-04 jrmu 	      (error "No method for these types"
107 665c255d 2023-08-04 jrmu 		     (lsit op type-tags)))))))
108 665c255d 2023-08-04 jrmu 
109 665c255d 2023-08-04 jrmu (define (apply-generic-r op . args)
110 665c255d 2023-08-04 jrmu   (define (no-method type-tags)
111 665c255d 2023-08-04 jrmu     (error "No method for these types"
112 665c255d 2023-08-04 jrmu 	   (list op type-tags)))
113 665c255d 2023-08-04 jrmu   (define (raise-into s t)
114 665c255d 2023-08-04 jrmu     (let ((s-type (type-tag s))
115 665c255d 2023-08-04 jrmu 	  (t-type (type-tag t)))
116 665c255d 2023-08-04 jrmu       (cond ((equal? s-type t-type) s)
117 665c255d 2023-08-04 jrmu 	    ((get 'raise (list s-type))
118 665c255d 2023-08-04 jrmu 	     (raise-into ((get 'raise (list s-type)) (contents s)) t))
119 665c255d 2023-08-04 jrmu 	    (t #f))))
120 665c255d 2023-08-04 jrmu   (let ((type-tags (map type-tag args)))
121 665c255d 2023-08-04 jrmu     (let ((proc (get op type-tags)))
122 665c255d 2023-08-04 jrmu       (if proc
123 665c255d 2023-08-04 jrmu 	  (apply proc (map contents args))
124 665c255d 2023-08-04 jrmu 	  (if (= (length args) 2)
125 665c255d 2023-08-04 jrmu 	      (let ((o1 (car args))
126 665c255d 2023-08-04 jrmu 		    (o2 (cadr args)))
127 665c255d 2023-08-04 jrmu 		(cond
128 665c255d 2023-08-04 jrmu 		 ((raise-into o1 o2)
129 665c255d 2023-08-04 jrmu 		  (apply-generic-r op (raise-into o1 o2) o2))
130 665c255d 2023-08-04 jrmu 		 ((raise-into o2 o1)
131 665c255d 2023-08-04 jrmu 		  (apply-generic-r op o2 (raise-into o2 o1)))
132 665c255d 2023-08-04 jrmu 		 (t (no-method type-tags))))
133 665c255d 2023-08-04 jrmu 	      (no-method type-tags))))))