問題 2.88
汎用符号反転演算 negative 手続きを実装して、多項式の減算ができるようにします。
(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 'negative '(scheme-number)
(lambda (x) (tag (* -1 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 'negative '(scheme-real)
(lambda (x) (tag (* -1 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))
(s (if (>= (* n d) 0) 1 -1)))
(cons (* s (abs (/ n g))) (abs (/ 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 (mul (numer x) (denom y))
(mul (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 (negative-rat x)
(mul-rat x (make-rat -1 1)))
(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 'negative '(rational)
(lambda (x) (tag (negative-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 (mul-rec z1 z2)
(let ((a (real-part z1))
(b (imag-part z1))
(c (real-part z2))
(d (imag-part z2)))
(make-from-real-imag (sub (mul a c) (mul b d))
(add (mul b c) (mul a d)))))
(define (div-rec z1 z2)
(let ((a (real-part z1))
(b (imag-part z1))
(c (real-part z2))
(d (imag-part z2)))
(make-from-real-imag (div (add (mul a c) (mul b d))
(add (square c) (square d)))
(div (sub (mul b c) (mul a d))
(add (square c) (square d))))))
;; システムの他の部分とのインターフェース
(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 'negative '(rectangular)
(lambda (z) (tag (mul-rec z (make-from-real-imag -1 0)))))
(put 'mul '(rectangular rectangular)
(lambda (z1 z2) (tag (mul-rec z1 z2))))
(put 'div '(rectangular rectangular)
(lambda (z1 z2) (tag (div-rec z1 z2))))
(put 'mul '(rectangular polar)
(lambda (z1 z2) (tag (mul-rec z1 z2))))
(put 'div '(rectangular polar)
(lambda (z1 z2) (tag (div-rec z1 z2))))
(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 (mul-pol z1 z2)
(make-from-mag-ang (mul (magnitude z1) (magnitude z2))
(add (angle z1) (angle z2))))
(define (div-pol z1 z2)
(make-from-mag-ang (div (magnitude z1) (magnitude z2))
(sub (angle z1) (angle z2))))
;; システムの他の部分とのインターフェース
(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 'negative '(polar)
(lambda (z) (mul (make-complex-from-real-imag (real-part z) (imag-part z))
(make-complex-from-real-imag -1 0))))
(put 'mul '(polar polar)
(lambda (z1 z2) (tag (mul-pol z1 z2))))
(put 'div '(polar polar)
(lambda (z1 z2) (tag (div-pol z1 z2))))
(put 'mul '(polar rectangular)
(lambda (z1 z2) (tag (mul-pol z1 z2))))
(put 'div '(polar rectangular)
(lambda (z1 z2) (tag (div-pol z1 z2))))
(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 (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) mul)
(put 'div '(complex complex) div)
(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?)
(put 'negative '(complex) negative)
'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 (negative x) (apply-generic 'negative 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 (mul 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)
;;;;; 2.5.3 例:記号代数
(define (install-polynomial-package)
;; 内部手続き
;; 多項式型の表現
(define (make-poly variable term-list)
(cons variable term-list))
(define (variable p) (car p))
(define (term-list p) (cdr p))
(define (variable? x) (symbol? x))
(define (same-variable? v1 v2)
(and (variable? v1) (variable? v2) (eq? v1 v2)))
;; 項と項リストの表現
(define (the-empty-termlist) '())
(define (empty-termlist? term-list) (null? term-list))
(define (first-term term-list) (car term-list))
(define (rest-terms term-list) (cdr term-list))
(define (make-term order coeff) (list order coeff))
(define (order term) (car term))
(define (coeff term) (cadr term))
(define (adjoin-term term term-list)
(if (=zero? (coeff term))
term-list
(cons term term-list)))
(define (add-terms L1 L2)
(cond ((empty-termlist? L1) L2)
((empty-termlist? L2) L1)
(else
(let ((t1 (first-term L1))
(t2 (first-term L2)))
(cond ((> (order t1) (order t2))
(adjoin-term t1 (add-terms (rest-terms L1) L2)))
((< (order t1) (order t2))
(adjoin-term t2 (add-terms L1 (rest-terms L2))))
(else
(adjoin-term
(make-term (order t1)
(add (coeff t1) (coeff t2)))
(add-terms (rest-terms L1)
(rest-terms L2)))))))))
(define (mul-terms L1 L2)
(if (empty-termlist? L1)
(the-empty-termlist)
(add-terms (mul-term-by-all-terms (first-term L1) L2)
(mul-terms (rest-terms L1) L2))))
(define (mul-term-by-all-terms t1 L)
(if (empty-termlist? L)
(the-empty-termlist)
(let ((t2 (first-term L)))
(adjoin-term
(make-term (+ (order t1) (order t2))
(mul (coeff t1) (coeff t2)))
(mul-term-by-all-terms t1 (rest-terms L))))))
(define (add-poly p1 p2)
(if (same-variable? (variable p1) (variable p2))
(make-poly (variable p1)
(add-terms (term-list p1)
(term-list p2)))
(error "Polys not in same var -- ADD-POLY"
(list p1 p2))))
(define (mul-poly p1 p2)
(if (same-variable? (variable p1) (variable p2))
(make-poly (variable p1)
(mul-terms (term-list p1)
(term-list p2)))
(error "Polys not in same var -- MUL-POLY"
(list p1 p2))))
(define (=zero-polynomial? p)
(define (iter t)
(cond ((empty-termlist? t) #t)
((not (=zero? (coeff (first-term t)))) #f)
(else (iter (rest-terms t)))))
(iter (term-list p)))
(define (negative-poly p)
(mul-poly p (make-poly (variable p) '((0 -1)))))
;; システムの他の部分とのインターフェース
(define (tag p) (attach-tag 'polynomial p))
(put 'add '(polynomial polynomial)
(lambda (p1 p2) (tag (add-poly p1 p2))))
(put 'sub '(polynomial polynomial)
(lambda (p1 p2) (tag (add-poly p1 (negative-poly p2)))))
(put 'mul '(polynomial polynomial)
(lambda (p1 p2) (tag (mul-poly p1 p2))))
(put '=zero? '(polynomial)
(lambda (p) (=zero-polynomial? p)))
(put 'negative '(polynomial)
(lambda (p) (tag (negative-poly p))))
(put 'make 'polynomial
(lambda (var terms) (tag (make-poly var terms))))
'done)
(define (make-polynomial var terms)
((get 'make 'polynomial) var terms))
;;;;;
(install-scheme-number-package)
(install-scheme-real-package)
(install-rational-package)
(install-rectangular-package)
(install-polar-package)
(install-complex-package)
(install-polynomial-package)negative 手続きを使って、多項式の符号を反転することができます。
gosh> (negative (make-polynomial 'x '((2 1) (1 1)))) (polynomial x (2 -1) (1 -1))
多項式の sub 手続きは negative 手続きを使って符号を反転したものを加算しています。
gosh> (sub (make-polynomial 'x '((3 3) (2 2) (1 1))) (make-polynomial 'x '((2 1) (1 1)))) (polynomial x (3 3) (2 1))
