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
SICP 演習問題 2.4
2.73
a
else節では、 operator 抽出した演算子に対応した演算処理関数を呼び出し、 operands で抽出した式に適用している。
number, valiableについては、 operator で演算子を抽出できないので吸収できない。
b
c
get, put が標準関数にないので、3.3.3 の実装を借用した。
#lang planet neil/sicp
;記号微分
(define (deriv exp var)
(cond ((number? exp) 0)
((variable? exp) (if (same-variable? exp var) 1 0))
(else ((get 'deriv (operator exp)) (operands exp) var))))
(define (operator exp) (car exp))
(define (operands exp) (cdr exp))
(define (=number? exp num)
(and (number? exp) (= exp num)))
(define (variable? x) (symbol? x))
(define (same-variable? v1 v2)
(and (variable? v1) (variable? v2) (eq? v1 v2)))
;表の実装(3.3.3 から流用)
(define (lookup key table)
(let ((record (assoc key (cdr table))))
(if record
(cdr record)
false)))
(define (assoc key records)
(cond ((null? records) false)
((equal? key (caar records)) (car records))
(else (assoc key (cdr records)))))
(define (make-table)
(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 (dispatch m)
(cond ((eq? m 'lookup-proc) lookup)
((eq? m 'insert-proc!) insert!)
(else (error "Unknown operation -- TABLE" m))))
dispatch))
(define operation-table (make-table))
(define get (operation-table 'lookup-proc))
(define put (operation-table 'insert-proc!))
; ここから回答
; b
(define (make-sum a1 a2) (list '+ a1 a2))
(define (make-product m1 m2) (list '* m1 m2))
;;sum
(define (install-sum-package)
(define (addend s) (car s))
(define (augend s) (cadr s))
(put 'deriv
'+
(lambda (exp var)
(make-sum (deriv (addend exp) var)
(deriv (augend exp) var)))))
;;product
(define (install-product-package)
(define (multiplier p) (car p))
(define (multiplicand p) (cadr p))
(put 'deriv
'*
(lambda (exp var)
(make-sum
(make-product (multiplier exp)
(deriv (multiplicand exp) var))
(make-product (deriv (multiplier exp) var)
(multiplicand exp))))))
; c
;;exponent
(define (install-exponent-package)
(define (make-exponentiation base exp)
(cond ((or (=number? base 1) (=number? exp 0)) 1)
((=number? exp 0) 0)
((=number? base 1) exp)
((and (number? exp) (number? base) (expt base exp)))
(else (list '** base exp))))
(define (exponentiation? e)
(cond ((or (pair? e) (eq? (car e) '**)))))
(define (base e) (car e))
(define (exponent e) (cadr e))
(put 'deriv
'**
(lambda (exp var)
(make-product
(make-product
(exponent exp)
(make-exponentiation
(base exp)
(make-sum (exponent exp) '-1)))
(deriv (base exp) var)))))
;test
(install-sum-package)
(install-product-package)
(install-exponent-package)
(get 'deriv '+)
(get 'deriv '*)
(get 'deriv '**)
(deriv 'y 'x)
(deriv '(+ x 1) 'x)
(deriv '(* x 3) 'x)
(deriv '(+ (* x x) (* x 3)) 'x)
(deriv '(+ (** x 4) (** x 3)) 'x)
d
putの順序を入れ替える。
例）
(put '+
'deriv
(lambda (exp var)
(make-sum (deriv (addend exp) var)
(deriv (augend exp) var)))))
2.74
a
以下を前提として実装する ・各事業所毎に従業員名から対応するレコードを取得する関数を用意する。 ・事業者名と従業員レコード取得関数を紐付けてテーブルに登録する
(define (get-record name divison) ((get divison 'record) name))
b
以下を前提として実装する ・各事業所毎に従業員レコードから給料を取得する関数を用意する。 ・事業者名と給与取得関数を紐付けてテーブルに登録する
(define (get-salary name division) ((get divison 'salary) ((get-record name division)))
c
(define (find-employee-record name divisions)
(if (null? divisions)
#f
(or (get-record name (car divisions))
(find-employee-record name (cdr divisions)))))
d
そのカイシャの record取得関数と給与取得関数を合併後の名前とひも付けて、テーブルに登録する。 例）
(put 'satiable-company 'record satiable-get-record) (put 'satiable-company 'salaly satiable-get-salary)
2.75
#lang planet neil/sicp
(define (make-from-mag-ang r th)
(define (dispatch op)
(cond ((eq? op 'real-part) (* r (cos th)))
((eq? op 'imag-part) (* r (sin th)))
((eq? op 'magnitude) r)
((eq? op 'angle) th)
(else
(error "Unknown op -- MAKE-FROM-REAL-IMAG" op))))
dispatch)
;test
(define pi 3.14159265359879)
(define complex1 (make-from-mag-ang 2 (/ pi 6)))
(complex1 'real-part)
(complex1 'imag-part)
(complex1 'magnitude)
(complex1 'angle)
2.76
明白な振分けを持つ汎用演算,
新しい型
すべての手続について、新しい型タグと対応する処理を実装する （例） 整数の四則演算に有理数の四則演算を加える場合、 加減乗除それぞれに、有理数を取る場合を実装する。
新しい演算
新しい演算処理を実装するだけ。（既存の演算には手を加えない） （例） 整数、有理数の四則演算にべき乗計算を加える場合、 べき乗計算の関数を実装すれば良い。 （既存の加減乗除関数には影響しない）
データ主導流
新しい型
パッケージを追加する。 （例） 整数の四則演算に有理数の四則演算を加える場合、 有理数のパッケージを実装する。
新しい演算
新しい演算を使用するパッケージ全てに、演算処理を追加する。 （例） 整数、有理数の四則演算にべき乗計算を加える場合、 整数パッケージ、有理数パッケージそれぞれにべき乗計算を実装する。
メッセージパッシング流
新しい型
新たなデータオブジェクト構成子を定義する （例） 整数の四則演算に有理数の四則演算を加える場合、 有理数のデータオブジェクトを生成する関数を実装する
新しい演算
既存のデータオブジェクト構成子に、新しい演算メッセージを受ける処理を定義する （例） 整数、有理数の四則演算にべき乗計算を加える場合、 整数、有理数の構成子それぞれに メッセージ exponentを受けたらべき乗を行う処理を追加する。
新しい型が絶えず追加されるシステム
パッケージ追加だけで対応でき、既存処理が影響受けないデータ手動流が適切。 同様に、構成子の追加だけで対応できるメッセージパッシングも適切。
新しい演算が絶えず追加されるシステム
演算処理を関数として実装すれば対応でき、既存処理が影響を受けない、明確な振り分けを持つ汎用演算が適切。
SICP 演習問題 2.3
2.53
(list 'a 'b 'c) ;=> '(a b c) (list (list 'george)) ;=> '((george)) (cdr '((x1 x2) (y1 y2))) ;=> '((y1 y2)) (cadr '((x1 x2) (y1 y2))) ;=> '(y1 y2) (pair? (car '(a short list))) ;=> #f (memq 'red '((red shoes) (blue socks))) ;=> #f (memq 'red '(red shoes blue socks)) ;=> '(red shoes blue socks)
2.54
#lang racket
(define (equal lst1 lst2)
(if (and (pair? lst1) (pair? lst2))
(and (equal? (car lst1) (car lst2)) (equal (cdr lst1) (cdr lst2)))
(eq? lst1 lst2)))
;test
(define lst1 '(a b c d))
(define lst2 '(a c b d))
(equal 'a 'a)
(equal 'a 'b)
(equal lst1 lst1)
(equal lst1 lst2)
2.55
''hoge は '('hoge)を返す。 つまり、 (quote (quote hoge))
(display ''hoge) ;=> 'hoge
そのため、(car ''hoge) の返り値は 'quote（記号の')となる。 なお、(cdr ''hoge)は'(hoge) （記号のhoge）となる
(car ''hoge) 'quote (cdr ''hoge) ;=> '(hoge) (cadr ''hoge) ;=> 'hoge
2.56
#lang racket
(define (deriv exp var)
(cond ((number? exp) 0)
((variable? exp)
(if (same-variable? exp var) 1 0))
((sum? exp)
(make-sum (deriv (addend exp) var)
(deriv (augend exp) var)))
((product? exp)
(make-sum
(make-product (multiplier exp)
(deriv (multiplicand exp) var))
(make-product (deriv (multiplier exp) var)
(multiplicand exp))))
((exponentiation? exp)
(make-product (make-product
(exponent exp)
(make-exponentiation
(base exp)
(make-sum (exponent exp) '-1)))
(deriv (base exp) var)))
(else
(error "unknown expression type --DERIV" exp))))
;べき乗
;base^expを (** base exp) と表現
(define (make-exponentiation base exp)
(cond ((or (=number? base 1) (=number? exp 0)) 1)
((=number? exp 0) 0)
((=number? exp 1) base)
((and (number? exp) (number? base) (expt base exp)))
(else (list '** base exp))))
(define (exponentiation? e)
(and (pair? e) (eq? (car e) '**)))
(define (base e) (cadr e))
(define (exponent e) (caddr e))
;数値、変数
(define (=number? exp num)
(and (number? exp) (= exp num)))
(define (variable? x) (symbol? x))
(define (same-variable? v1 v2)
(and (variable? v1) (variable? v2) (eq? v1 v2)))
;加算
(define (sum? a) (and (pair? a) (eq? (car a) '+)))
(define (addend a) (cadr a))
(define (augend a) (caddr a))
(define (make-sum a1 a2)
(cond ((=number? a1 0) a2)
((=number? a2 0) a1)
((and (number? a1) (number? a2)) (+ a1 a2))
(else (list '+ a1 a2))))
;乗算
(define (make-product m1 m2)
(cond ((or (=number? m1 0) (=number? m2 0)) 0)
((=number? m1 1) m2)
((=number? m2 1) m1)
((and (number? m1) (number? m2)) (* m1 m2))
(else (list '* m1 m2))))
(define (product? m) (and (pair? m) (eq? (car m) '*)))
(define (multiplier m) (cadr m))
(define (multiplicand m) (caddr m))
;test
(deriv '(+ x 3) 'x)
;;=>1
(deriv '(* x y) 'x)
;;=>y
(deriv '(* (* x y) (+ x 3)) 'x)
;;=>xy+y(x+3)
;(x^5-3x+y+2)
(define test-exp1
(make-sum
(make-exponentiation 'x '5)
(make-sum
(make-product '-3 'x)
(make-sum 'y '2))))
(deriv test-exp1 'x)
;;=>5x^4-3
2.57
#lang racket
;加算
;リストを受け取り、和を作る関数
(define (make-sum-list sum-list)
(define (iter rest result)
(if (null? rest)
(cons '+ (reverse result))
(iter (cdr rest) (cons (car rest) result))))
(iter sum-list '()))
(define (sum? a) (and (pair? a) (eq? (car a) '+)))
(define (addend a) (cadr a))
(define (augend a)
(let ((augend (cddr a)))
(if (> (length augend) 1)
(make-sum-list augend)
(car augend))))
(define (make-sum a1 a2)
(cond ((=number? a1 0) a2)
((=number? a2 0) a1)
((and (number? a1) (number? a2)) (+ a1 a2))
(else (make-sum-list (list a1 a2)))))
;乗算
(define (make-product-list product-list)
(define (iter rest result)
(if (null? rest)
(cons '* (reverse result))
(iter (cdr rest) (cons (car rest) result))))
(iter product-list '()))
(define (make-product m1 m2)
(cond ((or (=number? m1 0) (=number? m2 0)) 0)
((=number? m1 1) m2)
((=number? m2 1) m1)
((and (number? m1) (number? m2)) (* m1 m2))
(else (make-product-list (list m1 m2)))))
(define (product? m) (and (pair? m) (eq? (car m) '*)))
(define (multiplier m) (cadr m))
(define (multiplicand m)
(let ((multiplicand (cddr m)))
(if (> (length multiplicand) 1)
(make-product-list multiplicand)
(car multiplicand))))
;べき乗
(define (make-exponentiation base exp)
(cond ((or (=number? base 1) (=number? exp 0)) 1)
((=number? exp 0) 0)
((=number? exp 1) base)
((and (number? exp) (number? base) (expt base exp)))
(else (list '** base exp))))
(define (exponentiation? e) (and (pair? e) (eq? (car e) '**)))
(define (base e) (cadr e))
(define (exponent e) (caddr e))
(define (deriv exp var)
(cond ((number? exp) 0)
((variable? exp)
(if (same-variable? exp var) 1 0))
((sum? exp)
(make-sum (deriv (addend exp) var)
(deriv (augend exp) var)))
((product? exp)
(make-sum
(make-product (multiplier exp)
(deriv (multiplicand exp) var))
(make-product (deriv (multiplier exp) var)
(multiplicand exp))))
((exponentiation? exp)
(make-product (make-product
(exponent exp)
(make-exponentiation
(base exp)
(make-sum (exponent exp) '-1)))
(deriv (base exp) var)))
(else
(error "unknown expression type --DERIV" exp))))
;数値、変数
(define (=number? exp num)
(and (number? exp) (= exp num)))
(define (variable? x) (symbol? x))
(define (same-variable? v1 v2)
(and (variable? v1) (variable? v2) (eq? v1 v2)))
;test
(deriv '(** x 3) 'x)
(deriv '(+ x 3) 'x)
(deriv '(* x y) 'x)
(deriv '(* (* x y) (+ x 3)) 'x)
;;=> xy + y(x+3)
(deriv '(* x y (+ x 3)) 'x)
;;=> xy + y(x+3)
;(x^5-3xy+y+2)
(define test-exp1
(make-sum-list
(list
(make-exponentiation 'x '5)
(make-product-list '(-3 x y))
'y
'2)))
(deriv test-exp1 'x)
;;=>5x^4-3y
2.58
2.58a
加算、乗算、べき乗について、 演算子の位置を変えるだけで良い(car, cadrを入れ替える）
#lang racket
(define (deriv exp var)
(cond ((number? exp) 0)
((variable? exp)
(if (same-variable? exp var) 1 0))
((sum? exp)
(make-sum (deriv (addend exp) var)
(deriv (augend exp) var)))
((product? exp)
(make-sum
(make-product (multiplier exp)
(deriv (multiplicand exp) var))
(make-product (deriv (multiplier exp) var)
(multiplicand exp))))
((exponentiation? exp)
(make-product (make-product
(exponent exp)
(make-exponentiation
(base exp)
(make-sum (exponent exp) '-1)))
(deriv (base exp) var)))
(else
(error "unknown expression type --DERIV" exp))))
;べき乗
;base^expを (** base exp) と表現
(define (make-exponentiation base exp)
(cond ((or (=number? base 1) (=number? exp 0)) 1)
((=number? exp 0) 0)
((=number? base 1) exp)
((and (number? exp) (number? base) (expt base exp)))
(else (list base '** exp))))
(define (exponentiation? e)
(and (pair? e) (eq? (cadr e) '**)))
(define (base e) (car e))
(define (exponent e) (caddr e))
;数値、変数
(define (=number? exp num)
(and (number? exp) (= exp num)))
(define (variable? x) (symbol? x))
(define (same-variable? v1 v2)
(and (variable? v1) (variable? v2) (eq? v1 v2)))
;加算
(define (sum? a) (and (pair? a) (eq? (cadr a) '+)))
(define (addend a) (car a))
(define (augend a) (caddr a))
(define (make-sum a1 a2)
(cond ((=number? a1 0) a2)
((=number? a2 0) a1)
((and (number? a1) (number? a2)) (+ a1 a2))
(else (list a1 '+ a2))))
;乗算
(define (make-product m1 m2)
(cond ((or (=number? m1 0) (=number? m2 0)) 0)
((=number? m1 1) m2)
((=number? m2 1) m1)
((and (number? m1) (number? m2)) (* m1 m2))
(else (list m1 '* m2))))
(define (product? m) (and (pair? m) (eq? (cadr m) '*)))
(define (multiplier m) (car m))
(define (multiplicand m) (caddr m))
;test
(deriv '(x + 3) 'x)
(deriv '(x * y) 'x)
(deriv '((x * y) * (x + 3)) 'x)
;(x^5-3x+y+2)
(define test-exp1
(make-sum
(make-exponentiation 'x '5)
(make-sum
(make-product '-3 'x)
(make-sum 'y '2))))
(deriv test-exp1 'x)
2.58b
式の解釈方針 1. 加算記号を探す 1. 最初の加算記号について addend と augend を取り出す 1. addendもaugendも出力は式or数値なので、addendの結果、augendの結果をそれぞれ再帰
#lang racket
(define nil '())
(define (deriv exp var)
(cond ((number? exp) 0)
((variable? exp)
(if (same-variable? exp var) 1 0))
((sum? exp)
(make-sum (deriv (addend exp) var)
(deriv (augend exp) var)))
((product? exp)
(make-sum
(make-product (multiplier exp)
(deriv (multiplicand exp) var))
(make-product (deriv (multiplier exp) var)
(multiplicand exp))))
((exponentiation? exp)
(make-product (make-product
(exponent exp)
(make-exponentiation
(base exp)
(make-sum (exponent exp) '-1)))
(deriv (base exp) var)))
(else
(error "unknown expression type --DERIV" exp))))
;べき乗
;base^expを (** base exp) と表現
(define (make-exponentiation base exp)
(cond ((or (=number? base 1) (=number? exp 0)) 1)
((=number? exp 0) 0)
((=number? base 1) exp)
((and (number? exp) (number? base) (expt base exp)))
(else (list base '** exp))))
(define (exponentiation? e)
(and (pair? e) (eq? (cadr e) '**)))
(define (base e) (car e))
(define (exponent e) (caddr e))
;数値、変数
(define (=number? exp num)
(and (number? exp) (= exp num)))
(define (variable? x) (symbol? x))
(define (same-variable? v1 v2)
(and (variable? v1) (variable? v2) (eq? v1 v2)))
;加算
;... + ... + ... のような形を探す。
;具体的には、順繰りにcdrを取っていって、 + が出てきたらtrueとみなす。
(define (sum? x)
(and (pair? x)
(or (eq? (car x) '+)
(sum? (cdr x)))))
(define (make-sum a1 a2)
(cond ((=number? a1 0) a2)
((=number? a2 0) a1)
;数値+数値は和を出力
((and (number? a1) (number? a2)) (+ a1 a2))
;式 + 数値は 数値+式 に直して仕切りなおし
((number? a2) (make-sum a2 a1))
;式or数値+式
((sum? a2) (if (and (number? a1) (number? (addend a2)))
(make-sum (+ a1 (addend a2)) ;数値+(数値+式) は数値の和を求める
(augend a2))
(cons a1 (cons '+ a2)))) ;式or数値 + 式
(else (list a1 '+ a2))))
; + が出るまで要素を延々出力
(define (addend s)
(define (f x)
(if (eq? (car x) '+)
nil
(cons (car x) (f (cdr x)))))
(let ((res (f s)))
(if (null? (cdr res))
(car res)
res)))
;+が出たらそこ以降を出力。
;ただし、リストの場合があるので考慮して出力する
(define (augend s)
(define (f x)
(if (eq? (car x) '+)
(if (null? (cdr x))
(car x)
(cdr x))
(f (cdr x))))
(let ((res (f s)))
(if (null? (cdr res))
(car res)
res)))
;乗算
(define (make-product m1 m2)
(cond ((or (=number? m1 0) (=number? m2 0)) 0)
((=number? m1 1) m2)
((=number? m2 1) m1)
; 数値*数値は積を出力
((and (number? m1) (number? m2)) (* m1 m2))
; 式*数値は数値*式に直して再度
((number? m2) (make-product m2 m1))
; 式or数値*式
((product? m2) (if (and (number? m1) (number? (multiplier m2)))
(make-product (* m1 (multiplier m2)) ; 数値*(数値*式)
(multiplicand m2))
(cons m1 (cons '* m2))))
(else (list m1 '* m2))))
(define (product? m) (and (pair? m) (pair? (cdr m)) (eq? (cadr m) '*)))
(define (multiplier m) (car m))
(define (multiplicand m) (if (null? (cdddr m))
(caddr m)
(cddr m)))
;test
(display "d(x + 3)/dx -> ")
(deriv '(x + 3) 'x)
(display "d(x * y)/dx -> ")
(deriv '(x * y) 'x)
(display "d((x * y) * (x + 3))/dx -> ")
(deriv '((x * y) * (x + 3)) 'x)
(display "d(x + 3 * (x + y + 2))/dx -> ")
(deriv '(x + 3 * (x + y + 2)) 'x)
(display "d(x + 3 * (2 * x + y + 2))/dx -> ")
(deriv '(x + 3 * (2 * x + y + 2)) 'x)
2.59
#lang racket
(define (union-set set1 set2)
(cond ((null? set1) set2)
((null? set2) set1)
((element-of-set? (car set1) set2)
(union-set (cdr set1) set2))
(else (cons (car set1) (union-set (cdr set1) set2)))))
(define (element-of-set? x set)
(cond ((null? set) false)
((equal? x (car set)) true)
(else (element-of-set? x (cdr set)))))
;test
(define s1 '(a b c d))
(define s2 '(c d e f))
(union-set s1 s2)
2.60
element-of-set, intersection-set は変わらない。 adjoin-set, union-setは
(define (adjoin-set2 x set) (cons x set)) (define (union-set2 set1 set2) (append set1 set2))
となる。
効率は、element-of-set, intersection-setは落ち、 リストの要素数m, 正味の要素数n (m>n)とすると、O(m),O(m2)になる。
adjoin-set, union-setは改善する。 リスト内容の参照が不要となるので、共にO(1)となる。
よって、要素追加が要素参照よりも多い場合に有用といえる。
2.61
(define (adjoin-set3 x set)
(cond ((null? set) (list x))
((< (car set) x )
(cons (car set) (adjoin-set3 x (cdr set))))
((= (car set) x) set)
((< x (car set))
(cons x set))))
リストに要素が存在している場合、elements-of-set同様に半分のステップ数で発見できる。
2.62
(define (union-set3 set1 set2)
(cond ((null? set1) set2)
((null? set2) set1)
((< (car set1) (car set2))
(cons (car set1) (union-set3 (cdr set1) set2)))
((= (car set1) (car set2))
(cons (car set1) (union-set3 (cdr set1) (cdr set2))))
((> (car set1) (car set2))
(cons (car set2) (union-set3 set1 (cdr set2))))))
2.63
a
同じリストを出力する '(1 3 5 7 9 11)
b
後者のほうがステップ数の増加が遅い。 前者はappend処理(O(n))がある分ステップ数が増加するため。
2.64
a
（「明快で簡潔」のレベル感がわからないけれど。。。） まず、左の部分器を作るために再帰。 左の部分木に含まれなかった要素を根(entry)に。 残りの要素から右部分木を作るために再帰。 最後に、根と左右の部分木をconsで結合して木を作る。
(define (partial-tree elts n)
(if (= n 0)
(cons '() elts)
(let ((left-size (quotient (- n 1) 2)))
; 左の部分木を作る
(let ((left-result (partial-tree elts left-size)))
(let ((left-tree (car left-result))
(non-left-elts (cdr left-result))
(right-size (- n (+ left-size 1))))
; 根を決める
(let ((this-entry (car non-left-elts))
; 右の部分木を作る
(right-result (partial-tree (cdr non-left-elts)
right-size)))
(let ((right-tree (car right-result))
(remaining-elts (cdr right-result)))
; 根に左右の部分木を結合する
(cons (make-tree this-entry left-tree right-tree)
remaining-elts))))))))
(list 1 3 5 7 9 11) から生成される木は以下
(list->tree (list 1 3 5 7 9 11)) ; => '(5 (1 () (3 () ())) (9 (7 () ()) (11 () ())))
b
左右の木の要素数はそれぞれ n/2 となる。 2T(n/2) なので、 O(n)
2.65
#lang Racket
(define (union-set4 set1 set2)
(list->tree
(union-set3 (tree->list-2 set1)
(tree->list-2 set2))))
(define (intersection-set4 set1 set2)
(list->tree
(intersection-set3 (tree->list-2 set1)
(tree->list-2 set2))))
(define (union-set3 set1 set2)
(cond ((null? set1) set2)
((null? set2) set1)
((< (car set1) (car set2))
(cons (car set1) (union-set3 (cdr set1) set2)))
((= (car set1) (car set2))
(cons (car set1) (union-set3 (cdr set1) (cdr set2))))
((> (car set1) (car set2))
(cons (car set2) (union-set3 set1 (cdr set2))))))
(define (intersection-set3 set1 set2)
(if (or (null? set1) (null? set2))
'()
(let ((x1 (car set1)) (x2 (car set2)))
(cond ((= x1 x2)
(cons x1
(intersection-set3 (cdr set1)
(cdr set2))))
((< x1 x2)
(intersection-set3 (cdr set1) set2))
((< x2 x1)
(intersection-set3 set1 (cdr set2)))))))
(define (tree->list-2 tree)
(define (copy-to-list tree result-list)
(if (null? tree)
result-list
(copy-to-list (left-branch tree)
(cons (entry tree)
(copy-to-list (right-branch tree)
result-list)))))
(copy-to-list tree '()))
(define (list->tree elements)
(car (partial-tree elements (length elements))))
(define (partial-tree elts n)
(if (= n 0)
(cons '() elts)
(let ((left-size (quotient (- n 1) 2)))
(let ((left-result (partial-tree elts left-size)))
(let ((left-tree (car left-result))
(non-left-elts (cdr left-result))
(right-size (- n (+ left-size 1))))
(let ((this-entry (car non-left-elts))
(right-result (partial-tree (cdr non-left-elts)
right-size)))
(let ((right-tree (car right-result))
(remaining-elts (cdr right-result)))
(cons (make-tree this-entry left-tree right-tree)
remaining-elts))))))))
(define (entry tree) (car tree))
(define (left-branch tree) (cadr tree))
(define (right-branch tree) (caddr tree))
(define (make-tree entry left right) (list entry left right))
2.66
#lang Racket
(define (lookup given-key set-of-records)
(if (null? set-of-records)
false
(let ((current-key (key (entry set-of-records))))
(cond ((equal? given-key current-key) current-key)
((< given-key current-key)
(lookup given-key (left-branch set-of-records)))
(else (lookup given-key (right-branch set-of-records)))))))
;helper
(define nil '())
(define (entry tree) (car tree))
(define (left-branch tree) (cadr tree))
(define (right-branch tree) (caddr tree))
(define (make-tree entry left right)
(list entry left right))
;key(仮)
(define (key entry) entry)
;test
(define tree1
(make-tree
'5
(make-tree
'2
(make-tree '1 nil nil)
(make-tree '3 nil nil))
(make-tree
'8
(make-tree '7 nil nil)
(make-tree '9 nil nil))))
(lookup 5 tree1)
(lookup 3 tree1)
(lookup 7 tree1)
(lookup 6 tree1)
(lookup 4 tree1)
2.67
'(A D A B B C A)
2.68
#lang racket
(define (encode-symbol symbol tree)
(define (element-of-branch? branch)
(if (leaf? branch)
(equal? symbol (symbol-leaf branch))
(element-of-set? symbol (symbols branch))))
(let ((left (left-branch tree))
(right (right-branch tree)))
(cond ((element-of-branch? left)
(if (leaf? left)
'(0)
(cons 0 (encode-symbol symbol left))))
((element-of-branch? right)
(if (leaf? right)
'(1)
(cons 1 (encode-symbol symbol right))))
(else
(error "bad symbol"symbol)))))
;既存コード
(define (encode message tree)
(if (null? message)
'()
(append (encode-symbol (car message) tree)
(encode (cdr message) tree))))
(define (decode bits tree)
(define (decode-1 bits current-branch)
(if (null? bits)
'()
(let ((next-branch
(choose-branch (car bits) current-branch)))
(if (leaf? next-branch)
(cons (symbol-leaf next-branch)
(decode-1 (cdr bits) tree))
(decode-1 (cdr bits) next-branch)))))
(decode-1 bits tree))
(define (choose-branch bit branch)
(cond ((= bit 0) (left-branch branch))
((= bit 1) (right-branch branch))
(else (error "bad bit -- CHOOSE-BRANCH" bit))))
(define (element-of-set? x set)
(cond ((null? set) false)
((equal? x (car set)) true)
(else (element-of-set? x (cdr set)))))
(define (make-leaf symbol weight)
(list 'leaf symbol weight))
(define (leaf? object)
(eq? (car object) 'leaf))
(define (symbol-leaf x) (cadr x))
(define (weight-leaf x) (caddr x))
(define (left-branch tree) (car tree))
(define (right-branch tree) (cadr tree))
(define (make-code-tree left right)
(list left
right
(append (symbols left) (symbols right))
(+ (weight left) (weight right))))
(define (symbols tree)
(if (leaf? tree)
(list (symbol-leaf tree))
(caddr tree)))
(define (weight tree)
(if (leaf? tree)
(weight-leaf tree)
(cadddr tree)))
;動作確認
(define sample-tree
(make-code-tree (make-leaf 'A 4)
(make-code-tree
(make-leaf 'B 2)
(make-code-tree (make-leaf 'D 1)
(make-leaf 'C 1)))))
(define sample-message '(0 1 1 0 0 1 0 1 0 1 1 1 0))
(encode (decode sample-message sample-tree) sample-tree)
2.69
#lang racket
(define (generate-huffman-tree pairs)
(successive-merge (make-leaf-set pairs)))
(define (successive-merge set)
(if (<= (length set) 1)
set
(let ((left (car set))
(right (cadr set)))
(successive-merge
(adjoin-set
(make-code-tree left right)
(cddr set))))))
;既存コード
(define (make-leaf-set pairs)
(if (null? pairs)
'()
(let ((pair (car pairs)))
(adjoin-set
(make-leaf (car pair) (cadr pair))
(make-leaf-set (cdr pairs))))))
(define (adjoin-set x set)
(cond ((null? set) (list x))
((< (weight x) (weight (car set))) (cons x set))
(else (cons (car set)
(adjoin-set x (cdr set))))))
(define (make-leaf symbol weight)
(list 'leaf symbol weight))
(define (make-code-tree left right)
(list left
right
(append (symbols left) (symbols right))
(+ (weight left) (weight right))))
(define (symbols tree)
(if (leaf? tree)
(list (symbol-leaf tree))
(caddr tree)))
(define (weight tree)
(if (leaf? tree)
(weight-leaf tree)
(cadddr tree)))
(define (leaf? object)
(eq? (car object) 'leaf))
(define (symbol-leaf x) (cadr x))
(define (weight-leaf x) (caddr x))
;test
(generate-huffman-tree '((C 1) (D 1) (E 1) (F 1) (G 1) (H 1) (B 3) (A 8)))
2.70
元の曲？は36ワード。 エンコード結果は 84 bit 固定長符号の場合は、8種のワードがあるので1ワードあたり3bit必要。 よって 36*8=108ワード ハフマン符号の方がより少ないビット数で符号化できることがわかる。
2.71
n=5
'((((((leaf a 1)
(leaf b 2)
(a b) 3)
(leaf c 4)
(a b c) 7)
(leaf d 8)
(a b c d) 15)
(leaf e 16)
(a b c d e) 31))
n=10
'(((((((((((leaf a 1)
(leaf b 2)
(a b) 3)
(leaf c 4)
(a b c) 7)
(leaf d 8)
(a b c d) 15)
(leaf e 16)
(a b c d e) 31)
(leaf f 32)
(a b c d e f) 63)
(leaf g 64)
(a b c d e f g) 127)
(leaf h 128)
(a b c d e f g h) 255)
(leaf i 256)
(a b c d e f g h i) 511)
(leaf j 512)
(a b c d e f g h i j) 1023))
一般のnでは、n-1
2.72
2.71のような出現頻度の場合、 最高頻度の記号は O(n) （木の探索1 * シンボルの探索n） 最低頻度の記号は O(n2) （木の探索n * シンボルの探索n)
問題後半の、「アルファベットの最高頻度と最低頻度の符号」の 問題設定がよくわからないが、 2.71の出現頻度（最低:1 最大:225）と仮定できるなら、上の通り 仮に http://www7.plala.or.jp/dvorakjp/hinshutu.htm こういう出現率を考慮しろと言うことだとしたらわからない。。。 （最高：e: 11.40%, 最低：z 0.07%）
Xperia Z5 Compact タッチ不具合
まずは、何も言わず以下の動画を見てくれ。
動画にあるとおり、昨日機種変更したXperia Z5 Compactにタッチパネルの不具合がある。
どうも、以下の不具合にぶつかった模様。
Xperia Z5 Compactのタッチパネル不具合、原因はアース不良による「漏電」？ | スマホ評価・不具合ニュース
リンク先のタイトルにもある漏電を疑い、色々試してみた結果をまとめておく。
発生条件
木製の机の上で、本体を持たずに操作すると、画面の大部分が反応しない。（一部は反応する）
発生しない条件
机の上でも、以下の条件に合えば上記事象は発現しない
充電する
充電中は、机に置いておいても操作可能。
手で持つ
机の上に置いた状態で、本体に手を添えて操作すると操作できる
アルミホイルの上に置く
アルミホイルの上に置くと、手で触らずとも操作できる。
ただし、ある程度の大きさがないとダメ。
あるいは、小さなアルミホイルを置いて、それに手を添えても操作できる。
どれにも共通するのは、本体が何らかの形（充電ケーブル、手、アルミホイル）で接地されていること。
というわけで、漏電？あるいは接地不良で、タッチパネルの静電気をうまく扱えていないのが原因に見える。
暫定対処策
明日にでもドコモショップへ初期不良としてねじ込む予定だが、とりあえずの回避策を考えてみる。
回避策
とにかく、何らかの方法で本体を接地できれば良いようなので、アルミホイルを使って試してみることにした。
最初は、ケースの裏全体にアルミホイルを貼り付けてみたが、うまくゆかず。どうも、ちゃんと接地しきれないらしい。 そこで、アルミホイルの切れ端をスマホとスマホケースで挟み、簡単なアースを作ることにした。
こうすると、机に置いているとき自然にアースと指が触れるので、接地されて操作が可能となる。
ちょっと不格好だが、とりあえずドコモショップに持ち込んでみるまではこれで対処しようと思う。
なお、現在ソフトウェアアップデートをDL中なので、もしかしたらそれで解決して終わり・・・かもしれない。
（どう見てもハードウェア要因なので、余り期待はしていないが）
SICP 演習問題 2.2
2.17
#lang Racket
(define (last-pair items)
(if (null? (cdr items))
(car items)
(last-pair (cdr items))))
2.18
繰り返し
(define (reverse items)
(define (iter items result)
(if (null? items)
result
(iter (cdr items) (cons (car items) result))))
(iter items (list)))
(define (reverse items)
(if (null? items)
(list)
(append (reverse (cdr items)) (list (car items)))))
2.19
#lang racket
(define (cc amount coin-values)
(cond ((= amount 0) 1)
((or (< amount 0) (no-more? coin-values)) 0)
(else (+ (cc amount (except-first-denomination coin-values))
(cc (- amount
(first-denomination coin-values))
coin-values)))))
(define (no-more? coin-values) (null? coin-values))
(define (except-first-denomination coin-values)
(define (iter coin-values result max)
(if (null? coin-values)
result
(let ((tmp (car coin-values)))
(if (> tmp max)
(iter (cdr coin-values) (cons max result) tmp)
(iter (cdr coin-values) (cons tmp result) max)))))
(iter (cdr coin-values) (list) (car coin-values) ))
(define (first-denomination coin-values)
(define (iter coin-values max)
(if (null? coin-values)
max
(let ((tmp (car coin-values)))
(if (> tmp max)
(iter (cdr coin-values) tmp)
(iter (cdr coin-values) max)))))
(iter (cdr coin-values) (car coin-values)))
上記実装では、リスト coin-valuesの順は, ccの答に影響しない。
理由
first-denomination、except-first-denominationが、
リスト順に関係なく、常に最大のコインを対象とするように実装しているため。
2.20
#lang racket
(define (same-parity a . b)
(let ((parity (remainder a 2)))
(define (iter rest result)
(if (null? rest)
result
(if (= (remainder (car rest) 2) parity)
(iter (cdr rest) (cons (car rest) result))
(iter (cdr rest) result))))
(reverse (iter b (list)))))
2.21
#lang Racket
(define nil (list))
(define (square x) (* x x))
(define (square-list1 items)
(if (null? items)
nil
(cons (square (car items)) (square-list1 (cdr items)))))
(define (square-list2 items)
(map (lambda (x) (square x)) items))
2.22
cons は第1引数がリストだと、 carにリスト、cdrに末尾要素への参照が入ってしまうため、 出力が1つのリストにならない。
(cons '(1 2) 3) ; => '((1 2) . 3)
他方、第1引数が非リスト、第2引数がリストの場合は、 carに先頭要素、cdrにリストへの参照が入るため、 1つのリストとして出力される。
(cons 1 '(2 3)) ; => '(1 2 3)
問題のprogramは、consの第1引数 answerがリストになるため、正しく動作しない。
以下のように、cons を append にしたら、正しく動く
(define (square-list4 items)
(define (iter things answer)
(if (null? things)
answer
(iter (cdr things)
(append answer
(list (square (car things)))))))
(iter items nil))
2.23
(define (for-each proc list)
(cond ((null? list) #t)
(else (proc (car list))
(for-each proc (cdr list)))))
2.24
略
2.25
(cdr (car (cdr (car (cdr (cdr '(1 3 '(5 7) 9)))))))
(car(cdr(car'('(7)))))
(cdr (car (cdr (car (cdr (car (cdr
(car (cdr (car (cdr (car (cdr
(car (cdr (car (cdr (car (cdr
(car (cdr
'(1 '(2 '(3 '(4 '(5 '(6 7)))))))))))))))))))))))))))
2,26
(define x (list 1 2 3)) (define y (list 4 5 6)) (append x y) ; => '(1 2 3 4 5 6) (cons x y) ; => '((1 2 3) 4 5 6) (list x y) ; => '((1 2 3) (4 5 6))
2.27
(define (deep-reverse items)
(if (pair? items)
(append
(deep-reverse (cdr items))
(list (deep-reverse (car items))))
items))
2.28
(define nil (list))
(define (fringe lst)
(if (null? lst)
nil
(let ((first (car lst)))
(if (pair? first)
(append (fringe first) (fringe (cdr lst)))
(append (list first) (fringe (cdr lst)))))))
2.29 a-c
#lang Racket
(define (make-mobile left right) (list left right))
(define (make-branch length structure) (list length structure))
; 29a
(define (left-branch m) (car m))
(define (right-branch m) (car (cdr m)))
(define (branch-length b) (car b))
(define (branch-structure b) (car (cdr b)))
; 29b
(define (total-weight m)
(if (pair? m)
(+ (total-weight (branch-structure (left-branch m)))
(total-weight (branch-structure (right-branch m))))
m))
; 29c
(define (balanced? m)
(if (pair? m)
(let ((left-st (branch-structure (left-branch m)))
(left-len (branch-length (left-branch m)))
(right-st (branch-structure (right-branch m)))
(right-len (branch-length (right-branch m))))
(and
(= (* left-len (total-weight left-st))
(* right-len (total-weight right-st)))
(balanced? left-st)
(balanced? right-st)))
#t))
2.29d
アクセッサーを変えればOK（ここが抽象化の壁として機能する）
(define (right-branch m) (cdr m)) (define (branch-structure b) (cdr b))
2.30
#lang racket
(define nil '())
(define (square-tree tree)
(cond ((null? tree) nil)
((not (pair? tree)) (* tree tree))
(else (cons (square-tree (car tree))
(square-tree (cdr tree))))))
(define (square-tree2 tree)
(map (lambda (sub-tree)
(if (pair? sub-tree)
(square-tree2 sub-tree)
(* sub-tree sub-tree)))
tree))
(define (map proc items)
(if (null? items) nil
(cons (proc (car items))
(map proc (cdr items)))))
2.31
#lang racket
(define nil '())
(define (square-tree tree)
(tree-map square tree))
(define (tree-map proc tree)
(cond ((null? tree) nil)
((not (pair? tree)) (proc tree))
(else (cons (tree-map proc (car tree))
(tree-map proc (cdr tree))))))
(define (square x) (* x x))
2.32
(define (subsets s)
(if (null? s)
(list nil)
(let ((rest (subsets (cdr s))))
(append rest
(map
(lambda (x)
(cons (car s) x))
rest))))
2.33
#lang racket
(define nil (list))
(define (accumulate op initial sequence)
(if (null? sequence)
initial
(op (car sequence)
(accumulate op initial (cdr sequence)))))
(define (map p sequence)
(accumulate
(lambda (x y)
(cons (p x) y))
nil
sequence))
(define (append seq1 seq2)
(accumulate cons seq2 seq1))
(define (length sequence)
(accumulate
(lambda (x y) (+ 1 y))
0
sequence))
(define lst (list 1 2 3 4))
(define lst2 (list 5 6 7 8))
(define (square x) (* x x))
(map square lst)
(append lst lst2)
(length lst)
2.34
#lang racket
(define (accumulate op initial sequence)
(if (null? sequence)
initial
(op (car sequence)
(accumulate op initial (cdr sequence)))))
(define (horner-eval x coefficient-sequence)
(accumulate (lambda (this-coeff higher-terms)
(+ (* higher-terms x)
this-coeff))
0
coefficient-sequence))
2.35
#lang racket
(define nil (list))
(define (accumulate op initial sequence)
(if (null? sequence)
initial
(op (car sequence)
(accumulate op initial (cdr sequence)))))
(define (map p sequence)
(accumulate
(lambda (x y)
(cons (p x) y))
nil
sequence))
(define (fringe lst)
(if (null? lst)
nil
(let ((first (car lst)))
(if (pair? first)
(append (fringe first) (fringe (cdr lst)))
(append (list first) (fringe (cdr lst)))))))
(define (count-leaves t)
(accumulate +
0
(map (lambda (x) 1) (fringe t))))
2.36
#lang racket
(define (accumulate-n op init seqs)
(if (null? (car seqs))
nil
(cons (accumulate op init (map car seqs))
(accumulate-n op init (map cdr seqs)))))
(define nil (list))
(define (accumulate op initial sequence)
(if (null? sequence)
initial
(op (car sequence)
(accumulate op initial (cdr sequence)))))
(define (map p sequence)
(accumulate
(lambda (x y)
(cons (p x) y))
nil
sequence))
(define s (list (list 1 2 3) (list 4 5 6) (list 7 8 9) (list 10 11 12)))
(accumulate-n + 0 s)
2.37
#lang Racket
; Σ v_i w_i
(define (dot-product v w)
(accumulate + 0 (map * v w)))
; t_i = Σ m_ij v_j
(define (matrix-*-vector m v)
(map (lambda (m_i) (dot-product m_i v)) m ))
(define (transpose mat)
(accumulate-n cons nil mat))
;p_ij = Σ m_ik n_kj
(define (matrix-*-matrix m n)
(let ((cols (transpose n)))
(map
(lambda (m_i)
(map
(lambda (n_j) (dot-product m_i n_j))
cols))
m)))
(define nil (list))
(define (accumulate op initial sequence)
(if (null? sequence)
initial
(op (car sequence)
(accumulate op initial (cdr sequence)))))
(define (accumulate-n op init seqs)
(if (null? (car seqs))
nil
(cons (accumulate op init (map car seqs))
(accumulate-n op init (map cdr seqs)))))
(define (map p sequence)
(accumulate
(lambda (x y)
(cons (p x) y))
nil
sequence))
2.38
(fold-right / 1 (list 1 2 3)) ;-> 3/2 (fold-left / 1 (list 1 2 3)) ;-> 1/6 (fold-right list nil (list 1 2 3)) ;-> '(1 (2 (3 ()))) (fold-left list nil (list 1 2 3)) ;-> '(((() 1) 2) 3)
等価となる条件は
(op a b) と (op b a) の結果が等しいこと（交換法則）
2.39
(define (reverse-right sequence)
(fold-right
(lambda (x y) (append y (list x) ))
nil
sequence))
(define (reverse-left sequence)
(fold-left
(lambda (x y) (cons y x ))
nil
sequence))
2.40
#lang racket
(require math/number-theory)
(define (uniq-pair n)
(filter prime-sum?
(flatmap
(lambda (i)
(map (lambda (j) (list i j))
(enumerate-interval 1 (- i 1))))
(enumerate-interval 1 n))))
(define (prime-sum-pairs n)
(map make-pair-sum (uniq-pair n)))
(define (flatmap proc seq)
(accumulate append nil (map proc seq)))
(define (prime-sum? pair)
(prime? (+ (car pair) (cadr pair))))
(define (make-pair-sum pair)
(list (car pair) (cadr pair) (+ (car pair) (cadr pair))))
;accumulate
(define nil (list))
(define (accumulate op initial sequence)
(if (null? sequence)
initial
(op (car sequence)
(accumulate op initial (cdr sequence)))))
;map
(define (map p sequence)
(accumulate
(lambda (x y) (cons (p x) y)) nil sequence))
(define (enumerate-interval low high)
(if (> low high)
nil
(cons low (enumerate-interval (+ low 1) high))))
2.41
#lang racket
(require math/number-theory)
; 0<i<j<k=<n
; i+j+k=s
(define (uniq-triple n)
(flatmap
(lambda (i)
(flatmap
(lambda (j)
(map
(lambda (k) (list i j k))
(enumerate-interval 1 (- j 1))))
(enumerate-interval 1 (- i 1))))
(enumerate-interval 1 n)))
(define (sum-triple seq)
(+ (car seq) (cadr seq) (caddr seq)))
(define (find-s-triple n s)
(define (s-sum? seq)
(if (= s (sum-triple seq)) #t #f))
(filter s-sum? (uniq-triple n)))
(define (flatmap proc seq)
(accumulate append nil (map proc seq)))
;accumulate
(define nil (list))
(define (accumulate op initial sequence)
(if (null? sequence)
initial
(op (car sequence)
(accumulate op initial (cdr sequence)))))
;map
(define (map p sequence)
(accumulate
(lambda (x y) (cons (p x) y)) nil sequence))
(define (enumerate-interval low high)
(if (> low high)
nil
(cons low (enumerate-interval (+ low 1) high))))
(uniq-triple 10)
(find-s-triple 10 10)
2.42
#lang racket
(define (queens board-size)
(define (queen-cols k)
(if (= k 0)
(list empty-board)
(filter
(lambda (positions) (safe? k positions))
(flatmap
(lambda (rest-of-queens)
(map
(lambda (new-row)
(adjoin-position new-row k rest-of-queens))
(enumerate-interval 1 board-size)))
(queen-cols (- k 1))))))
(queen-cols board-size))
;queenの置き方
;queenの置かれた座標のリストとして定義.
;第1要素は今おいたクイーンとする
;((k col_k) (k-1 col_k-1) ... (1 col_1))
(define empty-board '())
(define (adjoin-position new-row k rest-of-queens)
(cons (cons k new-row) rest-of-queens))
;safe
;考慮すべき条件は以下の2パターン
;同じcolに存在 (col_k = col_i)
;斜めに存在 (col_k=col_i+(k-i) or col_k=col_i-(k-i) )
(define (safe? k positions)
(let ((k-queen (car positions)))
(define (iter rest-pos)
(if (null? rest-pos)
#t
(let ((i-queen (car rest-pos)))
(if (or (= (cdr k-queen) (cdr i-queen))
(= (cdr k-queen)
(+ (cdr i-queen) (- (car k-queen) (car i-queen))))
(= (cdr k-queen)
(- (cdr i-queen) (- (car k-queen) (car i-queen)))))
#f
(iter (cdr rest-pos))))))
(iter (cdr positions))))
(define (flatmap proc seq)
(accumulate append nil (map proc seq)))
(define nil (list))
(define (accumulate op initial sequence)
(if (null? sequence)
initial
(op (car sequence)
(accumulate op initial (cdr sequence)))))
(define (map p sequence)
(accumulate (lambda (x y) (cons (p x) y)) nil sequence))
(define (enumerate-interval low high)
(if (> low high)
nil
(cons low (enumerate-interval (+ low 1) high))))
2.43
2.42のflatmap
(flatmap
(lambda (rest-of-queens)
(map (lambda (new-row)
(adjoin-position new-row k rest-of-queens))
(enumerate-interval 1 board-size)))
(queen-cols (- k 1))))))
Louisのflatmap
(flatmap
(lambda (new-row)
(map (lambda (rest-of-queens)
(adjoin-position new-row k rest-of-queens))
(queen-cols (- k 1))))
(enumerate-interval 1 board-size))
2.42 は kが増える都度、(queen-cols (- k 1) のフィルタされた結果に対して適用するのに対して、 Louisは 毎回すべてのアイテムに対して適用を行うため、効率が悪い。
毎回board-size回の適用が必要になるため、結果 board-sizeboard-size 回の不要な演算が必要になる。
2.42の演算回数を T(board-size)とすると、Loiusの場合はT(board-sizeboard-size)となる。
2.44
(define (up-split painter n)
(if (= n 0)
painter
(let ((smaller (up-split painter (- n 1))))
(below painter (beside smaller smaller)))))
2.45
#lang racket
(require sicp-pict)
;new definition
(define (split first-ope second-ope)
(define (iter painter n)
(if (= n 0)
painter
(let ((smaller (iter painter (- n 1))))
(first-ope painter (second-ope smaller smaller)))))
iter)
(define right-split2 (split beside below))
(define up-split2 (split below beside))
;old definition
(define (right-split painter n)
(if (= n 0)
painter
(let ((smaller (right-split painter (- n 1))))
(beside painter (below smaller smaller)))))
(define (up-split painter n)
(if (= n 0)
painter
(let ((smaller (up-split painter (- n 1))))
(below painter (beside smaller smaller)))))
;test
(paint (right-split einstein 3))
(paint (right-split2 einstein 3))
(paint (up-split einstein 3))
(paint (up-split2 einstein 3))
2.46
(define (make-vect2 xcor ycor) (cons xcor ycor))
(define (xcor-vect vect) (car vect))
(define (ycor-vect vect) (cdr vect))
(define (add-vect v1 v2)
(make-vect2 (+ (xcor-vect v1) (xcor-vect v2))
(+ (ycor-vect v1) (ycor-vect v2))))
(define (sub-vect v1 v2)
(make-vect2 (- (xcor-vect v1) (xcor-vect v2))
(- (ycor-vect v1) (ycor-vect v2))))
(define (scale-vect scala vect)
(make-vect2 (* scala (xcor-vect vect))
(* scala (ycor-vect vect))))
2.47
;1つめ (define (make-frame1 origin edge1 edge2) (list origin edge1 edge2)) (define (origin-frame1 frame) (car frame)) (define (edge1-frame1 frame) (cadr frame)) (define (edge2-frame1 frame) (caddr frame)) ;2つめ (define (make-frame2 origin edge1 edge2) (cons origin (cons edge1 edge2))) (define (origin-frame2 frame) (car frame)) (define (edge1-frame2 frame) (cadr frame)) (define (edge2-frame2 frame) (cddr frame))
2.48
;segment (define (make-segment2 start end) (cons start end)) (define (segment-start2 segment) (car segment)) (define (segment-end2 segment) (cdr segment))
2.49
#lang Racket
(require sicp-pict)
;a
(define (frame->painter frame)
(let ((origin (frame-origin frame))
(edge1 (frame-edge1 frame))
(edge2 (frame-edge2 frame))
(end (vector-sub (vector-add (frame-edge1 frame) (frame-edge2 frame))
(frame-origin frame))))
(segments->painter
(list
(make-segment origin edge1)
(make-segment origin edge2)
(make-segment edge1 end)
(make-segment edge2 end)))))
;b
(define (x-frame->painter frame)
(let ((origin (frame-origin frame))
(edge1 (frame-edge1 frame))
(edge2 (frame-edge2 frame))
(end (vector-sub (vector-add (frame-edge1 frame) (frame-edge2 frame))
(frame-origin frame))))
(segments->painter
(list
(make-segment origin end)
(make-segment edge1 edge2)))))
;c
;frameの頂点ではなく菱型の各頂点を規定する
(define (mid-frame->painter frame)
(let ((org-edge1
(vector-scale 0.5
(vector-add (frame-origin frame)
(frame-edge1 frame))))
(org-edge2
(vector-scale 0.5
(vector-add (frame-origin frame)
(frame-edge2 frame))))
(end-edge1
(vector-scale 0.5
(vector-add (vector-sub
(vector-add (frame-edge1 frame) (frame-edge2 frame))
(frame-origin frame))
(frame-edge1 frame))))
(end-edge2
(vector-scale 0.5
(vector-add (vector-sub
(vector-add (frame-edge1 frame) (frame-edge2 frame))
(frame-origin frame))
(frame-edge2 frame)))))
(segments->painter
(list
(make-segment org-edge1 org-edge2)
(make-segment org-edge1 end-edge1)
(make-segment org-edge2 end-edge2)
(make-segment end-edge1 end-edge2)))))
;wave
(define (points->segments points)
(if (null? (cdr points))
'()
(let ((p1 (car points))
(p2 (cadr points))))
(cons (make-segment (make-vect (car p1) (cadr p1))
(make-vect (car p2) (cadr p2)))
(points->segments (cdr points))))))
(define wave
(let ((wp1 '((0.25 0)
(0.34 0.4)
(0.35 0.58)
(0.16 0.5)
(0 0.68)))
(wp2 '((0 0.78)
(0.16 0.61)
(0.30 0.7)
(0.42 0.69)
(0.35 0.82)
(0.42 1)))
(wp3 '((0.58 1)
(0.65 0.82)
(0.58 0.69)
(0.70 0.7)
(0.84 0.61)
(1.0 0.32)))
(wp4 '((0.75 0)
(0.66 0.4)
(0.65 0.58)
(0.80 0.5)
(1.0 0.22)))
(wp5 '((0.37 0)
(0.5 0.35)
(0.63 0))))
(segments->painter (append-map points->segments
(list wp1 wp2 wp3 wp4 wp5)))))
2.50
#lang Racket
(require sicp-pict)
(define (flip-horiz2 painter)
((transform-painter
(make-vect 1.0 0.0)
(make-vect 0.0 0.0)
(make-vect 1.0 1.0))
painter))
(define (rotate1802 painter)
((transform-painter
(make-vect 1.0 1.0)
(make-vect 0.0 1.0)
(make-vect 1.0 0.0))
painter))
(define (rotate2702 painter)
(rotate180 (rotate90 painter)))
本文のtransform-painterとsicp-pictのtransfrom-painterは定義が異なる。 上記は、sicp-pict似合わせた実装。
2.51
(define (below2 painter1 painter2)
(let ((split-point (make-vect 0.0 0.5)))
(let ((paint-bottom
((transform-painter
(make-vect 0.0 0.0)
(make-vect 1.0 0.0)
split-point)
painter1))
(paint-up
((transform-painter
split-point
(make-vect 1.0 0.5)
(make-vect 0.0 1.0))
painter2)))
(lambda (frame)
(paint-bottom frame)
(paint-up frame)))))
(define (below3 painter1 painter2)
(rotate270
(beside
(rotate90 painter2)
(rotate90 painter1))))
2.52
a
#lang racket
(require sicp-pict)
(define (points->segments points)
(if (null? (cdr points))
'()
(let ((p1 (car points))
(p2 (car (cdr points))))
(cons (make-segment (make-vect (car p1) (car (cdr p1)))
(make-vect (car p2) (car (cdr p2))))
(points->segments (cdr points))))))
(define wave
(let ((wp1 '((0.25 0)
(0.34 0.4)
(0.35 0.58)
(0.16 0.5)
(0 0.68)))
(wp2 '((0 0.78)
(0.16 0.61)
(0.30 0.7)
(0.42 0.69)
(0.35 0.82)
(0.42 1)))
(wp3 '((0.58 1)
(0.65 0.82)
(0.58 0.69)
(0.70 0.7)
(0.84 0.61)
(1.0 0.32)))
(wp4 '((0.75 0)
(0.66 0.4)
(0.65 0.58)
(0.80 0.5)
(1.0 0.22)))
(wp5 '((0.37 0)
(0.5 0.35)
(0.63 0))))
(segments->painter (append-map points->segments
(list wp1 wp2 wp3 wp4 wp5)))))
(define left
(let ((eye '((0.40 0.84)
(0.43 0.88)
(0.47 0.84)))
(mouth '((0.46 0.74)
(0.5 0.70))))
(segments->painter (append-map points->segments
(list eye mouth)))))
(define right (flip-horiz left))
(define (smiled-wave frame)
(left frame)
(right frame)
(wave frame))
;test
(paint smiled-wave)
b
和田先生訳がよくわからなかったので以下のように解釈。
b.Change the pattern constructed by corner-split (for example, by using only one copy of the up-split and right-split images instead of two).
corner-splitが描くパターンを変更せよ。 例）up-splitとright-splitが描くイメージを2つずつではなく1つずつだけ使用する）
#lang racket
(require sicp-pict)
(define (corner-split2 painter n)
(if (= n 0)
painter
(let ((up (up-split painter (- n 1)))
(right (right-split painter (- n 1))))
(let ((corner (corner-split2 painter (- n 1))))
(beside (below painter up)
(below right corner))))))
;helper
(define (right-split painter n)
(if (= n 0)
painter
(let ((smaller (right-split painter (- n 1))))
(beside painter (below smaller smaller)))))
(define (up-split painter n)
(if (= n 0)
painter
(let ((smaller (up-split painter (- n 1))))
(below painter (beside smaller smaller)))))
;wave
(define (points->segments points)
(if (null? (cdr points))
'()
(let ((p1 (car points))
(p2 (car (cdr points))))
(cons (make-segment (make-vect (car p1) (car (cdr p1)))
(make-vect (car p2) (car (cdr p2))))
(points->segments (cdr points))))))
(define wave
(let ((wp1 '((0.25 0)
(0.34 0.4)
(0.35 0.58)
(0.16 0.5)
(0 0.68)))
(wp2 '((0 0.78)
(0.16 0.61)
(0.30 0.7)
(0.42 0.69)
(0.35 0.82)
(0.42 1)))
(wp3 '((0.58 1)
(0.65 0.82)
(0.58 0.69)
(0.70 0.7)
(0.84 0.61)
(1.0 0.32)))
(wp4 '((0.75 0)
(0.66 0.4)
(0.65 0.58)
(0.80 0.5)
(1.0 0.22)))
(wp5 '((0.37 0)
(0.5 0.35)
(0.63 0))))
(segments->painter (append-map points->segments
(list wp1 wp2 wp3 wp4 wp5)))))
(define left
(let ((eye '((0.40 0.84)
(0.43 0.88)
(0.47 0.84)))
(mouth '((0.46 0.74)
(0.5 0.70))))
(segments->painter (append-map points->segments
(list eye mouth)))))
(define right (flip-horiz left))
(define (smiled-wave frame)
(left frame)
(right frame)
(wave frame))
;test
(paint (corner-split2 smiled-wave 2))
c
c.Modify the version of square-limit that uses square-of-four so as to assemble the corners in a different pattern. (For example, you might make the big Mr. Rogers look outward from each corner of the square.)
square-limit （square-of-four使う版）が違う絵を描くように変更しろ。 （例： 一番大きいMrRogerの絵が四角の四隅に配置されるようにする）
#lang racket
(require sicp-pict)
(define (square-limit2 painter n)
(let ((combine4 (square-of-four flip-vert rotate180
identity flip-horiz)))
(combine4 (corner-split2 painter n))))
;helper
(define (square-of-four tl tr bl br)
(lambda (painter)
(let ((top (beside (tl painter) (tr painter)))
(bottom (beside (bl painter) (br painter))))
(below bottom top))))
(define (corner-split2 painter n)
(if (= n 0)
painter
(let ((up (up-split painter (- n 1)))
(right (right-split painter (- n 1))))
(let ((corner (corner-split2 painter (- n 1))))
(beside (below painter up)
(below right corner))))))
(define (right-split painter n)
(if (= n 0)
painter
(let ((smaller (right-split painter (- n 1))))
(beside painter (below smaller smaller)))))
(define (up-split painter n)
(if (= n 0)
painter
(let ((smaller (up-split painter (- n 1))))
(below painter (beside smaller smaller)))))
;wave
(define (points->segments points)
(if (null? (cdr points))
'()
(let ((p1 (car points))
(p2 (car (cdr points))))
(cons (make-segment (make-vect (car p1) (car (cdr p1)))
(make-vect (car p2) (car (cdr p2))))
(points->segments (cdr points))))))
(define wave
(let ((wp1 '((0.25 0)
(0.34 0.4)
(0.35 0.58)
(0.16 0.5)
(0 0.68)))
(wp2 '((0 0.78)
(0.16 0.61)
(0.30 0.7)
(0.42 0.69)
(0.35 0.82)
(0.42 1)))
(wp3 '((0.58 1)
(0.65 0.82)
(0.58 0.69)
(0.70 0.7)
(0.84 0.61)
(1.0 0.32)))
(wp4 '((0.75 0)
(0.66 0.4)
(0.65 0.58)
(0.80 0.5)
(1.0 0.22)))
(wp5 '((0.37 0)
(0.5 0.35)
(0.63 0))))
(segments->painter (append-map points->segments
(list wp1 wp2 wp3 wp4 wp5)))))
(define left
(let ((eye '((0.40 0.84)
(0.43 0.88)
(0.47 0.84)))
(mouth '((0.46 0.74)
(0.5 0.70))))
(segments->painter (append-map points->segments
(list eye mouth)))))
(define right (flip-horiz left))
(define (smiled-wave frame)
(left frame)
(right frame)
(wave frame))
;test
(paint (square-limit2 smiled-wave 2))
SICP 演習問題 2.1
2.1
#lang racket
(define (make-rat n d)
(let ((g (gcd n d)))
(cond ((< (* n d) 0)
(cons
(* -1 (abs (/ n g)))
(abs (/ d g))))
(else
(cons (abs(/ n g)) (abs(/ d g)))))))
(define (add-rat x y)
(make-rat (+ (* (numer x) (denom y))
(* (numer y) (denom x)))
(* (denom x) (denom y))))
(define (sub-rat x y)
(make-rat (- (* (numer x) (denom y))
(* (numer y) (denom x)))
(* (denom x) (denom y))))
(define (mul-rat x y)
(make-rat (* (numer x) (numer y))
(* (denom x) (denom y))))
(define (div-rat x y)
(make-rat (* (numer x) (denom y))
(* (denom x) (numer y))))
(define (equal-rat? x y)
(= (* (numer x)(denom y))
(* (numer y)(denom x))))
(define (numer x) (car x))
(define (denom x) (cdr x))
(define (print-rat x)
(newline)
(display (numer x))
(display "/")
(display (denom x)))
2.2
#lang Racket
;点の定義
(define (make-point x y) (cons x y))
(define (x-point p) (car p))
(define (y-point p) (cdr p))
;線分の定義
(define (make-segment start end) (cons start end))
(define (start-segment seg) (car seg))
(define (end-segment seg) (cdr seg))
(define (midpoint-segment seg)
(let ((start (start-segment seg))
(end (end-segment seg)))
(make-point
(/ (+ (x-point start) (x-point end)) 2)
(/ (+ (y-point start) (y-point end)) 2))))
(define (print-point p)
(newline)
(display "(")
(display (x-point p))
(display ",")
(display (y-point p))
(display ")"))
2.3
実装1
（長辺と短辺を1つずつ指定。各辺は斜めでもOK。指定する2辺が長方形を構成可能かどうかの判断は省略）
#lang Racket
;周長
(define (perimeter-rectangle rec)
(* (+ (long-rectangle-length rec)
(short-rectangle-length rec))
2))
;面積
(define (area-rectangle rec)
(* (long-rectangle-length rec)
(short-rectangle-length rec)))
;辺の長さ
(define (length-segment seg)
(let ((start (start-segment seg))
(end (end-segment seg)))
(sqrt
(+ (square (- (x-point end) (x-point start)))
(square (- (y-point end) (y-point start)))))))
;長方形の定義: (cons 長辺 短辺)
(define (make-rectangle long short) (cons long short))
;長編の長さ
(define (long-rectangle-length rec) (length-segment (car rec)))
;短辺の長さ
(define (short-rectangle-length rec) (length-segment (cdr rec)))
(define (make-point x y) (cons x y))
(define (x-point p) (car p))
(define (y-point p) (cdr p))
(define (make-segment start end) (cons start end))
(define (start-segment seg) (car seg))
(define (end-segment seg) (cdr seg))
(define (square x) (* x x))
実装2 （4点を指定。効率は悪い。ホントは3点でも一意に定まるが、、、）
#lang racket
;長方形の定義 (cons 左上 右上 左下 右下)
(define (make-rectangle top-left top-right bottom-left bottom-right)
(cons (cons top-left top-right)
(cons bottom-left bottom-right)))
;短辺の長さ（ここに抽象化の壁がある）
(define (short-rectangle-length rec)
(let ((vertical
(length-segment
(make-segment (car (car rec)) (car (cdr rec)))))
(horizontal
(length-segment
(make-segment (car (car rec)) (cdr (car rec))))))
(if (< vertical horizontal) vertical horizontal)))
;長辺の長さ（ここに抽象化の壁がある）
(define (long-rectangle-length rec)
(let ((vertical
(length-segment
(make-segment (car (car rec)) (car (cdr rec)))))
(horizontal
(length-segment
(make-segment (car (car rec)) (cdr (car rec))))))
(if (> vertical horizontal) vertical horizontal)))
;面積と周長の関数定義はそのまま
(define (perimeter-rectangle rec)
(* (+ (long-rectangle-length rec)
(short-rectangle-length rec))
2))
(define (area-rectangle rec)
(* (long-rectangle-length rec)
(short-rectangle-length rec)))
(define (make-point x y) (cons x y))
(define (x-point p) (car p))
(define (y-point p) (cdr p))
(define (make-segment start end) (cons start end))
(define (start-segment seg) (car seg))
(define (end-segment seg) (cdr seg))
(define (length-segment seg)
(let ((start (start-segment seg))
(end (end-segment seg)))
(sqrt
(+ (square (- (x-point end) (x-point start)))
(square (- (y-point end) (y-point start)))))))
(define (square x) (* x x))
2.4
cdrの定義
#lang Racket (define (cdr z) (z (lambda (p q) q))) (define (cons x y) (lambda (m) (m x y))) (define (car z) (z (lambda (p q) p)))
(car (cons x y))がxを生じることを証明
(car (cons x y)) ;carを展開 ;->((cons x y) (lambda (p q) p)) ;consを展開 ;->((lambda (m) (m x y)) (lambda (p q) p)) ;mに(lambda (p q) p)を束縛 ;->((lambda (p q) p) x y) ; p, q に x, y を束縛 ;-> x
2.5
非負の整数の対は数と算術演算だけを使って表現出来ることを示せ
(a b) -> 2^a*3^b なので、 与えられた非負整数nが 奇数の場合: 2^0*3^bなので、1になるまで3で除算し、除算回数をbとする（b->log3(n)) 偶数の場合: 2^a*3^bなので、奇数mが得られるまで2で除算し、除算回数をaとする。 奇数mは2^0*3^bとなるので、bはnが奇数の場合と同じ求め方で得る(b->log3(m))
これに対応する手続き cons, carおよびcdrの定義
#lang Racket
;cons
(define (cons x y)
(* (base 2 x) (base 3 y)))
;car
(define (car z)
(count-n z 2))
;cdr
(define (cdr z)
(count-n z 3))
(define (base x n)
(if (= n 0) 1
(* x (base x (- n 1)))))
(define (count-n x divider)
(define (iter x divider n)
(if (= (remainder x divider) 0)
(iter (/ x divider) divider (+ n 1))
n))
(iter x divider 0))
2.6
oneの定義
;one (add-1 zero) (lambda (f) (lambda (x) (f ((zero f) x)))) (lambda (f) (lambda (x) (f (lambda (f) (lambda (x) x) f) x))) (lambda (f) (lambda (x) (f (lambda (x) x) x))) (lambda (f) (lambda (x) (f x)))
twoの定義
;two (add-1 one) (lambda (f) (lambda (x) (f ((one f) x)))) (lambda (f) (lambda (x) (f ((lambda (f) (lamda (x) (f x))) f) x))) (lambda (f) (lambda (x) (f (lambda (x) (f x)) x))) (lambda (f) (lambda (x) (f (f x))))
加算手続きの定義
(define (add a b) (lambda (f) (lambda (x) ((a f) ((b f) x)))))
;(add one two) (lambda (f) (lambda (x) ((one f) ((two f) x)))) (lambda (f) (lambda (x) (((lambda (f) (lambda(x) (f x))) f) (((lambda (f) (lambda(x) (f (f x)))) f) x)))) (lambda (f) (lambda (x) ((lambda (x) (f x)) (lambda (x) (f (f x)) x)))) (lambda (f) (lambda (x) ((lambda (x) (f x)) (f (f x))))) (lambda (f) (lambda (x) (f (f (f x))))) ; =>three
2.7
#lang Racket (define (make-interval a b) (cons a b)) (define (upper-bound interval) (max (car interval) (cdr interval))) (define (lower-bound interval) (min (car interval) (cdr interval)))
2.8
(define (sub-interval x y)
(make-interval
(- (lower-bound x) (upper-bound y))
(- (upper-bound x) (lower-bound y))))
2.9
区間Xの幅
X_width = X_max - X_min
和の幅
(X_max + Y_max) - (X_min + Y_min) = (X_max - X_min) + (Y_max - Y_min) = X_width + Y_width
差の幅
(X_max - Y_min) - (X_min - Y_max) = (X_max - X_min) + (Y_max - Y_min) = X_width + Y_width
積の幅
max(X_maxY_min X_maxY_max X_minY_min X_minY_max) - min(X_maxY_min X_maxY_max X_minY_min X_minY_max) よって、以下の16パターンだが、いずれもwidthのみの関数にはならない X_max(Ymin - Y_max) X_max(Ymax - Y_min) X_min(Ymin - Y_max) ... Y_min(Xmax - X_min) X_maxY_max-X_minY_min X_minY_min-X_maxY_max
商の幅も席の幅と同様、widthだけの関数にならない。
max(X_max/Y_min X_max/Y_max X_min/Y_min X_min/Y_max) - min(X_max/Y_min X_max/Y_max X_min/Y_min X_min/Y_max)
2.10
0をまたがる区間で割ると、正負それぞれの0近傍で+∞,-∞に発散してしまう。 また、0では解無しとなる。
エラーを返すコード
(define (div-interval x y)
(if (> 0 (* (lower-bound y) (upper-bound y)))
(print "error")
(mul-interval
x
(make-interval
(/ 1.0 (upper-bound y))
(/ 1.0 (lower-bound y))))))
2.11
区間 [min,max] の符号のパターンは、 [正,正],[負,正],[負,負]となる。 よって、x,yを考慮すると3*3=9通りになる。
それぞれのパターンにおける、min,maxは具体例を交えると以下のようになる。 （ [負,正]の場合はminとmaxの絶対値の大小関係により場合分けして考える）
[正,正] * [正,正] [1,2] * [2,4] min: x_min * y_min >0 max: x_max * y_max > max(x_min*y_max, x_max*y_min) > x_min*y_min (max<0) [正,正] * [負,正] [1,2] * [-2,4] [1,2] * [-4,2] 何方のパターンも同じ min: x_max * y_min < x_min*y_min < 0 max: x_max * y_max > x_min*y_max > 0 [正,正] * [負,負] [1,2] * [-4, -2] min: x_max * y_min < min(x_min*y_min,x_max*y_min) < 0 max: x_min * y_max > max(x_min*y_min,x_max*y_min) (max<0) [負,正] * [正,正] [-1,2] * [2,4] [-2,1] * [2,4] 何方のパターンも同じ min: x_min * y_max < x_min*y_min < 0 max: x_max * y_max > x_max*y_min > 0 [負,正] * [負,正] [-1,2] * [-2,4] [-2,1] * [-4,2] パターンごとに大小が変化する min: min(x_min * y_max, x_max * y_min) <0 max: max(x_max * y_max, x_min * y_min) >0 [負,正] * [負,負] [-1,2] * [-4,-2] [-2,1] * [-4,-2] 何方のパターンも同じ min: x_max * y_min < x_max*y_max < 0 max: x_min * y_min > x_min*y_max > 0 [負,負] * [正,正] [-2,-1] * [2,4] min: x_min * y_max < x_min*y_min < x_max*y_max max: x_max * y_min > x_max*y_max (max<0) [負,負] * [負,正] [-2,-1] * [-2,4] [-2,-1] * [-4,2] 何方のパターンも同じ min: x_min * y_max < x_max*y_max < 0 max: x_min * y_min > x_max*y_min > 0 [負,負] * [負,負] [-2,-1] * [-4,-2] min: x_max * y_max < min(x_min*y_max, x_max*y_min) (0<min) max: x_min * y_min > max(x_min*y_max, x_max*y_min)
よって、 [負,正] * [負,正]のパターン以外は、 最大、最小の組み合わせが一意に定まるので 乗算回数は2回で良い。
これを実装する
#lang racket
(define (make-interval a b) (cons a b))
(define (upper-bound interval) (max (car interval) (cdr interval)))
(define (lower-bound interval) (min (car interval) (cdr interval)))
(define (mul-interval2 x y)
(let ((xl (lower-bound x))
(xu (upper-bound x))
(yl (lower-bound y))
(yu (upper-bound y)))
(cond
((and (< 0 (* xl xu)) (< 0 (* yl yu)))
(cond
((and (< 0 xl) (< 0 yl))
;[正,正]*[正,正]
(make-interval (* xl yl) (* xu yu)))
((and (< xl 0) (< yl 0))
;[負,負]*[負,負]
(make-interval (* xu yu) (* xl yl)))
((and (< xl 0) (< 0 yl))
;[負,負]*[正,正]
(make-interval (* xl yu) (* xu yl))))
((and (< 0 xl) (< yl 0))
;[正,正]*[負,負]
(make-interval (* xu yl) (* xl yu))))
((< (* xl xu yl yu) 0)
(if (< 0 (* xl xu))
(if (< 0 xl)
;[正,正] * [負,正]
(make-interval (* xu yl) (* xu yu))
;[負,負] * [負,正]
(make-interval (* xl yu) (* xl yl)))
(if (< 0 yl)
;[負,正] * [正,正]
(make-interval (* xl yu) (* xu yu))
;[負,正] * [負,負]
(make-interval (* xu yl) (* xl yl)))))
(else
;[負,正] * [負,正]
(make-interval
(min (* xl yu) (* xu yl))
(max (* xu yu) (* xl yl)))))))
動作確認
;test methods
(define (old-mul-interval x y)
(let ((p1 (* (lower-bound x) (lower-bound y)))
(p2 (* (lower-bound x) (upper-bound y)))
(p3 (* (upper-bound x) (lower-bound y)))
(p4 (* (upper-bound x) (upper-bound y))))
(make-interval (min p1 p2 p3 p4)
(max p1 p2 p3 p4))))
(define (eql-interval? x y)
(and (= (lower-bound x) (lower-bound y))
(= (upper-bound x) (upper-bound y))))
(define (mul-test xl xu yl yu)
(let ((x (make-interval xl xu))
(y (make-interval yl yu)))
(if
(eql-interval?
(old-mul-interval x y)
(mul-interval2 x y))
true
(error "failed"
x
y
(old-mul-interval x y)
(mul-interval2 x y)))))
;test code
(mul-test 2 3 4 5)
(mul-test 2 3 -4 5)
(mul-test 2 3 4 -5)
(mul-test 2 3 -4 -5)
(mul-test 2 3 0 5)
(mul-test 2 3 -4 0)
(mul-test -2 3 4 5)
(mul-test -2 3 -4 5)
(mul-test -2 3 4 -5)
(mul-test -2 3 -4 -5)
(mul-test -2 3 0 5)
(mul-test -2 3 -4 0)
(mul-test 2 -3 4 5)
(mul-test 2 -3 -4 5)
(mul-test 2 -3 4 -5)
(mul-test 2 -3 -4 -5)
(mul-test 2 -3 0 5)
(mul-test 2 -3 -4 0)
(mul-test -2 -3 4 5)
(mul-test -2 -3 -4 5)
(mul-test -2 -3 4 -5)
(mul-test -2 -3 -4 -5)
(mul-test -2 -3 0 5)
(mul-test -2 -3 -4 0)
(mul-test -2 0 4 5)
(mul-test -2 0 -4 5)
(mul-test -2 0 4 -5)
(mul-test -2 0 -4 -5)
(mul-test -2 0 0 5)
(mul-test -2 0 -4 0)
(mul-test 0 3 4 5)
(mul-test 0 3 -4 5)
(mul-test 0 3 4 -5)
(mul-test 0 3 -4 -5)
(mul-test 0 3 0 5)
(mul-test 0 3 -4 0)
2.12
#lang racket
(define (make-interval a b) (cons a b))
(define (upper-bound interval) (max (car interval) (cdr interval)))
(define (lower-bound interval) (min (car interval) (cdr interval)))
(define (make-center-width c w)
(make-interval (- c w) (+ c w)))
(define (center i)
(/ (+ (lower-bound i) (upper-bound i)) 2.0))
(define (width i)
(/ (- (upper-bound i) (lower-bound i)) 2.0))
(define (make-center-percent c p)
(let ((w (* c (/ p 100))))
(make-interval (- c w) (+ c w))))
(define (percent i)
(* (/ (width i) (center i)) 100))
;test
(define i (make-interval 900 1100))
(center i)
(width i)
(percent i)
(define i2 (make-center-percent 1000 10))
(lower-bound i)
(upper-bound i)
(center i)
(width i)
(percent i)
2.13
Ci,Wi をインターバルi の 中央値(center)、許容誤差(width)と仮定
この時、x,yは以下のように示せる
x = [x_min, x_max] x_min = Cx*(1-0.5*Wx) x_max = Cx*(1-0.5*Wx) y = [y_min, y_max] y_min = Cy*(1-0.5*Wy) y_max = Cy*(1-0.5*Wy)
すべての数が正の場合、 xy = [x_miny_min, x_maxy_max] = [CxCy(1-0.5(Wx+Wy)+WxWy), CxCy*(1+0.5(Wx+Wy)-WxWy)]
相対許容誤差が小さいと仮定できる場合、 WxWyは無視できる。
よって xy≒ [CxCy(1-0.5(Wx+Wy)), CxCy(1+0.5(Wx+Wy))] となり、 xyの許容誤差は (Wx+Wy) となる。
2.14
(define A (make-interval 89999 90001))
(define B (make-interval 100 900))
(define (test x y)
(let ((ans (div-interval x y)))
(center ans)
(percent ans)))
(display "C_a ")
(center A)
(display "P_a ")
(percent A)
(display "C_b ")
(center B)
(display "P_b ")
(percent B)
(newline)
(display "A/A ")
(test A A)
(display "A/B ")
(test A B)
(display "B/B ")
(test B B)
(display "B/A ")
(test B A)
実行結果
C_a 90000.0 P_a 0.0011111111111111111 C_b 500.0 P_b 80.0 A/A 0.002222222221954537 A/B 80.00039999644447 B/B 97.56097560975611 B/A 80.0003999964445
A/A, B/B は本来１となるべきなのに、 相対誤差が増大している。
これは本プログラムが、A,Bを一つの値ではなく 「区間の中のいずれかの値」と規定しているが、 その「いずれかの値」を固定できないからである。
※以下、「固定」という言い方が正しいか自信無いので具体例...
本来は、同じ区間A[1,3],B[1,3]があった場合、 式中のAとBはそれぞれ1<a<3, 1<b<3を満たす任意の数値a,bになる。 (a, bの間に相関はないが、式中のa,bはそれぞれ一意の値となる） そのため、A/A=B/B=1かつA/B≠1 となるべきだが、本プログラムでは、 A/A,B/B共に1にならない。
これが、計算式によって答えに差分が生じる原因である。
2.15
Evaは正しい。 2.14の結果を踏まえると、上記プログラムを使う限り、 par1よりpar2のほうが正確な値を出力する。
par1のように、同じ値を示す区間変数が複数回登場する場合、2.14で述べた通り本来同じ値となるべきところを違う値として評価してしまうためである。
2.16
2.14に書いたとおり。 intervalのデータ構造にシリアル番号のような識別子を追加し、 識別子が同じ場合を特別扱いするような改造をすれば、問題は解決できるのではないか。
識別子が同じ場合、減算結果は0、除算結果は1とする。 （加算と積算は通常通りの区間演算で良い）
SICP 演習問題 1.3
Exercise 1.29
;h = (b-a)/n
;y_k=func(a+kh)
;sum = (y_0 + 4y_1 + 2y_2 + 4y_3 + ... + y_n)
;
#lang Racket
(define (simpthon a b func n)
(* (/ (h a b n) 3)
(sum-simpthon a b func 0 n)))
(define (sum-simpthon a b func k n)
(if (> k n)
0
(+ (cond ((or (= k 0) (= k n)) (y a b func k n))
((odd? k) (* 4 (y a b func k n)))
((even? k) (* 2 (y a b func k n))))
(sum-simpthon a b func (+ k 1) n))))
(define (h a b n) (/ (- b a) n))
(define (y a b func k n) (func (+ a (* k (h a b n)))))
(define (odd? k) (= (remainder k 2) 1))
(define (even? k) (= (remainder k 2) 0))
(define (linear x) x)
(define (square x) (* x x))
(simpthon 0 1 linear 1)
(simpthon 0 1 linear 10)
(simpthon 0 1 linear 100)
(simpthon 0 1 square 10)
Exercise 1.30
#lang Racket
(define (sum term a next b)
(if (> a b)
0
(+ (term a) (sum term (next a) next b))))
(define (sum2 term a next b)
(define (iter a result)
(if (> a b)
result
(iter (next a) (+ (term a) result))))
(iter a 0))
(define (square x) (* x x))
(define (step x) (+ x 1))
(sum square 1 step 4)
(sum2 square 1 step 4)
Exercise 1.31
1.31a
#lang Racket
(require racket/flonum)
(define (product term a next b)
(define (iter a result)
(if (> a b)
result
(iter (next a) (* (term a) result))))
(iter a 1))
(define (factorial n) (product abs 1 inc n))
(define (inc x) (+ x 1))
(define (pi n) (* 4 (product wallis 2 inc n)))
(define (wallis x)
(fl/ (->fl (wallis-even x))
(->fl (wallis-odd x))))
(define (wallis-even x) (if (odd? x) (+ x 1) x))
(define (wallis-odd x) (if (even? x) (+ x 1) x))
(factorial 5)
(pi 1000000)
1.31b
#lang Racket
(define (product term a next b)
(if (> a b)
1
(* (term a)
(product term (next a) next b))))
Exercise 1.32
1.32a
;sum (define (sum term a next b) (accumlate + 0 term a next b)) ;product (define (product term a next b) (accumulate * 1 term a next b))
1.32b
(define (accumulate combiner null-value term a next b)
(if (> a b)
null-value
(combiner
(term a)
(accumulate combiner null-value term (next a) next b))))
Exercise 1.33
#lang Racket
(define
(filtered-accumulate combiner null-value filter term a next b)
(define (iter a result)
(cond ((> a b) result)
((filter a) (iter (next a) (combiner (term a) result)))
(else (iter (next a) result))))
(iter a null-value))
1.33a
#lang Racket
(define (prime-square-sum a b)
(filtered-accumulate + 0 prime? square a inc b))
(define (prime? n) (= n (smallest-divisor n)))
(define (smallest-divisor n) (find-divisor n 2))
(define (find-divisor n test-divisor)
(cond ((> (square test-divisor) n) n)
((divides? test-divisor n) test-divisor)
(else (find-divisor n (next test-divisor)))))
(define (divides? a b) (= (remainder b a) 0))
(define (square n) (* n n))
(define (next n) (if (= n 2) 3 (+ n 2)))
(define (inc x) (+ x 1))
(prime-square-sum 1 5)
1.33b
#lang Racket (define (disjoint-product n) (define (disjoint? x) (= (gcd x n) 1)) (filtered-accumulate * 1 disjoint? abs 1 inc n)) (disjoint-product 6)
Exercise 1.33
#lang Racket
(define
(filtered-accumulate combiner null-value filter term a next b)
(define (iter a result)
(cond ((> a b) result)
((filter a) (iter (next a) (combiner (term a) result)))
(else (iter (next a) result))))
(iter a null-value))
a
#lang Racket
(define (prime-square-sum a b)
(filtered-accumulate + 0 prime? square a inc b))
(define (prime? n) (= n (smallest-divisor n)))
(define (smallest-divisor n) (find-divisor n 2))
(define (find-divisor n test-divisor)
(cond ((> (square test-divisor) n) n)
((divides? test-divisor n) test-divisor)
(else (find-divisor n (next test-divisor)))))
(define (divides? a b) (= (remainder b a) 0))
(define (square n) (* n n))
(define (next n) (if (= n 2) 3 (+ n 2)))
(define (inc x) (+ x 1))
(prime-square-sum 1 5)
b
#lang Racket (define (disjoint-product n) (define (disjoint? x) (= (gcd x n) 1)) (filtered-accumulate * 1 disjoint? abs 1 inc n)) (disjoint-product 6)
Excercise 1.34
(2 2) はひょうかできましぇん
#lang racket (define (f g) (g 2)) (define (square x) (* x x)) (f square) (f (lambda (z) (* z (+ z 1)))) (f f)
1.35
#lang Racket
(require racket/flonum)
(define tolerance 0.00001)
(define (fixed-point f first-guess)
(define (close-enough? v1 v2)
(< (abs (- v1 v2)) tolerance))
(define (try guess)
(let ((next (f guess)))
(if (close-enough? guess next)
next
(try next))))
(try first-guess))
(fixed-point (lambda (x) (fl+ 1.0 (fl/ 1.0 x))) 1.0)
1.36
#lang Racket
(require racket/flonum)
(define tolerance 0.00001)
(define (fixed-point f first-guess)
(define (close-enough? v1 v2)
(< (abs (- v1 v2)) tolerance))
(define (try guess)
(let ((next (f guess)))
(display "***")(display guess)(newline)
(if (close-enough? guess next)
next
(try next))))
(try first-guess))
(fixed-point (lambda (x) (fl/ (log 1000) (log x))) 1.1)
(define (average x y) (/ (+ x y) 2))
(fixed-point (lambda (x) (average x (fl/ (log 1000) (log x)))) 1.1)
tolerance 0.00001 38 steps (4.555538934848503) vs 14 steps (4.555536364911781)
tolerance 0.00000000000001 87 steps (4.555535705195124) vs 27 steps (4.555535705195128)
1.37
a
#lang Racket
(require racket/flonum)
(define (cont-frac-try n d k i)
(if (> i k) 0.0
(fl/ (n i) (fl+ (d i) (cont-frac-try n d k (+ i 1))))))
(define (cont-frac n d k)
(cont-frac-try n d k 1))
(cont-frac (lambda (i) 1.0) (lambda(i) 1.0) 11)
(cont-frac (lambda (i) 1.0) (lambda(i) 1.0) 12)
(cont-frac (lambda (i) 1.0) (lambda(i) 1.0) 13)
b
(define (cont-frac n d k)
(define (cont-frac-try i result)
(if (<= i 0)
result
(cont-frac-try (- i 1) (/ (n i) (+ (d i) result)))))
(cont-frac-try k 0.0))
1.38
(define (dfc k)
(+ 2
(cont-frac
(lambda (x) 1.0)
(lambda (x)
(cond ((= (remainder x 3) 2) (* (+ (floor(/ x 3)) 1) 2))
(else 1.0)))
k)))
(dfc 1000)
1.39
#lang Racket
(require racket/flonum)
(define (tan-cf x k)
(define (tan-cf-try i)
(if (> i k)
0
(/ (* x x)
(- (- (* i 2) 1) (tan-cf-try (+ i 1))))))
(/ x (- 1 (tan-cf-try 2))))
(define pi 3.141592)
(tan-cf (/ pi 4) 1000)
(tan-cf (/ pi 3) 1000)
(tan-cf pi 1000)
1.40
#lang Racket
(define dx 0.00001)
(define tolerance 0.00001)
(define (deriv g)
(lambda (x) (/ (- (g (+ x dx)) (g x)) dx)))
(define (newton-transform g)
(lambda (x) (- x (/ (g x) ((deriv g) x)))))
(define (fixed-point f first-guess)
(define (close-enough? v1 v2)
(< (abs (- v1 v2)) tolerance))
(define (try guess)
(let ((next (f guess)))
(if (close-enough? guess next)
next
(try next))))
(try first-guess))
(define (newtons-method g guess)
(fixed-point (newton-transform g) guess))
(define (cubic a b c) (lambda (x) (+ (* x x x) (* a x x) (* b x) c)))
(newtons-method (cubic -3 3 -1) 1.1)
(newtons-method (cubic -6 12 -8) 1.1)
1.41
#lang racket (define (double f) (lambda (x) (f (f x)))) (define (inc x) (+ x 1)) ((double inc) 1) (((double (double double)) inc) 5)
(((double (double double)) inc) 5) (((double (lambda (x) (double (double x)))) inc) 5) (((lambda (x) (double (double (double (double x))))) inc) 5) ((double (double (double (double inc)))) 5) ((double (double (double (lambda (x) (inc (inc x)))))) 5) ((double (double (lambda (x) (inc (inc (inc (inc x))))))) 5) ((double (lambda (x) (inc (inc (inc (inc (inc (inc (inc (inc x)))))))))) 5) ((lambda (x) (inc (inc (inc (inc (inc (inc (inc (inc (inc (inc (inc (inc (inc (inc (inc (inc x))))))))))))))))) 5) (inc (inc (inc (inc (inc (inc (inc (inc (inc (inc (inc (inc (inc (inc (inc (inc 5)))))))))))))))))
1.42
#lang racket (define (compose f g) (lambda (x) (f (g x)))) (define (square x) (* x x)) (define (inc x) (+ x 1)) ((compose square inc) 6)
1.43
#lang Racket
1.44
#lang Racket
(define dx 0.0001)
(define (smooth f)
(lambda (x) (/ (+ (f (- x dx)) (f x) (f (+ x dx))) 3)))
(define (repeated f n)
(if (<= n 1)
(lambda (x) (f x))
(compose f (repeated f (- n 1)))))
(define (n-fold-smooth f n) ((repeated smooth n) f))
1.45
#lang Racket
(define tolerance 0.00001)
(define (repeated f n)
(if (<= n 1)
(lambda (x) (f x))
(compose f (repeated f (- n 1)))))
(define (fixed-point f first-guess)
(define (close-enough? v1 v2)
(< (abs (- v1 v2)) tolerance))
(define (try guess)
(let ((next (f guess)))
(if (close-enough? guess next)
next
(try next))))
(try first-guess))
(define (average-damp f) (lambda (x) (average x (f x))))
(define (average x y) (/ (+ x y) 2))
(define (pow x n)
(if (<= n 0) 1 (* x (pow x (- n 1)))))
(define (n-root x n k)
(fixed-point
((repeated average-damp k)
(lambda (y) (/ x (pow y (- n 1)))))
1.1 ))
(n-root 2 2 1)
(n-root 2 3 1)
(n-root 2 4 2)
(n-root 2 5 2)
(n-root 2 6 2)
(n-root 2 7 2)
(n-root 2 8 3)
(n-root 2 10 3)
(n-root 2 15 3)
(n-root 2 16 4)
(n-root 2 20 4)
(n-root 2 30 4)
(n-root 2 31 4)
(n-root 2 32 5)
(n-root 2 40 5)
(n-root 2 63 5)
(n-root 2 64 6)
log2(n) の模様 したがって
#lang Racket
(define tolerance 0.00001)
(define (repeated f n)
(if (<= n 1)
(lambda (x) (f x))
(compose f (repeated f (- n 1)))))
(define (fixed-point f first-guess)
(define (close-enough? v1 v2)
(< (abs (- v1 v2)) tolerance))
(define (try guess)
(let ((next (f guess)))
(if (close-enough? guess next)
next
(try next))))
(try first-guess))
(define (average-damp f) (lambda (x) (average x (f x))))
(define (average x y) (/ (+ x y) 2))
(define (pow x n)
(if (<= n 0) 1 (* x (pow x (- n 1)))))
(define (log2 x)
(/ (log x) (log 2)))
(define (n-root x n)
(fixed-point
((repeated average-damp (floor (log2 n)))
(lambda (y) (/ x (pow y (- n 1)))))
1.1 ))
Excercise 1.46
#lang Racket
(define (iterative-improve evaluate improve)
(lambda (x)
(let ((next (improve x)))
(if (evaluate x next)
next
((iterative-improve evaluate improve) next)))))
(define tolerance 0.00001)
(define (close-enough? v1 v2)
(< (abs (- v1 v2)) tolerance))
(define (sqrt x)
((iterative-improve
close-enough?
(lambda (y)
(/ (+(/ x y) y) 2))) 1.0))
(define (fixed-point f first-guess)
((iterative-improve
close-enough?
f)
first-guess))
