みんな大好き汎用算術演算の問題も最後になってしまいました。
問題 2.86
equ? や =zero? のように apply-generic の戻り値が真偽値になる場合があります。このとき真偽値は drop できまいので、type-tag で真偽値の場合に特別なタイプを返すように修正し、この真偽値のタイプを元に drops 手続きでは drop するか否か判断するようにします。
sine や cosine、他にも sqroot や arctan も実装しました。また、デバッグ出力も用意してあります。結構ハマるとデバッグが大変ですｗ
以下全ソース。
(define *debug-mode* #t)
(define (debug-on)
(print "debug mode on")
(set! *debug-mode* #t))
(define (debug-off)
(print "debug mode off")
(set! *debug-mode* #f))
(define (debug-print msg1 . msg2)
(define (iter msg)
(if (null? msg)
(newline)
(begin
(display (car msg))
(iter (cdr msg)))))
(and *debug-mode* (display msg1) (iter msg2)))
;;;;;
(define *table* '())
(define (get op type)
(let ((item (filter (lambda (x)
(and (eq? (car x) op)
(equal? (cadr x) type)))
*table*)))
(if (null? item)
#f
(caddr (car item)))))
(define (put op type item)
(set! *table*
(cons (list op type item)
(filter (lambda (x)
(not (and (eq? (car x) op)
(equal? (cadr x) type))))
*table*))))
;;;;;
(define *coercion-table* '())
(define (get-coercion type1 type2)
(let ((item (filter (lambda (x)
(and (eq? (car x) type1)
(eq? (cadr x) type2)))
*coercion-table*)))
(debug-print ";;item=" item)
(if (null? item)
#f
(caddr (car item)))))
(define (put-coercion type1 type2 proc)
(set! *coercion-table*
(cons (list type1 type2 proc)
(filter (lambda (x)
(not (and (eq? (car x) type1)
(eq? (cadr x) type2))))
*coercion-table*))))
;;;;;
(define *conversion-table* '())
(define (get-conversion conv type1)
(let ((item (filter (lambda (x)
(and (eq? (car x) conv)
(eq? (cadr x) type1)))
*conversion-table*)))
(if (null? item)
#f
(caddr (car item)))))
(define (put-conversion conv type proc)
(set! *conversion-table*
(cons (list conv type proc)
(filter (lambda (x)
(not (and (eq? (car x) conv)
(eq? (cadr x) type))))
*conversion-table*))))
;;;;;
(define *height-table* '())
(define (get-height type)
(let ((item (filter (lambda (x)
(and (eq? (car x) type)))
*height-table*)))
(if (null? item)
#f
(cadr (car item)))))
(define (put-height type height)
(set! *height-table*
(cons (list type height)
(filter (lambda (x)
(not (and (eq? (car x) type)
(eq? (cadr x) height))))
*height-table*))))
;;;;;
(define (attach-tag type-tag contents)
(if (or (eq? type-tag 'scheme-number)
(eq? type-tag 'scheme-real))
contents
(cons type-tag contents)))
(define (type-tag datum)
(cond ((eq? datum #t) 'true)
((eq? datum #f) 'false)
((exact-integer? datum) 'scheme-number)
((number? datum) 'scheme-real)
((pair? datum) (car datum))
(else
(error "Bad tagged datum -- TYPE-TAG" datum))))
(define (contents datum)
(cond ((number? datum) datum)
((pair? datum) (cdr datum))
(else
(error "Bad tagged datum -- CONTENTS" datum))))
;;;;;
(define (convert-to-same-type arg1 arg2)
(let ((type1 (type-tag arg1))
(type2 (type-tag arg2)))
(let ((h1 (get-height type1))
(h2 (get-height type2)))
(debug-print ";;CONVERT-TO-SAME-TYPE arg1=" arg1 " arg2=" arg2)
(cond ((< h1 h2)
(convert-to-same-type (raise arg1) arg2))
((> h1 h2)
(convert-to-same-type arg1 (raise arg2)))
(else
(list arg1 arg2))))))
(define (apply-generic op . args)
(let ((type-tags (map type-tag args)))
(let ((proc (get op type-tags)))
(debug-print ";;APPLY-GENERIC op=" op " args=" args)
(if proc
(begin
(debug-print ";;APPLY proc=" proc " op=" op " args=" args)
(drops (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 (eq? type1 type2)
(error "op is not defined for the type -- APPLY-GENERIC" (list op type1))
(let ((conv-args (convert-to-same-type a1 a2)))
(if conv-args
(apply-generic op (car conv-args) (cadr conv-args))
(error "convert error -- APPLY-GENERIC" type1 type2))))))))))
(define (apply-generic-kai op . arguments)
(define (arg1 args) (car args))
(define (arg2 args) (cadr args))
(define (iter args)
(debug-print ";;APPLY-GENERIC-KAI args=" args)
(if (= (length args) 2)
(apply-generic op (arg1 args) (arg2 args))
(let ((val (apply-generic op (arg1 args) (arg2 args))))
(iter (cons val (cddr args))))))
(iter (car arguments)))
;;;;;
(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 'equ? '(scheme-number scheme-number)
(lambda (x y) (tag (= x y))))
(put '=zero? '(scheme-number)
(lambda (x) (zero? x)))
(put 'exp '(scheme-number scheme-number)
(lambda (x y) (tag (expt x y))))
(put 'sqroot '(scheme-number)
(lambda (x) (sqrt x)))
(put 'arctan '(scheme-number)
(lambda (x) (atan x)))
(put 'arctan '(scheme-number scheme-number)
(lambda (x y) (atan x y)))
(put 'sine '(scheme-number)
(lambda (x) (sin x)))
(put 'cosine '(scheme-number)
(lambda (x) (cos x)))
(put 'make 'scheme-number
(lambda (x) (tag x)))
'done)
(define (install-scheme-real-package)
;; システムの他の部分へのインターフェース
(define (tag x)
(attach-tag 'scheme-real x))
(put 'add '(scheme-real scheme-real)
(lambda (x y) (tag (+ x y))))
(put 'sub '(scheme-real scheme-real)
(lambda (x y) (tag (- x y))))
(put 'mul '(scheme-real scheme-real)
(lambda (x y) (tag (* x y))))
(put 'div '(scheme-real scheme-real)
(lambda (x y) (tag (/ x y))))
(put 'equ? '(scheme-real scheme-real)
(lambda (x y) (tag (= x y))))
(put '=zero? '(scheme-real)
(lambda (x) (zero? x)))
(put 'exp '(scheme-real scheme-real)
(lambda (x y) (tag (expt x y))))
(put 'sqroot '(scheme-real)
(lambda (x) (sqrt x)))
(put 'arctan '(scheme-real)
(lambda (x) (atan x)))
(put 'arctan '(scheme-real scheme-real)
(lambda (x y) (atan x y)))
(put 'sine '(scheme-real)
(lambda (x) (sin x)))
(put 'cosine '(scheme-real)
(lambda (x) (cos x)))
(put 'make 'scheme-real
(lambda (x) (tag x)))
'done)
(define (install-rational-package)
;; 内部手続き
(define (numer x) (car x))
(define (denom x) (cdr x))
(define (make-rat n d)
(if (= d 0)
(error "zero denominator -- MAKE-RAT")
(let ((g (gcd n d)))
(cons (/ n g) (/ d g)))))
(define (add-rat x y)
(make-rat (add (mul (numer x) (denom y))
(mul (numer y) (denom x)))
(mul (denom x) (denom y))))
(define (sub-rat x y)
(make-rat (sub (add (numer x) (denom y))
(add (numer y) (denom x)))
(mul (denom x) (denom y))))
(define (mul-rat x y)
(make-rat (mul (numer x) (numer y))
(mul (denom x) (denom y))))
(define (div-rat x y)
(make-rat (mul (numer x) (denom y))
(mul (denom x) (numer y))))
(define (equ-rat? x y)
(and (equ? (numer x) (numer y))
(equ? (denom x) (denom y))))
(define (=zero-rat? x) (=zero? (numer x)))
(define (sqroot-rat x)
(let ((n (sqrt (numer x)))
(d (sqrt (denom x))))
(if (and (exact-integer? n) (exact-integer? d))
(make-rational n d)
(make-scheme-real (/ n d)))))
;; システムの他の部分へのインターフェース
(define (tag x) (attach-tag 'rational x))
(put 'add '(rational rational)
(lambda (x y) (tag (add-rat x y))))
(put 'sub '(rational rational)
(lambda (x y) (tag (sub-rat x y))))
(put 'mul '(rational rational)
(lambda (x y) (tag (mul-rat x y))))
(put 'div '(rational rational)
(lambda (x y) (tag (div-rat x y))))
(put 'equ? '(rational rational)
(lambda (x y) (equ-rat? x y)))
(put '=zero? '(rational)
(lambda (x) (=zero-rat? x)))
(put 'numer '(rational) numer)
(put 'denom '(rational) denom)
(put 'sqroot '(rational)
(lambda (x) (sqroot-rat x)))
(put 'arctan '(rational)
(lambda (x) (arctan (raise (tag x)))))
(put 'arctan '(rational rational)
(lambda (x y)
(arctan (raise (tag x)) (raise (tag y)))))
(put 'sine '(rational)
(lambda (x)
(sine (raise (tag x)))))
(put 'cosine '(rational)
(lambda (x)
(cosine (raise (tag x)))))
(put 'make 'rational
(lambda (n d) (tag (make-rat n d))))
'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)
(sqroot (add (square (real-part z))
(square (imag-part z)))))
(define (angle z)
(arctan (imag-part z) (real-part z)))
(define (equ-rec? z1 z2)
(and (equ? (real-part z1) (real-part z2))
(equ? (imag-part z1) (imag-part z2))))
(define (=zero-rec? z)
(and (=zero? (real-part z)) (=zero? (imag-part z))))
(define (make-from-mag-ang r a)
(cons (mul r (cosine a)) (mul r (sine 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 'equ? '(rectangular rectangular)
(lambda (z1 z2) (equ-rec? z1 z2)))
(put '=zero? '(rectangular)
(lambda (z) (=zero-rec? z)))
(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 (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)
(mul (magnitude z) (cosine (angle z))))
(define (imag-part z)
(mul (magnitude z) (sine (angle z))))
(define (equ-pol? z1 z2)
(and (equ? (magnitude z1) (magnitude z2))
(equ? (angle z1) (angle z2))))
(define (=zero-pol? z) (=zero? (magnitude z)))
(define (make-from-real-imag x y)
(cons (sqrt (add (square x) (square y)))
(arctan 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 'equ? '(polar polar)
(lambda (z1 z2) (equ-pol? z1 z2)))
(put '=zero? '(polar)
(lambda (z) (=zero-pol? z)))
(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 (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 (add (real-part z1) (real-part z2))
(add (imag-part z1) (imag-part z2))))
(define (sub-complex z1 z2)
(make-from-real-imag (sub (real-part z1) (real-part z2))
(sub (imag-part z1) (imag-part z2))))
(define (mul-complex z1 z2)
(make-from-mag-ang (mul (magnitude z1) (magnitude z2))
(add (angle z1) (angle z2))))
(define (div-complex z1 z2)
(make-from-mag-ang (div (magnitude z1) (magnitude z2))
(sub (angle z1) (angle z2))))
;; システムの他の部分へのインターフェース
(define (tag z) (attach-tag 'complex 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)
(put 'equ? '(complex complex)
(lambda (z1 z2)
(equ? (contents (rectangular->polar (tag z1))) (contents (rectangular->polar (tag z2))))))
(put '=zero? '(complex) =zero?)
'done)
;;;;;
(define (add x . y) (apply-generic-kai 'add (cons 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 (numer r) (apply-generic 'numer r))
(define (denom r) (apply-generic 'denom r))
(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))
;;;;;
(define (make-scheme-number n)
(if (exact-integer? n)
((get 'make 'scheme-number) n)
((get 'make 'scheme-real) n)))
(define (make-scheme-real n)
(make-scheme-number n))
(define (make-rational n d)
((get 'make 'rational) n d))
(define (make-complex-from-real-imag x y)
((get 'make-from-real-imag 'complex) x y))
(define (make-complex-from-mag-ang r a)
((get 'make-from-mag-ang 'complex) r a))
(define (rectangular->polar z)
(make-complex-from-mag-ang (magnitude z) (angle z)))
(define (square x) (mul x x))
(define (equ? x y) (apply-generic 'equ? x y))
(define (=zero? x) (apply-generic '=zero? x))
(define (exp x y) (apply-generic 'exp x y))
(define (sqroot x) (apply-generic 'sqroot x))
(define (arctan x) (apply-generic 'arctan x))
(define (arctan x y) (apply-generic 'arctan x y))
(define (sine x) (apply-generic 'sine x))
(define (cosine x) (apply-generic 'cosine x))
;;;;;
(define (scheme-number->real n)
(make-scheme-real (contents n)))
(define (scheme-number->rational n)
(make-rational (contents n) 1))
(define (rational->scheme-real rat)
(make-scheme-real (/. (numer rat) (denom rat))))
(define (scheme-real->complex r)
(make-complex-from-real-imag (contents r) 0))
(define (scheme-number->complex n)
(make-complex-from-real-imag (contents n) 0))
(define (rational->complex rat)
(make-complex-from-real-imag (/ (numer rat) (denom rat)) 0))
(put-coercion 'scheme-number 'rational scheme-number->rational)
(put-coercion 'scheme-number 'complex scheme-number->complex)
(put-coercion 'rational 'complex rational->complex)
;;;;;
(put-conversion 'raise 'scheme-number scheme-number->rational)
(put-conversion 'raise 'rational rational->scheme-real)
(put-conversion 'raise 'scheme-real scheme-real->complex)
(define (raise x)
(let ((proc (get-conversion 'raise (type-tag x))))
(debug-print ";;RAISE x=" x)
(if proc
(proc x)
(error "cannot raise -- RAISE" x))))
;;;;;
(define (rational->scheme-number rat)
(if (= (denom rat) 1)
(make-scheme-number (numer rat))
rat))
(define (scheme-real->rational real)
(let ((s (string-split (number->string (inexact->exact real)) "/")))
(if (= (length s) 2)
(make-rational (string->number (car s)) (string->number (cadr s)))
(make-rational (string->number (car s)) 1))))
(define (complex->scheme-real z)
(if (=zero? (imag-part z))
(make-scheme-real (* 1.0 (real-part z)))
z))
(put-conversion 'drop 'rational rational->scheme-number)
(put-conversion 'drop 'scheme-real scheme-real->rational)
(put-conversion 'drop 'complex complex->scheme-real)
(define (drop x)
(let ((proc (get-conversion 'drop (type-tag x))))
(debug-print ";;DROP x=" x)
(if proc
(proc x)
x)))
(define (drops x)
(let ((old-type (type-tag x)))
(if (or (eq? old-type 'true) (eq? old-type 'false))
x
(let* ((new-type-x (drop x))
(new-type (type-tag new-type-x)))
(if (eq? old-type new-type)
x
(drops new-type-x))))))
;;;;;
(put-height 'scheme-number 10)
(put-height 'rational 20)
(put-height 'scheme-real 30)
(put-height 'rectangular 40)
(put-height 'polar 40)
(put-height 'complex 99)
;;;;;
(install-scheme-number-package)
(install-scheme-real-package)
(install-rational-package)
(install-rectangular-package)
(install-polar-package)
(install-complex-package)以下のようなテスト用のデータを用意して
(define z1 (make-complex-from-real-imag
(make-rational 89439303 244473592)
(make-rational 109461327 321171076)))
(define z2 (make-complex-from-mag-ang
(make-rational 1 2)
(make-rational 3 4)))complex rectangular 型のテスト。
gosh> (real-part z1) (rational 89439303 . 244473592) gosh> (imag-part z1) (rational 109461327 . 321171076) gosh> (magnitude z1) (rational 1 . 2) gosh> (angle z1) (rational 3 . 4)
complex polar 型のテスト。
gosh> (real-part z2) (rational 89439303 . 244473592) gosh> (imag-part z2) (rational 109461327 . 321171076) gosh> (magnitude z2) (rational 1 . 2) gosh> (angle z2) (rational 3 . 4)
四則演算のテスト。
gosh> (add z1 z2) (complex rectangular (rational 89439303 . 122236796) rational 109461327 . 160585538) gosh> (sub z1 z2) 0 gosh> (mul z1 z2) (complex polar (rational 1 . 4) rational 3 . 2) gosh> (div z1 z2) 1
z1 と z2 は型が違うだけで同じ値ですから、sub の結果は 0、div の結果は 1 になります。
equ? のテスト。
gosh> (equ? z1 z2) #t gosh> (equ? z2 z1) #t gosh> (equ? z2 (add z1 z2)) #f gosh> (equ? (add z1 z2) z1) #f gosh> (equ? (add z1 z2) (add z2 z1)) #t
z1 と z2 は型が違うだけで同じ値ですから #t が返ります。
=zero? のテスト
gosh> (=zero? (make-complex-from-real-imag (make-rational 1 2) (make-rational 3 4))) #f gosh> (=zero? (make-complex-from-real-imag (make-rational 0 1) (make-rational 0 2))) #t gosh> (=zero? (make-complex-from-mag-ang (make-rational 1 2) (make-rational 3 4))) #f gosh> (=zero? (make-complex-from-mag-ang (make-rational 0 2) (make-rational 3 4))) #t
問題なさそう。
