じぇねりっく！じぇねりっく！
コードがめちゃくちゃ長いです。
apply-genericでうまいことやってみよう。
前準備 (基本)
(define (square x) (* x x))
(define-values
(put get)
(let ((*table* '()))
(values
(lambda (op type proc)
(set! *table* (cons (cons (cons op type) proc) *table*)))
(lambda (op type)
(let ((key (cons op type)))
(let ((item (assoc key *table*)))
(and item (cdr item)))))
)))
(define (attach-tag type-tag contents)
(cons type-tag contents))
(define (type-tag datum)
(if (pair? datum)
(car datum)
(error "Bad tagged datum -- TYPE-TAG" datum)))
(define (contents datum)
(if (pair? datum)
(cdr datum)
(error "Bad tagged datum -- CONTENTS" datum)))
(define (apply-generic op . args)
(let ((type-tags (map type-tag args)))
(let ((proc (get op type-tags)))
(if proc
(apply proc (map contents args))
(error
"No method for these types -- APPLY-GENERIC"
(list op type-tags))))))
前準備 (実数(Scheme組み込みの数))
(define (install-scheme-number-package)
(define (tag x)
(attach-tag 'scheme-number x))
(put 'add '(scheme-number scheme-number)
(lambda (x y) (tag (+ x y))))
(put 'sub '(scheme-number scheme-number)
(lambda (x y) (tag (- x y))))
(put 'mul '(scheme-number scheme-number)
(lambda (x y) (tag (* x y))))
(put 'div '(scheme-number scheme-number)
(lambda (x y) (tag (/ x y))))
(put 'make 'scheme-number
(lambda (x) (tag x)))
'done)
前準備 (整数)
(define (install-integer-package)
(define (tag x)
(attach-tag 'integer x))
(put 'add '(scheme-number scheme-number)
(lambda (x y) (tag (+ x y))))
(put 'sub '(scheme-number scheme-number)
(lambda (x y) (tag (- x y))))
(put 'mul '(scheme-number scheme-number)
(lambda (x y) (tag (* x y))))
(put 'div '(scheme-number scheme-number)
(lambda (x y) (tag (/ x y))))
(put 'make 'integer
(lambda (x)
(if (integer? x)
(tag x)
(error "not an integer:" x))))
'done)
前準備 (直交座標表示の複素数)
(define (install-rectangular-package)
(define (real-part z) (car z))
(define (imag-part z) (cdr z))
(define (make-from-real-imag x y) (cons x y))
(define (magnitude z)
(sqrt (+ (square (real-part z))
(square (imag-part z)))))
(define (angle z)
(atan (imag-part z) (real-part z)))
(define (make-from-mag-ang r a)
(cons (* r (cos a)) (* r (sin a))))
(define (tag x) (attach-tag 'rectangular x))
(put 'real-part '(rectangular) real-part)
(put 'imag-part '(rectangular) imag-part)
(put 'magnitude '(rectangular) magnitude)
(put 'angle '(rectangular) angle)
(put 'make-from-real-imag 'rectangular
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'rectangular
(lambda (r a) (tag (make-from-mag-ang r a))))
'done)
(define (make-complex-from-real-imag x y)
((get 'make-from-real-imag 'complex) x y))
前準備 (極座標表示の複素数)
(define (install-polar-package)
(define (magnitude z) (car z))
(define (angle z) (cdr z))
(define (make-from-mag-ang r a) (cons r a))
(define (real-part z)
(* (magnitude z) (cos (angle z))))
(define (imag-part z)
(* (magnitude z) (sin (angle z))))
(define (make-from-real-imag x y)
(cons (sqrt (+ (square x) (square y)))
(atan y x)))
(define (tag x) (attach-tag 'polar x))
(put 'real-part '(polar) real-part)
(put 'imag-part '(polar) imag-part)
(put 'magnitude '(polar) magnitude)
(put 'angle '(polar) angle)
(put 'make-from-real-imag 'polar
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'polar
(lambda (r a) (tag (make-from-mag-ang r a))))
'done)
(define (make-complex-from-mag-ang r a)
((get 'make-from-mag-ang 'complex) r a))
前準備 (複素数)
(define (install-complex-package)
(define (make-from-real-imag x y)
((get 'make-from-real-imag 'rectangular) x y))
(define (make-from-mag-ang r a)
((get 'make-from-mag-ang 'polar) r a))
(define (add-complex z1 z2)
(make-from-real-imag (+ (real-part z1) (real-part z2))
(+ (imag-part z1) (imag-part z2))))
(define (sub-complex z1 z2)
(make-from-real-imag (- (real-part z1) (real-part z2))
(- (imag-part z1) (imag-part z2))))
(define (mul-complex z1 z2)
(make-from-mag-ang (* (magnitude z1) (magnitude z2))
(+ (angle z1) (angle z2))))
(define (div-complex z1 z2)
(make-from-mag-ang (/ (magnitude z1) (magnitude z2))
(- (angle z1) (angle z2))))
(define (tag z) (attach-tag 'complex z))
(define (real-part z) (apply-generic 'real-part z))
(define (imag-part z) (apply-generic 'imag-part z))
(define (magnitude z) (apply-generic 'magnitude z))
(define (angle z) (apply-generic 'angle z))
(put 'add '(complex complex) (lambda (z1 z2) (tag (add-complex z1 z2))))
(put 'sub '(complex complex) (lambda (z1 z2) (tag (sub-complex z1 z2))))
(put 'mul '(complex complex) (lambda (z1 z2) (tag (mul-complex z1 z2))))
(put 'div '(complex complex) (lambda (z1 z2) (tag (div-complex z1 z2))))
(put 'make-from-real-imag 'complex (lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'complex (lambda (r a) (tag (make-from-mag-ang r a))))
(put 'real-part '(complex) real-part)
(put 'imag-part '(complex) imag-part)
(put 'magnitude '(complex) magnitude)
(put 'angle '(complex) angle)
'done)
前準備 (ジェネリックな関数)
(define (add x y) (apply-generic 'add x y)) (define (sub x y) (apply-generic 'sub x y)) (define (mul x y) (apply-generic 'mul x y)) (define (div x y) (apply-generic 'div x y)) (define (real-part z) (apply-generic 'real-part z)) (define (imag-part z) (apply-generic 'imag-part z)) (define (magnitude z) (apply-generic 'magnitude z)) (define (angle z) (apply-generic 'angle z)) (install-integer-package) (install-rational-package) (install-scheme-number-package) (install-rectangular-package) (install-polar-package) (install-complex-package)
2.77
(magnitude (make-complex-from-real-imag 3 4)) ; apply-generic: magnitude (complex rectangular 3 . 4) ; apply-generic: magnitude (rectangular 3 . 4) ; => 5
2.78 (プリミティブな型も自然に扱えるように)
(define (attach-tag type-tag contents)
(if (or (symbol? contents) (number? contents))
contents
(cons type-tag contents)))
(define (type-tag datum)
(cond
((pair? datum) (car datum))
((symbol? datum) 'scheme-symbol)
;((integer? datum) 'integer)
((number? datum) 'scheme-number)
((boolean? datum) 'scheme-boolean)
(else (error "Bad tagged datum -- TYPE-TAG" datum))))
(define (contents datum)
(cond
((pair? datum) (cdr datum))
((or (symbol? datum) (number? datum)) datum)
(error "Bad tagged datum -- CONTENTS" datum)))type-tagでinteger?のとこをコメントアウトしてるのは、後で見る型変換の時にいろいろ困るから。
2.79 (適当にジェネリックな関数を作ってみる)
(define (equ? x y) (apply-generic 'equ? x y))
(put 'equ? '(scheme-number scheme-number) =)
(put 'equ? '(rational rational) equal?)
(put 'equ? '(integer integer) =)
(let ((complex-eq? (lambda (z1 z2)
(and (= (real-part z1) (real-part z2))
(= (imag-part z1) (imag-part z2))))))
(put 'equ? '(rectangular rectangular) complex-eq?)
(put 'equ? '(polar polar) complex-eq?)
(put 'equ? '(complex complex) complex-eq?))
2.80 (適当にジェネリックな関数を作ってみる)
(define (=zero? x) (apply-generic '=zero? x)) (put '=zero? '(scheme-number) zero?) (put '=zero? '(rational) (lambda (r) (zero? (car r)))) (put '=zero? '(integer) zero?) (let ((complex-=zero? (lambda (z) (and (zero? (real-part z1)) (zero? (imag-part z1)))))) (put '=zero? '(rectangular) complex-=zero?) (put '=zero? '(polar) complex-=zero?) (put '=zero? '(complex) complex-=zero?))
前準備 (型変換編)
ここから型変換も入ってくる。
(define-values
(put-coercion get-coercion)
(let ((*coercion-table* '()))
(values
(lambda (from to proc)
(set! *coercion-table* (cons (cons (cons from to) proc) *coercion-table*)))
(lambda (from to)
(let ((key (cons from to)))
(let ((item (assoc key *coercion-table*)))
(and item (cdr item)))))
)))
(define (apply-generic op . args)
(let ((type-tags (map type-tag args)))
(let ((proc (get op type-tags)))
(if proc
(apply proc (map contents args))
(if (= (length args) 2)
(let ((type1 (car type-tags))
(type2 (cadr type-tags))
(a1 (car args))
(a2 (cadr args)))
(let ((t1->t2 (get-coercion type1 type2))
(t2->t1 (get-coercion type2 type1)))
(cond (t1->t2
(apply-generic op (t1->t2 a1) a2))
(t2->t1
(apply-generic op a1 (t2->t1 a2)))
(else
(error "No method for these types"
(list op type-tags))))))
(error "No method for these types"
(list op type-tags)))))))
(define (scheme-number->complex n) (make-complex-from-real-imag (contents n) 0))
(define (rational->scheme-number r) (/ (car (contents r)) (cdr (contents r))))
(define (integer->rational n) (make-rational (contents n) 1))
(put-coercion 'scheme-number 'complex scheme-number->complex)
(put-coercion 'rational 'scheme-number rational->scheme-number)
(put-coercion 'integer 'rational integer->rational)
(put-coercion 'integer 'scheme-number (compose rational->scheme-number integer->rational))
(put-coercion 'integer 'complex (compose scheme-number->complex
(compose rational->scheme-number integer->rational)))こんな。
(add 1 (make-complex-from-real-imag 3 4)) ; => (complex rectangular 4 . 4)
2.81
(define (scheme-number->scheme-number n) n)
(define (complex->complex z) z)
(put-coercion 'scheme-number 'scheme-number scheme-number->scheme-number)
(put-coercion 'complex 'complex complex->complex)
(define (exp x y) (apply-generic 'exp x y))
(put 'exp '(scheme-number scheme-number)
(lambda (x y) (attach-tag 'scheme-number (expt x y))))
(define (apply-generic op . args)
(let ((type-tags (map type-tag args)))
(let ((proc (get op type-tags)))
(if proc
(apply proc (map contents args))
(if (= (length args) 2)
(let ((type1 (car type-tags))
(type2 (cadr type-tags))
(a1 (car args))
(a2 (cadr args)))
(if (equal? type1 type2)
(error "No method for these types"
(list op type-tags))
(let ((t1->t2 (get-coercion type1 type2))
(t2->t1 (get-coercion type2 type1)))
(cond (t1->t2
(apply-generic op (t1->t2 a1) a2))
(t2->t1
(apply-generic op a1 (t2->t1 a2)))
(else
(error "No method for these types"
(list op type-tags)))))))
(error "No method for these types"
(list op type-tags)))))))
2.82
上手くいかない場合が思いつかないからあとで答えみる。
2.83 (一つ上の型に変換するraise)
(define (raise x) (apply-generic 'raise x)) (put 'raise '(scheme-number) (lambda (x) (make-complex-from-real-imag x 0))) (put 'raise '(rational) rational->scheme-number) (put 'raise '(integer) (lambda (n) (make-rational n 1)))
2.84 (apply-genericにraiseを使用する)
(define (upper-type x) (apply-generic 'upper-type x))
(put 'upper-type '(complex) (lambda (x) #f))
(put 'upper-type '(scheme-number) (lambda (x) 'complex))
(put 'upper-type '(rational) (lambda (x) 'scheme-number))
(put 'upper-type '(integer) (lambda (x) 'rational))
(define (type< x y)
(let ((upper-type-x (upper-type x)))
(cond
((eq? upper-type-x #f) #f)
((eq? upper-type-x (type-tag y)) #t)
(else (type< (raise x) y)))))
(define (apply-generic op . args)
(let ((type-tags (map type-tag args)))
(let ((proc (get op type-tags)))
(if proc
(apply proc (map contents args))
(if (= (length args) 2)
(let ((type1 (car type-tags))
(type2 (cadr type-tags))
(a1 (car args))
(a2 (cadr args)))
(cond
((type< a1 a2)
(apply-generic op (raise a1) a2))
((type< a2 a1)
(apply-generic op a1 (raise a2)))
(else
(error "No method for these types"
(list op type-tags)))
))
(error "No method for these types"
(list op type-tags)))))))
2.85 (シンプルな表現に落とす)
raiseやdropの中でapply-genericを呼び出しているので無限ループに陥ったりして大変だった。
(define (drop x)
(let ((project (get 'project (list (type-tag x)))))
(if project
(let ((dropped (project x)))
(let ((raise (get 'raise (list (type-tag dropped)))))
(if (and raise (equ? (raise dropped) x))
(drop dropped)
x)))
x)))
(define (project x) (apply-generic 'project x))
(put 'project '(complex) (lambda (z) (apply-generic 'real-part z)))
(define (raise x) ((get 'raise (list (type-tag x))) x))
(define (apply-generic op . args)
(let ((type-tags (map type-tag args)))
(let ((proc (get op type-tags)))
(if proc
(drop (apply proc (map contents args)))
(if (= (length args) 2)
(let ((type1 (car type-tags))
(type2 (cadr type-tags))
(a1 (car args))
(a2 (cadr args)))
(cond
((type< a1 a2)
(apply-generic op (raise a1) a2))
((type< a2 a1)
(apply-generic op a1 (raise a2)))
(else
(error "No method for these types"
(list op type-tags)))
))
(error "No method for these types"
(list op type-tags)))))))
2.86 (complexを構成する数もrationalとかで表現してみる)
(put 'sqrt '(scheme-number) sqrt) (define (square-root x) (apply-generic 'sqrt x)) (put 'sin '(scheme-number) sin) (define (sine x) (apply-generic 'sin x)) (put 'cos '(scheme-number) cos) (define (cosine x) (apply-generic 'cos x)) (put 'atan '(scheme-number scheme-number) atan) (define (arctan x y) (apply-generic 'atan x y))
冗長なので省略するけど、install-rectangular-package, install-polar-package, install-complex-package中でs/sqrt/square-root/g,s/sin/sine/g,s/cos/cosine/g,s/atan/arctan/gする。
で、type-tagでinteger?の判別をスキップした件は、たとえばintegerな"1"をraiseしていったときに、integer->rational->scheme-number->integer->...とループしてしまったから。scheme-numberでずぼらしなけりゃいいんだろうけどもう面倒で面倒で。
