SICP 2.5
全部解けてから投稿しようと思ったが、後半が辛すぎた。
done is better than perfect ってことでとりあえずうｐ
2.77
パッケージ外へのインタフェースとして、 本文の complex-package では - add - sub - mul - div - make-from-real-imag - make-from-mag-ang しか定義されていない。 そのため、 表から magnitude complex タグに対応する手続きを見つけられない。
magnitude z を評価するときに呼び出される手続きは
(apply-generic 'magnitude z)
(map type-tag z)
;=> ('complex)
(get 'magnitude ('complex))
;=> magnitude
(apply magnitude (map contents (x))
;=> (magnitude x)の評価結果
図2.24に示されるとおり、apply-genericは2回呼び出される。 1回目は complex に、2回目は rectangularに対応する
2.78
(define (attach-tag2 type-tag contents)
(if (number? contents)
contents
(attach-tag type-tag contents)))
(define (type-tag2 datum)
(if (number? contents)
'scheme-number
(type-tag datum)))
(define (contents2 datum)
(if (number? datum)
datum
(contents datum)))
;;tags(2.4.2)
(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)))
2.79
;'scheme-number
;; システムの他の部分へのインターフェース
(put 'equ? '(scheme-number scheme-number) =)
;'rational
;; 内部手続
(define (equ-rat x y)
(let ((gx (gcd (numer x) (demon x)))
(gy (gcd (numer y) (demon y))))
(and (= (/ (numer x) gx) (/ (numer y) gy))
(= (/ (demon x) gx) (/ (numer y) gy)))))
;; システムの他の部分へのインターフェース
(put 'equ? '(rational-number rational-number)
equ-rat )
;'complex
;; 内部手続
(define (equ-complex z1 z2)
(and (= (real-part z1) (real-part z2))
(= (imag-part z1) (imag-part z2))))
;; システムの他の部分へのインターフェース
(put 'equ? '(complex-number complex-number)
equ-complex )
2.80
;'scheme-number
;; システムの他の部分へのインターフェース
(put '=zero? '(scheme-number)
(= x 0))
;'rational
;; 内部手続
(define (zero-rat? x) (= (numer x) 0))
;; システムの他の部分へのインターフェース
(put '=zero? 'rational-number
zero-rat?)
;'complex
;; 内部手続
(define (zero-complex? z)
(= (real-part z) (imag-part z) 0))
;; システムの他の部分へのインターフェース
(put '=zero? 'complex-number
zero-complex?)
2.81
a
complex->complexが延々評価され続ける。
b
Louisは正しくない。現状のままでよい。
c
現状のままでよいと思うのだが、 hoge->hoge が定義されていても無限呼び出しにはまらないようにするという意味だと理解。
(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 (and (= (length args) 2)
(not (equal? (car type-tags) (cadr type-tags))))
(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)))))))
2.82
すべて先頭要素に揃える戦略
(define (apply-generic op . args)
(define (iter type-tags args)
(if (null? type-tags)
(error "no method")
(let ((type1 (car type-tags)))
(let ((filterd-args
(true-map
(lambda (x)
(let ((type2 (type-tag x)))
(if (eq? type1 type2)
x
(let ((t2->t1 (get-collection type2 type)))
(if (null? t2->t1) #f (t2->t1 x))))))
args)))
(or filterd-args
(iter (cdr type-tags) args))))))
(let ((type-tags (map type-tag args)))
(let ((proc (get op type-tags)))
(if (not (null? proc))
(apply proc (map contents args))
(apply apply-generic (cons op (iter type-tags args)))))))
(define (true-map proc sequence)
(define (iter proc sequence result)
(if (null? sequence)
(reverse result)
(let ((item (proc (car sequence))))
(if item
(iter proc (cdr sequence) (cons item result))
#f))))
(iter proc sequence nil))
この戦略は、第1引数の型->第2引数の型変換だけがある場合にNG （第2引数の型に揃えれば解けるのに、解けないとみなされてしまう）
2.83
型の塔は
integer -> rational -> real -> complex
の順に高くなるとする。 （integer=shceme-number)
各型毎に1レベルあげる手続きを用意すれば良いので
(define (raise x) (apply-generic 'raise x))
各パッケージには以下を追加
;;scheme-number
(put 'raise 'integer
(lambda (x) (make-rational x 1)))
;;rational
(put 'raise 'rational
(lambda (x) (make-real (/ (numer x) (denom x)))))
;;real
(put 'raise 'real
(lambda (x) (make-from-real-imag x 0)))
なお、complex（複素数）は最上位なのでraiseの適用を受けない。
2.84
最も上位にある型にすべてを揃える戦略とする。
;比較用に型を数値に変換(上位ほど数が大きい)
;型が増えたらここに追加
(define (level type)
(cond ((eq? type 'integer) 0)
((eq? type 'rational) 1)
((eq? type 'real) 2)
((eq? type 'complex) 3)
(else (error "Invalid type:" type))))
;最上位タイプを探す
(define (highest-type args)
(define (iter rest result)
(if (null? rest)
result
(iter (cdr rest)
(let ((current-type (type-tag (car rest))))
(if (> (level current-type) (level result))
current-type
result)))))
(if (pair? args)
(iter (cdr args) (type-tag (car args)))
(type-tag args)))
;全てのargを共通する最上位の型までraiseする
(define (raise-to-higest args)
(let ((type (highest-type args)))
(define (iter rest result)
(if (null? rest)
(reverse result)
(iter (cdr rest)
(cons (raise-to type (car rest)) result))))
(iter args '())))
;目標の型(type)になるまで、argをraiseする
(define (raise-to type arg)
(if (eq? type (type-tag arg))
arg
(raise-to type (raise arg))))
(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 (not (null? (cdr args))) ;ここから変更
(let ((raised-args (raise-to-higest args)))
(let ((proc (get op (map type-tag raised-args))))
(if proc
(apply proc (map contents raised-args))
(error "No method for these types"
(list op type-tags))))))))))
2.85
(define (drop x)
(let ((drop-proc (get 'drop (type-tag x))))
(if drop-proc
(let ((droped (drop-proc (contents x))))
(if (equ? droped (raise droped))
droped
x))
x)))
各パッケージには以下を追加
;;rational
(put 'raise 'rational
(lambda (x) (make-real (round (/ (numer x) (denom x))))))
;;real
(put 'raise 'real
(lambda (x)
(let ((rat (rationalize
(inexact->exact x) 1/100)))
(make-rational
(numerator rat)
(denominator rat)))))
;;complex
(put 'drop 'complex
(lambda (x) (make-real (real-part x))))
2.86
問題文
Exercise 2.86. Suppose we want to handle complex numbers whose real parts, imaginary parts, magnitudes, and angles can be either ordinary numbers, rational numbers, or other numbers we might wish to add to the system. Describe and implement the changes to the system needed to accommodate this. You will have to define operations such as sine and cosine that are generic over ordinary numbers and rational numbers.
handle complex numbers を 複素数の四則演算を行うこと と解釈する。
また、 You will have to... 以降も本問の要求と判断する。
つまり、本問の目的は
- 複素数の加算、減算、乗算、除算を実装する。
- 複素数の実部、虚部で実数だけでなく有理数も扱えるようにする
- さらに、それ以外の数が実部、虚部にくる場合も拡張できるようにする
- sine, cosine についても、実数、有理数に対応できるよう実装する
ことだという前提で回答する。
方針としては、complexの四則演算関数内部で使われていた演算子を add, sub, mul, div にして、実数、有理数どちらも扱えるようにする。
;;四則演算
;;add, sub, mul, div はshceme-numberとrational それぞれのパッケージに定義されているモノとする
(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))))
sine, cosine はそれぞれのパッケージに当該の手続きを用意してやれば良い
;;sine, cosine ;;グローバルな定義 (define (sine x) (apply-generic 'sine x)) (define (cosine x) (apply-generic 'cosine x)) ;; schme-number-packageに追加 (put 'sine 'schme-number (lambda (x) (sine x))) (put 'cosine 'schme-number (lambda (x) (cosine x))) ;; rational-packageに追加 (put 'sine 'rational (lambda (x) (sine (/ (numer x) (denom x))))) (put 'cosine 'rational (lambda (x) (cosine (/ (numer x) (denom x)))))
2.87
term-listに係数0の要素が入らないと仮定すると
(define (=zero? x) (apply-generic '=zero? x)) ;; polynomial-packageに追加 (put '=zero? 'polynomial (lambda(x) (empty-termlist? (term-list x))))
係数0の要素が入る場合（データ型の定義として非効率だが,こっちが想定解っぽい）
;; polynomial-packageに追加
(put '=zero? 'polynomial zero-poly)
(define (zero-poly x)
(define (zero-term termlist)
(or (empty-terms termlist)
(and (=zero? (coeff (first-term termlist)))
(zero-term (rest-terms termlist)))))
(zero-term (term-list x)))
2.88
問題文にあるとおり、X - Y を X + 反転Y と考える
(define (negate x) (apply-generic 'negate x))
;; scheme-number package
(put 'negate 'scheme-number
(lambda (n) (tag (- n))))
;; rational package
(put 'negate 'rational
(lambda (rat) (make-rational (- (numer rat)) (denom rat))))
;; complex package
(put 'negate 'complex
(lambda (z) (make-from-real-imag (- (real-part z))
(- (imag-part z)))))
;; polynomial package
(define (negate-terms termlist)
(if (empty-termlist? termlist)
the-empty-termlist
(let ((t (first-term termlist)))
(adjoin-term (make-term (order t) (negate (coeff t)))
(negate-terms (rest-terms termlist))))))
(put 'negate 'polynomial
(lambda (poly) (make-polynomial (variable poly)
(negate-terms (term-list poly)))))
;; 減算
(put 'sub '(polynomial polynomial)
(lambda (x y) (tag (add-poly x (negate y)))))
2.89
#lang racket
;; adjoin termの次数と合致する場所に挿入する
(define (adjoin-term term term-list)
(if (=zero? (coeff term) term-list)
(let ((exponent (order term))
(len (length term-list)))
(define (iter times terms)
(if (= exponent times)
(cond (coeff term) terms)
(iter (+ 1 times)
(cond 0 terms))))
(iter len term-list))))
;; first-term 次数を計算して生成
(define (first-term term-list) (list (car term-list) (- (length (cdr term-list) 1))))
;; =zero?
(define (zero-poly x)
(define (zero-term termlist)
(or (empty-termlist? termlist)
(and (= 0 (first-term termlist))
(zero-term (rest-terms termlist)))))
(zero-term (term-list x)))
;; あとは同じ
(define (the-empty-termlist) '())
(define (rest-terms term-list) (cdr term-list))
(define (empty-termlist? term-list) (null? term-list))
(define (make-term order coeff) (list order coeff))
(define (order term) (car term))
(define (coeff term) (cadr term))
2.90
;;濃い演算のパッケージ ;;薄い演算のパッケージ ;;相互変換 ;;汎用演算処理
2.91
(define (div-terms L1 L2)
(if (empty-termlist? L1)
(list (the-empty-termlist) (the-empty-termlist))
(let ((t1 (first-term L1))
(t2 (first-term L2)))
(if (> (order t2) (order t1))
(list (the-empty-termlist) L1)
(let ((new-c (div (coeff t1) (coeff t2)))
(new-o (- (order t1) (order t2))))
(let ((rest-of-result
(div-terms
;; 要は L1-(L2*次数) が次の入力になる
(sub-terms
L1
(mul-terms
L2
(list (make-term new-o new-c))))
L2)))
(list (adjoin-term (make-term new-o new-c)
(car rest-of-result))
(cadr rest-of-result))))))))
(define (div-poly poly1 poly2)
(if (same-variable? (variable poly1) (variable poly2))
(make-poly (variable poly1)
(div-terms (term-list poly1)
(term-list poly2)))
(error "not the same variable" (list poly1 poly2))))
2.92
順序(order)はどちらかというと順位（どちらが高位か）を意味しているように感じた。 易しくはないそうなので、回答は諦めてWebにある答えを理解することにする。 方針としては - 高位、低位の変数を決めて、variable-order 関数に規定する（コードではxとそれ以外で分けている） - polyを(高位,低位)と構成することで、高位と低位を区別する - それぞれを使って処理演算を書く（これがすげー大変そう）
(コードはすげー長い。日本語のコメントは自分で入れたが、ほぼ挫折)
(define (install-polynomial-package)
;; internal procedures
;; representation of poly
;; 部品の定義
(define (make-poly variable term-list)
(cons variable term-list))
(define (polynomial? p)
(eq? 'polynomial (car p)))
(define (variable p) (car p))
(define (term-list p) (cdr p))
(define (variable? x)
(symbol? x))
(define (same-variable? x y)
(and (variable? x) (variable? y) (eq? x y)))
;; representation of terms and term lists
;; 加算
(define (add-poly p1 p2)
; (display "var p1 ") (display p1) (newline)
; (display "var p2 ") (display p2) (newline)
(if (same-variable? (variable p1) (variable p2))
(make-poly (variable p1)
(add-terms (term-list p1)
(term-list p2)))
;; 順序をつけた処理
;; low-p（低位の変数）を高位の変数に合わせてraiseする
(let ((ordered-polys (order-polys p1 p2)))
(let ((high-p (higher-order-poly ordered-polys))
(low-p (lower-order-poly ordered-polys)))
(let ((raised-p (change-poly-var low-p)))
(if (same-variable? (variable high-p)
(variable (cdr raised-p)))
(add-poly high-p (cdr raised-p)) ;-> cdr for 'polynomial. Should fix this,
;; change-poly-var should return without 'polynomial as it is only used here.
(error "Poly not in same variable, and can't change either! -- ADD-POLY"
(list high-p (cdr raised-p)))))))))
(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-poly p1 p2)
(if (same-variable? (variable p1) (variable p2))
(make-poly (variable p1)
(mul-terms (term-list p1)
(term-list p2)))
;; add-polyと同じ戦略
(let ((ordered-polys (order-polys p1 p2)))
(let ((high-p (higher-order-poly ordered-polys))
(low-p (lower-order-poly ordered-polys)))
(let ((raised-p (change-poly-var low-p)))
(if (same-variable? (variable high-p)
(variable (cdr raised-p)))
(mul-poly high-p (cdr raised-p))
(error "Poly not in same variable, and can't change either! -- MUL-POLY"
(list high-p (cdr raised-p)))))))))
(define (mul-terms L1 L2)
(if (empty-termlist? L1)
(the-empty-termlist L1)
(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 L)
(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 (div-poly p1 p2)
(if (same-variable? (variable p1) (variable p2))
(let ((answer (div-terms (term-list p1)
(term-list p2))))
(list (tag (make-poly (variable p1) (car answer)))
(tag (make-poly (variable p1) (cadr answer)))))
;; add-polyと同じ戦略
(let ((ordered-polys (order-polys p1 p2)))
(let ((high-p (higher-order-poly ordered-polys))
(low-p (lower-order-poly ordered-polys)))
(let ((raised-p (change-poly-var low-p)))
(if (same-variable? (variable high-p)
(variable (cdr raised-p)))
(div-poly high-p (cdr raised-p))
(error "Poly not in same variable, and can't change either! -- DIV-POLY"
(list high-p (cdr raised-p)))))))))
(define (div-terms L1 L2)
(define (div-help L1 L2 quotient)
(if (empty-termlist? L1)
(list (the-empty-termlist L1) (the-empty-termlist L1))
(let ((t1 (first-term L1))
(t2 (first-term L2)))
(if (> (order t2) (order t1))
(list (cons (type-tag L1) quotient) L1)
(let ((new-c (div (coeff t1) (coeff t2)))
(new-o (- (order t1) (order t2))))
(div-help
(add-terms L1
(mul-term-by-all-terms
(make-term 0 -1)
(mul-term-by-all-terms (make-term new-o new-c)
L2)))
L2
(append quotient (list (list new-o new-c)))))))))
(div-help L1 L2 '()))
(define (zero-pad x type)
(if (eq? type 'sparse)
'()
(cond ((= x 0) '())
((> x 0) (cons 0 (zero-pad (- x 1) type)))
((< x 0) (cons 0 (zero-pad (+ x 1) type))))))
;;; donno what to do when coeff `=zero?` for know just return the term-list
(define (adjoin-term term term-list)
(define (adjoin-help term acc term-list)
(let ((preped-term ((get 'prep-term (type-tag term-list)) term))
(preped-first-term ((get 'prep-term (type-tag term-list))
(first-term term-list)))
(empty-termlst (the-empty-termlist term-list)))
(cond ((=zero? (coeff term)) term-list)
((empty-termlist? term-list) (append empty-termlst
acc
preped-term
(zero-pad (order term)
(type-tag term-list))))
((> (order term) (order (first-term term-list)))
(append (list (car term-list)) ;-> the type-tag
acc
preped-term
(zero-pad (- (- (order term)
(order (first-term term-list)))
1) (type-tag term-list))
(cdr term-list)))
((= (order term) (order (first-term term-list)))
(append (list (car term-list))
acc
preped-term ;-> if same order, use the new term
(zero-pad (- (- (order term)
(order (first-term term-list)))
1) (type-tag term-list))
(cddr term-list))) ;-> add ditch the original term.
(else
(adjoin-help term
(append acc preped-first-term)
(rest-terms term-list))))))
(adjoin-help term '() term-list))
(define (negate p)
(let ((neg-p ((get 'make-polynomial (type-tag (term-list p)))
(variable p) (list (make-term 0 -1)))))
(mul-poly (cdr neg-p) p))) ; cdr of neg p to eliminat the tag 'polynomial
(define (zero-poly? p)
(define (all-zero? term-list)
(cond ((empty-termlist? term-list) #t)
(else
(and (=zero? (coeff (first-term term-list)))
(all-zero? (rest-terms term-list))))))
(all-zero? (term-list p)))
(define (equal-poly? p1 p2)
(and (same-variable? (variable p1) (variable p2))
(equal? (term-list p1) (term-list p2))))
(define (the-empty-termlist term-list)
(let ((proc (get 'the-empty-termlist (type-tag term-list))))
(if proc
(proc)
(error "No proc found -- THE-EMPTY-TERMLIST" term-list))))
(define (rest-terms term-list)
(let ((proc (get 'rest-terms (type-tag term-list))))
(if proc
(proc term-list)
(error "-- REST-TERMS" term-list))))
(define (empty-termlist? term-list)
(let ((proc (get 'empty-termlist? (type-tag term-list))))
(if proc
(proc term-list)
(error "-- EMPTY-TERMLIST?" term-list))))
(define (make-term order coeff) (list order coeff))
(define (order term)
(if (pair? term)
(car term)
(error "Term not pair -- ORDER" term)))
(define (coeff term)
(if (pair? term)
(cadr term)
(error "Term not pair -- COEFF" term)))
;; Mixed polynomial operations. This better way to do this, was just to raise the other types
;; to polynomial. Becuase raise works step by step, all coeffs will end up as complex numbers.
(define (mixed-add x p) ; I should only use add-terms to do this.
(define (zero-order L) ; And avoid all this effort. :-S
(let ((t1 (first-term L)))
(cond ((empty-termlist? L) #f)
((= 0 (order t1)) t1)
(else
(zero-order (rest-terms L))))))
(let ((tlst (term-list p)))
(let ((last-term (zero-order tlst)))
(if last-term
(make-poly (variable p) (adjoin-term
(make-term 0
(add x (coeff last-term)))
tlst))
(make-poly (variable p) (adjoin-term (make-term 0 x) tlst))))))
(define (mixed-mul x p)
(make-poly (variable p)
(mul-term-by-all-terms (make-term 0 x)
(term-list p))))
(define (mixed-div p x)
(define (div-term-by-all-terms t1 L)
(if (empty-termlist? L)
(the-empty-termlist L)
(let ((t2 (first-term L)))
(adjoin-term
(make-term (- (order t1) (order t2))
(div (coeff t1) (coeff t2)))
(div-term-by-all-terms t1 (rest-terms L))))))
(make-poly (variable p)
(div-term-by-all-terms (make-term 0 x)
(term-list p))))
;; Polynomial transformation. (Operations on polys of different variables)
;; 順位をつける処理
(define (variable-order v) ;-> var heirarchy tower. x is 1, every other letter 0.
(if (eq? v 'x) 1 0))
;; 高位から順に結合する
;; 英語コメントの car, cdr はそれぞれ先頭、後半、と捉える
(define (order-polys p1 p2) ;-> a pair with the higher order poly `car`, and the
(let ((v1 (variable-order (variable p1))) ;-> lower order `cdr`
(v2 (variable-order (variable p2))))
(if (> v1 v2) (cons p1 p2) (cons p2 p1))))
;; 高位のpoly(=car)をとる
(define (higher-order-poly ordered-polys)
(if (pair? ordered-polys) (car ordered-polys)
(error "ordered-polys not pair -- HIGHER-ORDER-POLY" ordered-polys)))
;; 低位のpoly(=cdr)をとる
(define (lower-order-poly ordered-polys)
(if (pair? ordered-polys) (cdr ordered-polys)
(error "ordered-polys not pair -- LOWER-ORDER-POLY" ordered-polys)))
(define (change-poly-var p) ;-> All terms must be polys
(define (helper-change term-list) ;-> change each term in term-list
(cond ((empty-termlist? term-list) '()) ;-> returns a list of polys with changed var.
(else ;-> one poly per term.
(cons (change-term-var (variable p)
(type-tag term-list)
(first-term term-list))
(helper-change (rest-terms term-list))))))
(define (add-poly-list acc poly-list) ;-> add a list of polys.
(if (null? poly-list) ;-> no more polys, give me the result.
acc
(add-poly-list (add acc (car poly-list)) ;-> add acc'ed result to first poly
(cdr poly-list)))) ;-> rest of the polys.
(add-poly-list 0 (helper-change (term-list p))))
(define (change-term-var original-var original-type term)
(make-polynomial original-type (variable (cdr (coeff term))) ;-> cdr eliminates 'polynomial
(map (lambda (x)
(list (order x) ;-> the order in x
(make-polynomial ;-> coeff is a poly in
original-type ;-> the original-type (in this example y)
original-var ;-> the original-var is passed to the coeffs now
(list ;-> each term, is formed by
(list (order term) ;-> the order of the orignal term
(coeff x)))))) ;-> and the coeff of each term in x
(cdr (term-list (cdr (coeff term))))))) ;-> un-tagged termlist of
;-> the coeff of the term of y.
;; interface to rest of the system
(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 (negate p2)))))
(put 'mul '(polynomial polynomial)
(lambda (p1 p2) (tag (mul-poly p1 p2))))
(put 'negate '(polynomial)
(lambda (p) (negate p)))
(put 'div '(polynomial polynomial)
(lambda (p1 p2) (div-poly p1 p2)))
(put 'zero-poly? '(polynomial)
(lambda (p) (zero-poly? p)))
(put 'equal-poly? '(polynomial polynomial)
(lambda (p1 p2) (equal-poly? p1 p2)))
(put 'make 'polynomial
(lambda (var terms) (tag (make-poly var terms))))
;; Interface of the mixed operations.
;; Addition
(put 'add '(scheme-number polynomial) ; because it's commutative I won't define both. Just
(lambda (x p) (tag (mixed-add x p)))) ;poly always second.
(put 'add '(rational polynomial)
(lambda (x p) (tag (mixed-add (cons 'rational x) p)))) ;-> this is needed becuase
(put 'add '(real polynomial) ;-> apply-generic will remove the
(lambda (x p) (tag (mixed-add x p)))) ;-> tag.
(put 'add '(complex polynomial)
(lambda (x p) (tag (mixed-add (cons 'complex x) p))))
;; Subtraction
(put 'sub '(scheme-number polynomial)
(lambda (x p) (tag (mixed-add x (negate p)))))
(put 'sub '(polynomial scheme-number)
(lambda (p x) (tag (mixed-add (mul -1 x) p))))
(put 'sub '(rational polynomial)
(lambda (x p) (tag (mixed-add (cons 'rational x) (negate p)))))
(put 'sub '(polynomial rational)
(lambda (p x) (tag (mixed-add (mul -1 (cons 'rational x)) p))))
(put 'sub '(real polynomial)
(lambda (x p) (tag (mixed-add x (negate p)))))
(put 'sub '(polynomial real)
(lambda (p x) (tag (mixed-add (mul -1 x) p))))
(put 'sub '(complex polynomial)
(lambda (x p) (tag (mixed-add (cons 'complex x) (negate p)))))
(put 'sub '(polynomial complex)
(lambda (p x) (tag (mixed-add (mul -1 (cons 'complex x)) p))))
;; Multiplication
(put 'mul '(scheme-number polynomial)
(lambda (x p) (tag (mixed-mul x p))))
(put 'mul '(rational polynomial)
(lambda (x p) (tag (mixed-mul (cons 'rational x) p))))
(put 'mul '(real polynomial)
(lambda (x p) (tag (mixed-mul x p))))
(put 'mul '(complex polynomial)
(lambda (x p) (tag (mixed-mul (cons 'complex x) p))))
;; Division
;; Using a polynomial as a divisor will leave me wiht negative orders. Which I donno how to
;; handle yet.
(put 'div '(polynomial scheme-number)
(lambda (p x) (tag (mixed-mul (/ 1 x) p))))
(put 'div '(scheme-number polynomial)
(lambda (x p) (tag (mixed-div p x))))
(put 'div '(polynomial rational) ;multiply by the denom, and divide by the numer.
(lambda (p x) (tag (mixed-mul (make-rational (cdr x) (car x)) p))))
(put 'div '(rational polynomial)
(lambda (x p) (tag (mixed-div p (cons 'rational x)))))
(put 'div '(polynomial real)
(lambda (p x) (tag (mixed-mul (/ 1.0 x) p))))
(put 'div '(real polynomial)
(lambda (x p) (tag (mixed-div p x))))
(put 'div '(polynomial complex)
(lambda (p x) (tag (mixed-mul (div 1 (cons 'complex x)) p))))
(put 'div '(complex polynomial)
(lambda (x p) (tag (mixed-div p (cons 'complex x)))))
'done)
(install-polynomial-package)
; this takes an extra argument type to specify if it is dense or sparse.
(define (make-polynomial type var terms)
(let ((proc (get 'make-polynomial type)))
(if proc
(proc var terms)
(error "Can't make poly of this type -- MAKE-POLYNOMIAL"
(list type var terms)))))
; the generic negate procedure needed for subtractions.
(define (negate p)
(apply-generic 'negate p))
; And the generic first-term procedure with it's package to work with dense and
; sparse polynomials.
(define (first-term term-list)
(let ((proc (get 'first-term (type-tag term-list))))
(if proc
(proc term-list)
(error "No first-term for this list -- FIRST-TERM" term-list))))
(define (install-polynomial-term-package)
(define (first-term-dense term-list)
(if (empty-termlist? term-list)
'()
(list
(- (length (cdr term-list)) 1)
(car (cdr term-list)))))
(define (first-term-sparse term-list)
(if (empty-termlist? term-list)
'()
(cadr term-list)))
(define (prep-term-dense term)
(if (null? term)
'()
(cdr term))) ;-> only the coeff for a dense term-list
(define (prep-term-sparse term)
(if (null? term)
'()
(list term))) ;-> (order coeff) for a sparse term-list
(define (the-empty-termlist-dense) '(dense))
(define (the-empty-termlist-sparse) '(sparse))
(define (rest-terms term-list) (cons (type-tag term-list) (cddr term-list)))
(define (empty-termlist? term-list)
(if (pair? term-list)
(>= 1 (length term-list))
(error "Term-list not pair -- EMPTY-TERMLIST?" term-list)))
(define (make-polynomial-dense var terms)
(append (list 'polynomial var 'dense) (map cadr terms)))
(define (make-polynomial-sparse var terms)
(append (list 'polynomial var 'sparse) terms))
(put 'first-term 'sparse
(lambda (term-list) (first-term-sparse term-list)))
(put 'first-term 'dense
(lambda (term-list) (first-term-dense term-list)))
(put 'prep-term 'dense
(lambda (term) (prep-term-dense term)))
(put 'prep-term 'sparse
(lambda (term) (prep-term-sparse term)))
(put 'rest-terms 'dense
(lambda (term-list) (rest-terms term-list)))
(put 'rest-terms 'sparse
(lambda (term-list) (rest-terms term-list)))
(put 'empty-termlist? 'dense
(lambda (term-list) (empty-termlist? term-list)))
(put 'empty-termlist? 'sparse
(lambda (term-list) (empty-termlist? term-list)))
(put 'the-empty-termlist 'dense
(lambda () (the-empty-termlist-dense)))
(put 'the-empty-termlist 'sparse
(lambda () (the-empty-termlist-sparse)))
(put 'make-polynomial 'sparse
(lambda (var terms) (make-polynomial-sparse var terms)))
(put 'make-polynomial 'dense
(lambda (var terms) (make-polynomial-dense var terms)))
'done)
(install-polynomial-term-package)
```
# 2.93
(define (install-rational-package) (define (numer x) (car x)) (define (denom x) (cdr x)) (define (make-rat n d) (cons n d))
;;四則演算 (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 (=rat-zero? x) (= (numer x) 0)) (define (rat-equ? x y) (if (and (= (numer x) (numer y)) (= (denom x) (denom y))) #t #f)) ;; 負数 (define (negative-rat x) (make-rat (- (numer x)) (denom x)))
(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 '=zero? '(rational) (lambda (x) (=rat-zero? x))) (put 'make 'rational (lambda (n d) (tag (make-rat n d)))) (put 'equ? '(rational rational) (lambda (x y) (rat-equ? x y))) (put 'negative '(rational) (lambda (x) (tag (negative-rat x)))) 'done)
(install-rational-package)
(define (make-rational n d) *1
# 2.94
```
(define (greatest-common-divisor a b)
(apply-generic 'greatest-common-divisor a b))
;; 整数パッケージにGCDを追加
(put 'greatest-common-divisor '(scheme-number scheme-number)
(lambda (a b) (gcd a b)))
;; polynomial package にも追加
(define (remainder-terms p1 p2)
(cadr (div-terms p1 p2)))
(define (gcd-terms a b)
(if (empty-termlist? b)
a
(gcd-terms b (remainder-terms a b))))
(define (gcd-poly p1 p2)
(if (same-varaible? (variable p1) (variable p2))
(make-poly (variable p1)
(gcd-terms (term-list p1)
(term-list p2))
(error "not the same variable -- GCD-POLY" (list p1 p2)))))
現時点ではgetとputが動く状態にないのにうごかせって、実際の講義ではどうしてたのだろうか。
2.95
動かせないのでよそから結果をパクる
http://www.serendip.ws/archives/1163
確かにP1になっていない。
最後までは辛いので途中まで手計算してみる。
。。。計算が合わなくて死亡。
何が起きたかは理解できなかった。
小数のまるめ誤差かと思ったが、計算は有理数でしているし、何がいかんのか分からない。
数学がキライになりそう
2.96
2.95がわから無いので手のつけようがない。
非整数係数って事は、整数以外の係数が入った状態でGCDのアルゴリズムを適用するのがいけないのだろうか。
（たしかに最大公約数は整数問題だからそれならつじつまがあう。
が、そうすると実数であるxの多項式に最大公約数を持ち込んでいる時点で矛盾があるような、、、
もはや数学の世界なので諦める）
2.97
2.96の版が無いので出来ない。 心も折れた。
*1:get 'make 'rational) n d
