SICP 3.5.1-3.5.2
3.50
脚注12
12 Schemeが標準的に用意しているmap手続きは, ここに述べたものより一般的である.
より一般的 mapは, n引数の手続きとn個のリストをとり,
手続きをリストのすべての第一要素に作用させ,
リストのすべての第二要素に作用させ,
等々させて, 結果のリストを返す.
例えば
(map + (list 1 2 3) (list 40 50 60) (list 700 800 900))
(741 852 963)
(map (lambda (x y) (+ x (* 2 y)))
(list 1 2 3)
(list 4 5 6))
(9 12 15)
元々のmap
(define (stream-map proc s)
(if (stream-null? s)
the-empty-stream
(cons-stream
(proc (stream-car s))
(stream-map proc (stream-cdr s)))))
よって、
(define (stream-map proc . argstreams)
(if (stream-null? (car argstreams))
the-empty-stream
(cons-stream
(apply proc (map stream-car argstreams))
(apply stream-map
(cons proc (map stream-cdr argstreams))))))
ただし、argstreamsの長さが違うとおかしくなるかも？ e.g. (stream-map some-proc (1 1 1) (2 2)) だと、(2 2)の第3要素が無いのでそこでおかしくなりそう
3.51
(define x (stream-map show (stream-enumerate-interval 0 10))) 0 => x (stream-ref x 5) 1 2 3 4 5 => 5 (stream-ref x 7) 6 7 => 7
3.52
(define sum 0) ; 0 (define (accum x) (set! sum (+ x sum)) sum) ; 0 (define seq (stream-map accum (stream-enumerate-interval 1 20))) ; sumは1 (define y (stream-filter even? seq)) ; even になるまで巡るので、 1, 3, 6 で 6 ; sumは6 (define z (stream-filter (lambda (x) (= (remainder x 5) 0)) seq)) ; 5の倍数になるまで巡るので 6, 10 ; sumは10 (stream-ref y 7) ; yの7番目まで巡る ; yは 6 10 28 36 66 78 120 136 190 210 ; sumは120 (display-stream z) ; zを最後まで巡る ; z は 10 15 45 55 120 190 210 ; sumは210 ; 印字は (10 15 45 55 120 190 210)
最適化を使わない場合、毎度計算(accum)がやり直されるので、どんどんsumの値が増える
; yまでは同じ (define z (stream-filter (lambda (x) (= (remainder x 5) 0)) seq)) ; 第1要素が6になる ; 6 + 2 + 3 + 4 = 15 (stream-ref y 7) ; 15 + (4 + 5 + ... + 17) = 162 (display-stream z) ; 162 + (5 + 6 + ... + 20) = 362
3.53
(define s (cons-stream 1 (add-streams s s)))
最後に出力された要素の2倍が次の要素。
1 2 4 8 …
よって n番目の要素は 2n-1
3.54
(define (mul-stream s1 s2) (stream-map * s1 s2))
(define factorials (cons-stream 1 (mul-streams factorials (stream-cdr integers))))
3.55
(define (partial-sums S)
(cons-stream
(stream-car S)
(add-stream (partial-sums S) (stream-cdr S))))
3.56
(define S (cons-stream 1 (merge ⟨scale-stream S 2⟩ ⟨merge (scale-stream S 3) (scale-stream S 5)⟩)))
3.57
fibs
(define fibs
(cons-stream 0
(cons-stream 1
(add-streams (stream-cdr fibs) fibs))))
1番目 0 2番目 1 3番目 2 4番目 3 … n番目 n-1
メモかを使わない場合は、毎回計算がやり直されるので 1番目 0 2番目 1 3番目 3 4番目 7 … n番目 n-1の回数 + n
3.58
(define (expand num den radix) (cons-stream (quotient (* num radix) den) (expand (remainder (* num radix) den) den radix)))
(expand 1 7 10) ; (quotient 10 7) ; => 1 ; (expand 3 7 10) ; (quotient 30 7) ; => 4 ; (expand 2 7 10) ; (quotient 20 7) ; => 2 ; (expand 6 7 10) ; (quotient 60 7) ; => 8 ; (expand 4 7 10) ; (quotient 40 7) ; => 5 ; (expand 5 7 10) ; (quotient 50 7) ; => 7 ; (expand 1 7 10) ; 以下循環
(expand 3 8 10) ; (quotien 30 8) ; => 3 ; (expand 6 8 10) ; => 7 ; (expand 4 8 10) ; => 5 ; (expand 0 8 10) ; => 0 ; (expand 0 8 10) ; 以下ずっと0
3.59
a
ストリームのn番目の要素を 1/n すれば良いので
(define (integrate-series s) (stream-map / s integers))
b
(define sine-series (cons-stream 1 (integrate-series cosine-series)))
余弦の微分が正弦の符号を変えたもの = 正弦の符号を変えて積分すれば余弦
(define cosine-series (cons-stream 0 (integrate-series (scale-stream sine-stream -1))))
循環論法みたいで気持ち悪いが、遅延評価なら交互に実行すれば、求めた精度をやがて得られる。
3.60
べき級数の積の定義 https://ja.wikipedia.org/wiki/%E5%86%AA%E7%B4%9A%E6%95%B0#.E4.B9.97.E6.B3.95.E3.81.A8.E9.99.A4.E6.B3.95
(define (mul-series s1 s2)
(cons-stream
(* (stream-car s1) (stream-car s2))
(add-streams
(scale-stream (stream-cdr s2) (stream-car s1))
(mul-series (stream-cdr s1) s2))))
3.61
(define (invert-unit-series s)
(let ((sr (stream-cdr s)))
(cons-stream 1
(stream-map -
(mul-series sr
(invert-unit-series sr))))))
3.62
べき級数がよく分かっていないが、 f/g は gに対する級数Xを見つけて、 f と乗算すれば得られるはず。 よって、
(define (dev-series s1 s2)
(if (= 0 (stream-car s2))
(error "-- zero " )
(mul-series s1 (invert-unit-series s2))))
正接は sin/cos なので、
(define tangent-series (dev-series sine-series cosine-series))
SICP 3.4.2
3.38
3.38a
- Peter => Paul => Mary 45
- Peter => Mary => Paul 35
- Paul => Peter => Mary 45
- Paul => Mary => Peter 50
- Mary => Peter => Paul 40
- Mary => Paul => Peter 40
3.38b
以下のパターンが考えられる
- 並列実行により、いずれか1人の残高反映が失われる
- 同いずれか二人の残高反映が失われる
( ) が失われた処理
- Peter => Paul (Mary) 90
- Peter => Mary (Paul) 55
- Paul => Peter (Mary) 90
- Paul => Mary (Peter) 40
- Mary => Peter (Paul) 60
- Mary => Paul (Peter) 30
- Peter (Paul) (Mary) 110
- Paul (Peter) (Mary) 80
- Mary (Peter) (Mary) 50
3.39
起こりえるパターンは
- (* 10 10) => set! 100 => (+ 100 1) => set! x 101 101
- (* 10 10) => (+ 10 1) => set! 100 => set! x 11 11
- (* 10 10) => (+ 10 1) => set! x 11 => set! 100 100
- (+ 10 1) => set! x 11 => (* 11 11) => set! 121 121
4.40
- ( 10 10) => set 100 => ( 100 100 100) => set 1000000 1000000
- ( 10 10) => ( 10 10 10) => set 100 => set 1000 1000
- ( 10 10) => ( 10 10 10) => set 1000 => set 100 100
- ( 10 10 10) => set 1000 => ( 1000 1000) => set 1000000 1000000
- ( 10 10 10) => ( 10 10) => set 1000 => set 100 100
- ( 10 10 10) => ( 10 10) => set 100 => set 1000 1000
なお、serializeすると、1000000 だけになる。
3.41
不要。 balance は、処理が完了するまでは処理前の値を返す。 balance 自体は副作用を起こさないので、同時アクセスによる影響は無い。
3.42
安全かつ、差分はないように見える。 時間の浪費？という観点で言うと、make-accountの時点で serializeするので、 確かにdispatchの時点での処理時間は減るかもしれない。
3.43
交換は失敗するが合計は保持される場合
合計も保持されない場合
（不可分だった新残高計算と残高セットを分離している）
3.44
Louisは誤っている。 送金の場合は、 differenceを計算する必要が無いので、3.43のような問題は発生しない
3.45
serialized-exchangeを行う際
(serializer1 (serializer2 ((account1 'withdraw) difference) ((account2 'deposit) difference))) => (serializer1 (serializer2 ((serializer1 (withdraw account1 amount)) (serializer2 (deposit account2 amount)))))
serializer1の中にserializer1があるので、この処理は永遠に終わらない
3.46
両方のプロセスが mutexを獲得できてしまう
3.47
a
mutexを使った実装。 acquire されたら countを減らす。 count が 0 になるまでは acquireを許容。 release されたら countを増やす。
(define (make-semaphore)
(let ((count n)
(mutex1 make-mutex))
(define (the-semaphore m)
(cond
((eq m 'aquire)
(mutex1 'aquire)
(if (> count 0)
(begin
(set! count (- count 1))
(muxtex1 'release))
(begin
(mutex1 'release)
(the-semaphore m))))
((eq m 'release)
(mutex1 'aquire)
(set! count (+ count 1))
(mutex1 'release))))
the-semaphore))
b
方針は同じ. ただし、 test-and-set は 排他を採れたときにfalseを返すので分岐の順序が変わる
(define (make-semaphore)
(let ((count n)
(cell (list false)))
(define (the-semaphore m)
(cond
((eq m 'aquire)
(if (test-and-set! cell)
(the-semaphore m)
(if (> count 0)
(begin
(set! count (- count 1))
(clear! cell))
(begin
(clear! cell)
(the-semaphore m)))))
((eq m 'release)
(set! count (+ count 1)))))
the-semaphore))
3.48
デッドロックが起きるのは、二者間で 保護した資源と 保護しようとした資源とが 相互に入れ替わってしまった場合である。 本文中で言うと、Peterのa1, Paulのa2 が保護した資源。Peterのa2とPaulのa1が保護しようとした資源。 この入れ替わりが発生しないようにするためには、保護する順番を全員が共通化する必要がある。 本文中で言うと、二人ともa1から保護しに行けば、デッドロックは発生し得ない。
#lang racket
(define (make-account balance id)
(define (withdraw amount)
(if (>= balance amount)
(begin (set! balance (- balance amount))
balance)
"Insufficient funds"))
(define (deposit amount)
(set! balance (+ balance amount))
balance)
(let ((protected (make-serializer)))
(define (dispatch m)
(cond ((eq? m 'withdraw) (protected withdraw))
((eq? m 'deposit) (protected deposit))
((eq? m 'balance) balance)
((eq? m 'id) id)
(else (error "Unknown request -- MAKE-ACCOUNT"
m))))
dispatch))
(define (serialized-exchange account1 account2)
(let ((serializer1 (account1 'serializer))
(serializer2 (account2 'serializer)))
(if (< (account1 'id) (account2 'id))
((serializer1 (serializer2 exchange)) account1 account2)
((serializer2 (serializer1 exchange)) account2 account1)
)))
3.49
先行して保護した共有資源の処理結果に応じて、次に保護すべき資源が決まるような処理。 例を考えたが、思いつかなかった。。。
SICP 3.3.5
3.33
avalagerは以下の2パターンが考えられる
;avalager
(define (avalager a b c)
(let ((u (make-connector))
(v (make-connector)))
(adder a b u)
(multiplier u v c)
(constant 0.5 v)
'ok))
;avalager
(define (avalager a b c)
(let ((u (make-connector))
(v (make-connector)))
(adder a b u)
(multiplier c v u)
(constant 2 v)
'ok))
動作確認
#lang racket
;helper
(define (adder a1 a2 sum)
(define (process-new-value)
(cond ((and (has-value? a1) (has-value? a2))
(set-value! sum
(+ (get-value a1) (get-value a2))
me))
((and (has-value? a1) (has-value? sum))
(set-value! a2
(- (get-value sum) (get-value a1))
me))
((and (has-value? a2) (has-value? sum))
(set-value! a1
(- (get-value sum) (get-value a2))
me))))
(define (process-forget-value)
(forget-value! sum me)
(forget-value! a1 me)
(forget-value! a2 me)
(process-new-value))
(define (me request)
(cond ((eq? request 'I-have-a-value)
(process-new-value))
((eq? request 'I-lost-my-value)
(process-forget-value))
(else
(error "Unknown request -- ADDER" request))))
(connect a1 me)
(connect a2 me)
(connect sum me)
me)
(define (inform-about-value constraint)
(constraint 'I-have-a-value))
(define (inform-about-no-value constraint)
(constraint 'I-lost-my-value))
(define (multiplier m1 m2 product)
(define (process-new-value)
(cond ((or (and (has-value? m1) (= (get-value m1) 0))
(and (has-value? m2) (= (get-value m2) 0)))
(set-value! product 0 me))
((and (has-value? m1) (has-value? m2))
(set-value! product
(* (get-value m1) (get-value m2))
me))
((and (has-value? product) (has-value? m1))
(set-value! m2
(/ (get-value product) (get-value m1))
me))
((and (has-value? product) (has-value? m2))
(set-value! m1
(/ (get-value product) (get-value m2))
me))))
(define (process-forget-value)
(forget-value! product me)
(forget-value! m1 me)
(forget-value! m2 me)
(process-new-value))
(define (me request)
(cond ((eq? request 'I-have-a-value)
(process-new-value))
((eq? request 'I-lost-my-value)
(process-forget-value))
(else
(error "Unknown request -- MULTIPLIER" request))))
(connect m1 me)
(connect m2 me)
(connect product me)
me)
(define (constant value connector)
(define (me request)
(error "Unknown request -- CONSTANT" request))
(connect connector me)
(set-value! connector value me)
me)
(define (probe name connector)
(define (print-probe value)
(newline)
(display "Probe: ")
(display name)
(display " = ")
(display value))
(define (process-new-value)
(print-probe (get-value connector)))
(define (process-forget-value)
(print-probe "?"))
(define (me request)
(cond ((eq? request 'I-have-a-value)
(process-new-value))
((eq? request 'I-lost-my-value)
(process-forget-value))
(else
(error "Unknown request -- PROBE" request))))
(connect connector me)
me)
(define (make-connector)
(let ((value false) (informant false) (constraints '()))
(define (set-my-value newval setter)
(cond ((not (has-value? me))
(set! value newval)
(set! informant setter)
(for-each-except setter
inform-about-value
constraints))
((not (= value newval))
(error "Contradiction" (list value newval)))
(else 'ignored)))
(define (forget-my-value retractor)
(if (eq? retractor informant)
(begin (set! informant false)
(for-each-except retractor
inform-about-no-value
constraints))
'ignored))
(define (connect new-constraint)
(if (not (memq new-constraint constraints))
(set! constraints
(cons new-constraint constraints))
'ignore)
(if (has-value? me)
(inform-about-value new-constraint)
'ignore)
'done)
(define (me request)
(cond ((eq? request 'has-value?)
(if informant true false))
((eq? request 'value) value)
((eq? request 'set-value!) set-my-value)
((eq? request 'forget) forget-my-value)
((eq? request 'connect) connect)
(else (error "Unknown operation -- CONNECTOR"
request))))
me))
(define (for-each-except exception procedure list)
(define (loop items)
(cond ((null? items) 'done)
((eq? (car items) exception) (loop (cdr items)))
(else (procedure (car items))
(loop (cdr items)))))
(loop list))
(define (has-value? connector)
(connector 'has-value?))
(define (get-value connector)
(connector 'value))
(define (set-value! connector new-value informant)
((connector 'set-value!) new-value informant))
(define (forget-value! connector retractor)
((connector 'forget) retractor))
(define (connect connector new-constraint)
((connector 'connect) new-constraint))
;avalager
(define (avalager a b c)
(let ((u (make-connector))
(v (make-connector)))
(adder a b u)
(multiplier u v c)
(constant 0.5 v)
'ok))
;test
(define (test-avg x y)
(let ((a (make-connector))
(b (make-connector))
(c (make-connector)))
(probe "avalage" c)
(avalager a b c)
(constant x a)
(constant y b)
'ok))
(test-avg 2 3)
3.34
乗算器としては問題ないが、以下のようなコードで平方根がとれない。
;test (define x (make-connector)) (define y (make-connector)) (probe "x" x) (probe "y" y) (squarer x y) (constant 4 y)
結果
#<procedure:me> #<procedure:me> #<procedure:me> Probe: y = 4 #<procedure:me>
(multiplier m1 m2 product) は m1=m2 であることを知らないので、 productしか確定していない状態と解釈してしまう。
3.35
;helper
(define (square x) (* x x))
;squarer
(define (squarer a b)
(define (process-new-value)
(if (has-value? b)
(if (< (get-value b) 0)
(error "square less than 0 -- SQUARER" (get-value b))
(set-value! a (sqrt (get-value b)) me))
(if (has-value? a)
(set-value! b (square (get-value a) me))
'ignore)))
(define (process-forget-value)
(forget-value! a me)
(forget-value! b me))
(define (me request)
(cond ((eq? request 'I-have-a-value)
(process-new-value))
((eq? request 'I-lost-my-value)
(process-forget-value))
(else
(error "Unkown request" request))))
(connect a me)
(connect b me)
me)
;test
(define x (make-connector))
(define y (make-connector))
(probe "x" x)
(probe "y" y)
(squarer x y)
(constant 4 y)
3.37
(define (c+ x y)
(let ((z (make-connector)))
(adder x y z)
z))
(define (c- x y)
(let ((z (make-connector)))
(adder y z x)
z))
(define (c* x y)
(let ((z (make-connector)))
(multiplier x y z)
z))
(define (c/ x y)
(let ((z (make-connector)))
(multiplier y z x)
z))
(define (cv x)
(let ((z (make-connector))
SICP 3.3.4
3.28
(define (or-gate a1 a2 output)
(define (or-action-procedure)
(let ((new-value
(logical-or (get-signal a1) (get-signal a2))))
(after-delay or-gate-delay
(lambda ()
(set-signal! output new-value)))))
(add-action! a1 or-action-procedure)
(add-action! a2 or-action-procedure)
'ok)
3.29
OR を and-gate と inverter で実現すると
aをa1, bをb1, fをoutputと見なせば
(define (or-gate a1 b1 output)
(let ((c make-wire)
(d make-wire)
(e make-wire))
(inverter a1 c)
(inverter b1 d)
(and-gate c d e)
(inverter e output)
'ok))
遅延時間は inverter-dalay2 + and-delay1
3.30
full-adderの定義
(define (full-adder a b c-in sum c-out)
(let ((s (make-wire))
(c1 (make-wire))
(c2 (make-wire)))
(half-adder b c-in s c1)
(half-adder a s sum c2)
(or-gate c1 c2 c-out)
'ok))
これを使って
; aとbは同じ桁と仮定
; aとbは(a1,a2,...,an) のような順序で格納されたリスト
(define (ripple-carry-adder a b s c)
(let ((c-tmp make-wire))
(if (null? (cdr a))
(set-signal! c-tmp 0) ;最下位桁のcarry
(ripple-carry-adder (cdr a) (cdr b) (cdr s) c-tmp))
(full-adder (car a) (car b) c-tmp (car s) c)))
全体の遅延は full-adder-delay * n
全加算器1段の遅延は half-adder-delay * 2 + or-delay
半加算器の遅延は and-gate-delay * 2 + or-gate-delay * 1 + inverter-daly
よって、
and-gate-dlay * 4n + or-gate-delay * 3n + inverter-dlay * 2n
3.31
本文の実装
(define (accept-action-procedure! proc) (set! action-procedures (cons proc action-procedures)) (proc))
問題の実装
(define (accept-action-procedure! proc) (set! action-procedures (cons proc action-procedures)))
(proc)の実行有無で何が変わるか。
半加算器の例
(define (half-adder a b s c)
(let ((d (make-wire)) (e (make-wire)))
(or-gate a b d)
(and-gate a b c)
(inverter c e)
(and-gate d e s)
'ok))
全部追う時間が無いのでカンニング http://labs.timedia.co.jp/2014/12/sicp-ex-3.31-ex-3.32.html
ポイントは、 set時に初期値を正しく評価できるか。 単にsetした値をそのまま使うのであれば、procなしでも問題ない。 しかし、invertを含む場合、初期値を反転して評価する必要がある。 そのため、procを走らせる必要がある。
3.32
キューイングされた処理をFIFOで行わなければならない理由。 先に入ったイベントに後の処理が依存していれば、当然先のイベントを評価した後で無いと、 依存する後発処理は正しく評価できない。という話かと。。。
問題文
In particular, trace the behavior of an and-gate whose inputs change from 0,1 to 1,0 in the same segment and say how the behavior would differ if we stored a segment's procedures in an ordinary list, adding and removing procedures only at the front (last in, first out).
and-gateのinputが 0,1 -> 1,0 と変わった場合 FIFO:
初期時点 (a=0, b=1) -> 0 and 1 -> 0 a変更 (a=1, b=1) -> 1 and 1 -> 1 b変更 (a=1, b=0) -> 1 and 0 -> 0
LIFO:
初期時点 (a=0, b=1) -> 0 and 1 -> 0 b変更 (a=0, b=0) -> 0 and 0 -> 0 a変更 (a=1, b=0) -> 1 and 0 -> 0
適用中の値の変化が変わる。 が、、、FIFOが正しい、という確信が得られず。。。
SICP 3.2 3.3
3.9
3.10
3.11
3.12
3.13
3.14
3.15
3.16
3.17
#lang racket
; to use set-car! set-cdr!
(require r5rs)
(define (count-pairs lst)
(let ((counted '()))
(define (counter x)
(if (or (not (pair? x))
(memq x counted))
0
(begin
(set! counted (cons x counted))
(+ (counter (car x))
(counter (cdr x))
1))))
(counter lst)))
;test
(define x (cons 'a (cons 'b (cons 'c '()))))
(display x)
(count-pairs x) ;3
(define y (cons 'd (cons 'a '())))
(set-car! y (cons 'b (cdr y)))
(display y)
(count-pairs y) ;3
(define z (cons 'a (cons 'b (cons 'c '()))))
(set-car! (cdr z) (cdr (cdr z)))
(set-car! z (cdr z))
(display z)
(count-pairs z) ;3
3.18
#lang racket
; to use set-car! set-cdr!
(require r5rs)
(define (check-loop lst)
(let ((encountered '()))
(define (checker x)
(cond ((not (pair? x)) #f)
((memq x encountered) #t)
(else
(set! encountered (cons x encountered))
(or (checker (car x))
(checker (cdr x))))))
(checker lst)))
;test
(check-loop '()) ;f
(define x (cons 'a (cons 'b (cons 'c '()))))
(display x)
(check-loop x) ;f
(define y (cons 'd (cons 'a '())))
(set-car! y (cons 'b (cdr y)))
(display y)
(check-loop y) ;t
(define z (cons 'a (cons 'b (cons 'c '()))))
(set-car! (cdr z) (cdr (cdr z)))
(set-car! z (cdr z))
(display z)
(check-loop z) ;t
3.19
リストが有限なら3.18も有限の空間で動くじゃん。 と思いつつも空気を読んでより効率的な実装にする。
使うのはフロイドの循環検出法。 wikipediaはわかりにくかったが、ココがわかりやすかった。 http://hidekazu.hatenablog.jp/entry/2016/04/01/204153
要は、 ウサギ：cddrで2個ずつ巡る。 亀：cdrで1個ずつ巡る。 という方針
#lang racket
; to use set-car! set-cdr!
(require r5rs)
(define (smart-check-loop lst)
(define (checker x y)
x
y
(cond ((or (not (pair? x)) (not (pair? y))) #f)
((not (pair? (cdr y))) #f)
((or (eq? x y) (eq? x (cdr y))) #t)
(else
(checker (cdr x) (cddr y)))))
(if (pair? lst)
(checker lst (cdr lst))
#f))
;test
(define (make-cycle x)
(set-cdr! (last-pair x) x)
x)
(define (last-pair x)
(if (null? (cdr x))
x
(last-pair (cdr x))))
(smart-check-loop '()) ;f
(define x (cons 'a (cons 'b (cons 'c '()))))
(smart-check-loop x) ;f
(define y (make-cycle x))
y
(smart-check-loop y) ;t
3.20
3.21
キューのcar（リスト全体）と cdr（リスト末尾）が両方印字されているため、末尾要素が2度挿入されているように見えるだけ。 正しい印字プログラムは
#lang racket
(require r5rs)
(define (print-queue queue)
(display (front-ptr queue)))
;helper
(define (make-queue) (cons '() '()))
(define (front-ptr queue) (car queue))
(define (rear-ptr queue) (cdr queue))
(define (set-front-ptr! queue item) (set-car! queue item))
(define (set-rear-ptr! queue item) (set-cdr! queue item))
(define (empty-queue? queue) (null? (front-ptr queue)))
(define (front-queue queue)
(if (empty-queue? queue)
(error "FRONT called with an empty queue" queue)
(car (front-ptr queue))))
(define (insert-queue! queue item)
(let ((new-pair (cons item '())))
(cond ((empty-queue? queue)
(set-front-ptr! queue new-pair)
(set-rear-ptr! queue new-pair)
queue)
(else
(set-cdr! (rear-ptr queue) new-pair)
(set-rear-ptr! queue new-pair)
queue))))
(define (delete-queue! queue)
(cond ((empty-queue? queue)
(error "DELETE! called with an empty queue" queue))
(else
(set-front-ptr! queue (cdr (front-ptr queue)))
queue)))
;test
(define q1 (make-queue))
(insert-queue! q1 'a)
(display q1)
(newline)
(print-queue q1)
(insert-queue! q1 'b)
(display q1)
(newline)
(print-queue q1)
(delete-queue! q1)
(display q1)
(newline)
(print-queue q1)
(delete-queue! q1)
(display q1)
(newline)
(print-queue q1)
3.22
#lang racket
(require r5rs)
(define (make-queue)
(let ((front-ptr '() )
(rear-ptr '() ))
(define (set-front-ptr! item) (set! front-ptr item))
(define (set-rear-ptr! item) (set! rear-ptr item))
(define (empty-queue?) (null? front-ptr))
(define (front)
(if (empty-queue?)
(error "empty")
(car front-ptr)))
(define (rear)
(if (empty-queue?)
(error "empty")
(car rear-ptr)))
(define (insert item)
(let ((new-item (cons item '())))
(if (empty-queue?)
(begin
(set-front-ptr! new-item)
(set-rear-ptr! new-item)
(print))
(begin
(set-cdr! rear-ptr new-item)
(set-rear-ptr! new-item)
(print)))))
(define (delete)
(if (empty-queue?)
(error "empty")
(set-front-ptr! (cdr front-ptr))))
(define (print)
(display front-ptr))
(define (dispatch m)
(cond ((eq? m 'insert-queue!) insert)
((eq? m 'delete-queue!) (delete))
((eq? m 'print-queue) (print))
((eq? m 'front-queue) front)
((eq? m 'rear-queue) rear)
(else (error "undefined " m))))
dispatch))
;test
(define q1 (make-queue))
((q1 'insert-queue!) 'a)
((q1 'insert-queue!) 'b)
(q1 'delete-queue!)
(q1 'print-queue)
(q1 'delete-queue!)
(q1 'print-queue)
3.23
各要素を （値、（前要素、次要素） という形に変更した。
#lang racket
(require r5rs)
(define (make-queue)
(let ((front-ptr '() )
(rear-ptr '() ))
(define (set-front-ptr! item) (set! front-ptr item))
(define (set-rear-ptr! item) (set! rear-ptr item))
(define (empty-queue?) (null? front-ptr))
(define (front)
(if (empty-queue?)
(error "empty")
(car front-ptr)))
(define (rear)
(if (empty-queue?)
(error "empty")
(car rear-ptr)))
(define (prev item)
(if (null? item)
'()
(cadr item)))
(define (next item)
(if (null? item)
'()
(cddr item)))
(define (set-prev! item new-prev)
(if (null? item)
'()
(set-cdr! item (cons new-prev (next item)))))
(define (set-next! item new-next)
(if (null? item)
'()
(set-cdr! item (cons (prev item) new-next))))
(define (rear-insert item)
(let ((new-item (cons item (cons rear-ptr '() ))))
(if (empty-queue?)
(begin
(set-front-ptr! new-item)
(set-rear-ptr! new-item)
(print))
(begin
(set-next! rear-ptr new-item)
(set-rear-ptr! new-item)
(print)))))
(define (front-delete)
(if (empty-queue?)
(error "empty")
(begin
(set-front-ptr! (next front-ptr))
(if (null? front-ptr)
(set-rear-ptr! '())
(set-prev! front-ptr '()))
(print))))
(define (front-insert item)
(if (empty-queue?)
(rear-insert item)
(begin
(let ((new-item (cons item (cons '() front-ptr))))
(set-prev! front-ptr new-item)
(set-front-ptr! new-item))
(print))))
(define (rear-delete)
(if (empty-queue?)
(error "empty")
(begin
(set-rear-ptr! (prev rear-ptr))
(if (null? rear-ptr)
(set-front-ptr! '())
(set-next! rear-ptr '()))
(print))))
(define (print)
(define (iter item)
(if (null? item)
(newline)
(begin
(display (car item))
(iter (next item)))))
(iter front-ptr))
(define (dispatch m)
(cond ((eq? m 'rear-insert-queue!) rear-insert)
((eq? m 'front-delete-queue!) (front-delete))
((eq? m 'front-insert-queue!) front-insert)
((eq? m 'rear-delete-queue!) (rear-delete))
((eq? m 'print-queue) (print))
(else (error "undefined " m))))
dispatch))
;test
(define q1 (make-queue))
((q1 'rear-insert-queue!) 'a)
((q1 'rear-insert-queue!) 'b)
(q1 'front-delete-queue!)
(q1 'front-delete-queue!)
((q1 'front-insert-queue!) 'c)
((q1 'front-insert-queue!) 'd)
(q1 'rear-delete-queue!)
(q1 'rear-delete-queue!)
3.24
key-1とkey-2の関係性を考慮して#t/#fを返す仕様も考えたが、 それは 3.25 に包含されるので、ここではkey-1とkey-2を独立して評価する仕様にする。
#lang racket
(require r5rs)
;; same-key? は2つの引数を取り、#t/#fを返す関数
(define (make-table same-key?)
(let ((local-table (list '*table*)))
(define (lookup key-1 key-2)
(let ((subtable (assoc key-1 (cdr local-table))))
(if subtable
(let ((record (assoc key-2 (cdr subtable))))
(if record
(cdr record)
false))
false)))
(define (insert! key-1 key-2 value)
(let ((subtable (assoc key-1 (cdr local-table))))
(if subtable
(let ((record (assoc key-2 (cdr subtable))))
(if record
(set-cdr! record value)
(set-cdr! subtable
(cons (cons key-2 value)
(cdr subtable)))))
(set-cdr! local-table
(cons (list key-1
(cons key-2 value))
(cdr local-table)))))
'ok)
(define (assoc key records)
(cond ((null? records) false)
((same-key? key (caar records)) (car records))
(else (assoc key (cdr records)))))
(define (dispatch m)
(cond ((eq? m 'lookup-proc) lookup)
((eq? m 'insert-proc!) insert!)
(else (error "Unknown operation -- TABLE" m))))
dispatch))
;test
; 差が5未満なら一致と見なす
(define (my-same-key? x y)
(if (> 5 (abs (- x y)))
#t
#f))
(define test-table (make-table my-same-key?))
((test-table 'insert-proc!) 10 10 100)
((test-table 'lookup-proc) 10 10)
((test-table 'lookup-proc) 10 15)
((test-table 'lookup-proc) 6 6)
((test-table 'lookup-proc) 5 10)
3.25
#lang racket
(require r5rs)
;; same-key? はキーのリストを取り、#t/#fを返す関数
;; key-list はキーのリストを格納する
;; 表自体はリスト型のuキーを取る1次元の表 とみなす
(define (make-table same-key?)
(let ((local-table (list '*table*)))
(define (lookup key-list)
(let ((record (assoc key-list (cdr local-table))))
(if record
(cdr record)
false)))
(define (insert! key-list value)
(let ((record (assoc key-list (cdr local-table))))
(if record
(set-cdr! record value)
(set-cdr! local-table
(cons (cons key-list value)
(cdr local-table)))))
'ok)
(define (assoc key records)
(cond ((null? records) false)
((same-key? key (caar records)) (car records))
(else (assoc key (cdr records)))))
(define (dispatch m)
(cond ((eq? m 'lookup-proc) lookup)
((eq? m 'insert-proc!) insert!)
(else (error "Unknown operation -- TABLE" m))))
dispatch))
;test
; リストが完全一致なら一致と見なす
(define (my-same-key? x y) (equal? x y))
(define test-table (make-table my-same-key?))
((test-table 'insert-proc!) (list 10 10) 100)
((test-table 'insert-proc!) (list 10 10 11) 1100)
((test-table 'lookup-proc) (list 10 10))
((test-table 'lookup-proc) (list 10 10 11))
((test-table 'lookup-proc) (list 10 11))
2.26
assocが表全体を走査してしまうので、これを二分探索で評価できるようにする。
#lang racket
(require r5rs)
;; compare-key は2つの引数を取り、大小関係を返す関数
;; 第一引数が大なら正の値、小なら負の値、イコールなら0を返す。
;; 表の要素は ( key value left right ) とする
(define (make-table compare-key)
(let ((local-table (list '*table*)))
(define (lookup key-list)
(if (eq? (car local-table) '*table*)
false
(assoc key-list local-table)))
(define (assoc key-list records)
(if (null? records) false
(let ((current-result (compare-key key-list (get-key records))))
(cond ((= 0 current-result) (get-value records))
((< 0 current-result)
(assoc key-list (left-branch records)))
((> 0 current-result)
(assoc key-list (right-branch records)))))))
(define (insert! key-list value)
(define (iter key value table)
(if (eq? (car table) '*table*)
(set! local-table (make-record key-list value '() '()))
(let ((current-result (compare-key key-list (get-key table))))
(cond ((= 0 current-result)
(set-value! table value))
((< 0 current-result)
(if (null? (left-branch table))
(set-left! table (make-record key-list value '() '()))
(iter key value (left-branch table))))
((> 0 current-result)
(if (null? (right-branch table))
(set-right! table (make-record key-list value '() '()))
(iter key value (right-branch table))))))))
(iter key-list value local-table)
(display local-table)
'ok)
(define (get-key record) (car record))
(define (get-value record) (cadr record))
(define (left-branch record) (caddr record))
(define (right-branch record) (cadddr record))
(define (make-record key value left right) (list key value left right))
(define (set-value! record value) (set-car! (cdr record) value))
(define (set-left! record left) (set-car! (cddr record) left))
(define (set-right! record right) (set-car! (cdddr record) right))
(define (dispatch m)
(cond ((eq? m 'lookup-proc) lookup)
((eq? m 'insert-proc!) insert!)
(else (error "Unknown operation -- TABLE" m))))
dispatch))
;test
; リストの上位要素から順次比較し、差分があった要素の大小関係を返す.
; リスト長さが違う場合は、0が入っていると仮定する
(define (my-compare-key? x y)
(cond ((equal? x y) 0)
((not (pair? x)) -1)
((not (pair? y)) 1)
((= (car x) (car y)) (my-compare-key? (cdr x) (cdr y)))
(else (- (car x) (car y)))))
(define test-table (make-table my-compare-key?))
((test-table 'insert-proc!) (list 10 10) 100)
((test-table 'insert-proc!) (list 10 10 11) 1100)
((test-table 'insert-proc!) (list 10 10 9) 900)
((test-table 'lookup-proc) (list 10 10))
((test-table 'lookup-proc) (list 10 10 11))
((test-table 'lookup-proc) (list 10 10 9))
((test-table 'lookup-proc) (list 10 11))
SICP 3.1
3.1
#lang racket
(define (make-accumulator sum)
(lambda (x)
(set! sum (+ sum x))
sum))
(define A (make-accumulator 5))
;test
(A 10)
(A 10)
3.2
#lang racket
(define (make-monitored function)
(let ((call-count 0))
(lambda (arg)
(cond
((eq? arg 'how-many-calls?) call-count)
((eq? arg 'reset-count) (set! call-count 0))
(else (set! call-count (+ 1 call-count))
(function arg))))))
;test
(define s (make-monitored sqrt))
(s 'how-many-calls?)
(s 100)
(s 'how-many-calls?)
(s 100)
(s 'how-many-calls?)
(s 'reset-count)
(s 'how-many-calls?)
3.3
#lang racket
(define (make-account balance real-password)
(define (withdraw amount)
(if (>= balance amount)
(begin (set! balance (- balance amount))
balance)
"Insufficient funds"))
(define (deposit amount)
(set! balance (+ balance amount))
balance)
(define (dispatch inputed-password msg)
(if (eq? inputed-password real-password)
(cond ((eq? msg 'withdraw) withdraw)
((eq? msg 'deposit) deposit)
(else (error "Unknown request -- MAKE-ACCOUNT" msg)))
(error "Incorrect Password")))
dispatch)
;test
(define acc (make-account 100 'foo))
((acc 'foo 'withdraw) 40)
((acc 'bar 'deposit) 50)
3.4
仕様
- 連続7回間違えたら call the Cops
- 成功したらリセット
#lang racket
(define (make-account balance real-password)
(define (police amount) "Call the Cops")
(define (wrong-password amount) "Incorrect Password")
(let ((count 0)
(limit 7))
(define (withdraw amount)
(if (>= balance amount)
(begin (set! balance (- balance amount))
balance)
"Insufficient funds"))
(define (deposit amount)
(set! balance (+ balance amount))
balance)
(define (dispatch inputed-password msg)
(if (eq? inputed-password real-password)
(begin
(set! count 0)
(cond ((eq? msg 'withdraw) withdraw)
((eq? msg 'deposit) deposit)
(else (error "Unknown request -- MAKE-ACCOUNT" msg))))
(begin
(set! count (+ 1 count))
(if (>= count limit)
police
wrong-password))))
dispatch))
;test
(define acc (make-account 100 'foo))
((acc 'foo 'withdraw) 40)
((acc 'bar 'deposit) 10)
((acc 'foo 'withdraw) 40)
((acc 'bar 'deposit) 10)
((acc 'bar 'deposit) 20)
((acc 'bar 'deposit) 30)
((acc 'bar 'deposit) 40)
((acc 'bar 'deposit) 50)
((acc 'bar 'deposit) 60)
((acc 'bar 'deposit) 70)
((acc 'bar 'deposit) 80)
((acc 'foo 'deposit) 20)
((acc 'bar 'deposit) 10)
3.5
#lang racket
(define (random-in-range low high)
(let ((range (- high low)))
(+ low (random range))))
(define (monte-carlo trials experiment)
(define (iter trials-remaining trials-passed)
(cond ((= trials-remaining 0)
(/ trials-passed trials))
((experiment)
(iter (- trials-remaining 1) (+ trials-passed 1)))
(else
(iter (- trials-remaining 1) trials-passed))))
(iter trials 0))
(define (square x) (* x x))
; モンテカルロの結果と (x1,y1)と(x2,y2)を対角に持つ長方形の積を出力
; p 述語関数
; trials 試行回数
(define (estimate-integral p x1 x2 y1 y2 trials)
(* (monte-carlo
trials
(lambda() (p (random-in-range x1 x2)
(random-in-range y1 y2))))
(* (- x2 x1) (- y2 y1))))
;単位円をテストする関数
(define (circle x y)
(<= (+ (square x) (square y)) 1))
;中心 (5,5) 半径 5 の円
(define (circle2 x y)
(<= (+ (square (- x 5)) (square (- y 5))) (square 5)))
; piの見積もり (pi=S/r^2)
; S 円の面積
; r 半径
(define (estimate-pi S r)
(/ S (square r)))
;test
(estimate-pi
(estimate-integral circle -1 1 -1 1 1000000)
1.0)
(estimate-pi
(estimate-integral circle2 0 10 0 10 1000000)
5.0)
単位円だと、結果は3近傍になり、3.1よりは大きくならない。
円を少し大きくして 中心 5,5 半径5で試してみると 3.16 となった。
3.6
#lang racket
;lcgによる乱数生成
(define (lcg x)
(remainder (+ (* x 13) 5) 24))
(define new-rand
(let ((x 1))
(define (reset new-seed)
(begin (set! x new-seed)
x))
(define (generate)
(begin
(set! x (lcg x))
x))
(define (dispatch msg)
(cond
((eq? msg 'reset) reset)
((eq? msg 'generate) generate)
(else (error "Unkown arg"))))
dispatch))
;test
((new-rand 'reset) 2)
((new-rand 'generate))
((new-rand 'generate))
((new-rand 'generate))
((new-rand 'generate))
(newline)
((new-rand 'reset) 2)
((new-rand 'generate))
((new-rand 'generate))
((new-rand 'generate))
((new-rand 'generate))
3.7
#lang racket
(define (make-account balance real-password)
(define (withdraw amount)
(if (>= balance amount)
(begin (set! balance (- balance amount))
balance)
"Insufficient funds"))
(define (deposit amount)
(set! balance (+ balance amount))
balance)
(define (dispatch inputed-password msg)
(if (eq? inputed-password real-password)
(cond ((eq? msg 'withdraw) withdraw)
((eq? msg 'deposit) deposit)
(else (error "Unknown request -- MAKE-ACCOUNT" msg)))
(error "Incorrect Password")))
dispatch)
(define (make-joint account current-pass new-pass)
(lambda (pass msg)
(if (eq? pass new-pass)
(account current-pass msg)
(error "Incorrect Password"))))
; 最初のアカウント
(define peter-acc (make-account 100 'open-sesame))
; 最初のアカウントを使う
((peter-acc 'open-sesame 'deposit) 10)
; 第2のアカウント
(define paul-acc (make-joint peter-acc 'open-sesame 'rosebud))
; 第2のアカウントを使う
((paul-acc 'rosebud 'withdraw) 100)
; 第2のアカウントを最初のアカウントのPWで使う（失敗する）
((paul-acc 'open-sesame 'withdraw) 100)
3.8
引数が0だと、以降ずっと0を返す関数 f を定義する。
#lang racket
(define f
(let ((x 1))
(lambda (arg)
(begin
(set! x (* x arg))
x))))
;right->left
(+ (f 1) (f 0))
;left->right
(+ (f 0) (f 1))
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
