2015/11/02

# SICP 問題 2.84

``````(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)))
;; aよりもbのほうが階層が高いか調べる述語
;; 両方をraiseしながらcomplexに先になったほうが階層が高い
(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))))))
;; リストの要素すべてを最も階層の高い型highまでraiseする
(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
(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
(apply proc (map contents new-args))
(error "Nomethod for these types"
(list op type-tags)))))))))
``````