(define (install-project-packege)
(define (project x) (apply-generic 'project x))
(put 'project 'complex (lambda (x)
(make-real (real-part x))))
(put 'project 'real (lambda (x)
(let ((rational (inexact->exact x)))
(make-rational (numerator rational)
(denominator rational)))))
(put 'project 'rational (lambda (x)
(make-scheme-number (round (/ (numer x)
(denom x))))))
'done)
(define (drop x)
(let ((projected ((get 'project (type-tag x)) x)))
(let ((raised ((get 'raise (type-tag projected)) projected)))
(if (equ? x raised)
(drop projected)
x))))
(define (apply-generic op . args)
(let ((type-tags (map type-tag args))
(tower '(complex real rational scheme-number)))
(define (same-type? a b)
(eq? (type-tag a) (type-tag b)))
(define (type-< a b)
(cond ((same-type? a b) false)
((eq? (type-tag a) (car tower)) true)
((eq? (type-tag b) (car tower)) false)
(else (type-< ((get 'raise (type-tag a)) a)
((get 'raise (type-tag b)) b)))))
(define (highest-type lst)
(let iter ((result (car lst))
(rest (cdr lst)))
(cond ((null? rest) result)
((type-< result (car rest))
(iter (car rest) (cdr rest)))
(else
(iter result (cdr rest))))))
(define (same-highest-type high lst)
(map (lambda (x) (let iter ((target x))
(if (eq? high target)
target
(iter ((get 'raise (type-tag target))
target)))))
lst))
(let ((proc (get op types)))
(if proc
(drop (apply proc (map contents args)))
(let ((new-args (same-highest-type (highest-type args)
args)))
(let ((proc (get op (type-tag (car new-args)))))
(if proc
(dorp (apply proc (map contents new-args)))
(error "Nomethod for these types"
(list op type-tags)))))))))
