alaskanの解答

基本的にコーディングがある問題のみを解答していきます。

;;; 問題1.3

(define (sum2 a b c)
  (if (> a b)
      (if (> b c)
          (+ (square a) (square b))
          (+ (square a) (square c)))
      (if (> a c)
          (+ (square b) (square a))
          (+ (square b) (square c)))))

;;; 問題1.7

改造前
gosh> (sqrt 0.00000002)
0.03125021312471016
gosh> (sqrt 20000000000)
141421.35623730952

(define (sqrt-iter prev guess x)
  (if (good-enough? prev guess)
      guess
      (sqrt-iter guess (improve guess x)
                 x)))
(define (good-enough? prev guess)
  (< (abs (/ (- prev guess) guess)) 0.001))
(define (sqrt x)
  (sqrt-iter 0.0 1.0 x))

改造後
gosh> (sqrt 0.00000002)
1.4142135875671105e-4
gosh> (sqrt 2000000000000)
1414213.5625134502

;;; 問題1.8

(define (cubic-iter prev guess x)
  (if (good-enough? prev guess)
      guess
      (cubic-iter guess (cubic-improve guess x)
                 x)))
(define (cubic-improve guess x)
  (/ (+ (/ x (square guess)) (* 2 guess )) 3))
(define (cubic-root x)
  (cubic-iter 0.0 1.0 x))

;;; 問題1.11

;; 再帰的
(define (recursive-f n)
  (if (< n 3)
      n
      (+ (recursive-f (- n 1)) (* 2 (recursive-f (- n 2))) (* 3 (recursive-f (- n 3))))))

;; 反復的
(define (iterative-f n)
  (define (f-iter count a b c)
    (if (= count n)
        a
        (f-iter (+ count) (+ a (* 2 b) (*3 c)) a b)))
  (if (< n 3)
      n
      (f-iter 3 4 2 0)))

;;; 問題1.12

;; パスカルの三角形の項を計算(i,jは1から数える)
(define (pascal-term i j)
  (if (or (= j 1) (= i j))
      1
      (+ (pascal-term (- i 1) (- j 1)) (pascal-term (- i 1) j))))

;;; 問題1.16

(define (iterative-expt b n)
  (define (expt-iter a b n)
    (if (= n 0)
        a
        (if (even? n)
            (expt-iter a (square b) (/ n 2))
            (expt-iter (* a b) b (- n 1)))))
  (expt-iter 1 b n))

;;; 問題1.17

(define (double x)
  (+ x x))

(define (halve x)
  (if (= 0 (remainder x 2))
      (/ x 2)
      (/ (- x 1) 2)))

(define (multi a b)
  (if (= b 0)
      0
      (if (even? b)
          (multi (double a) (halve b))
          (+ a (multi a (- b 1))))))

;;; 問題1.18

(define (iterative-multi a b)
  (define (multi-iter n a b)
    (if (= b 0)
        n
        (if (even? b)
            (multi-iter n (double a) (halve b))
            (multi-iter (+ n a) a (- b 1)))))
  (multi-iter 0 a b))

;;; 問題1.19

(define (fib n)
  (fib-iter 1 0 0 1 n))

(define (fib-iter a b p q count)
  (cond ((= count 0) b)
        ((even? count)
         (fib-iter a
                   b
                   (+ (square p) (square q)) ; compute p'
                   (+ (* 2 p q) (square q))  ; compute q'
                   (/ count 2)))
        (else (fib-iter (+ (* b q) (* a q) (* a p))
                        (+ (* b p) (* a q))
                        p
                        q
                        (- count 1)))))

;;; 問題1.21

(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 (+ test-divisor 1)))))

(define (divides? a b)
  (= (remainder b a) 0))

;;; 問題1.28

(use math.mt-random)
(define m (make <mersenne-twister> :seed (sys-time)))
(define (expmod base exp m)
  (cond ((= exp 0) 1)
        ((even? exp)
         (remainder (square (expmod base (/ exp 2) m))
                    m))
        (else
         (remainder (* base (expmod base (- exp 1) m))
                    m))))

(define (fermat-test n)
  (define (try-it a)
    (= (expmod a n n) a))
  (try-it (+ 1 (mt-random-integer m (- n 1)))))

(define (fermat-all-test n)
  (let iter ((i (- n 1)))
    (cond ((= i 1) #t)                  ;全ての数について#t
          ((= (expmod i n n) i)         ;fermat-test
           (iter (- i 1)))              ;fetmat-testにパスしたらiを減らしてループ
          (else #f))))                  ;fermat-testにパスしなければ#f

;;; 問題1.29

(define (sum term a next b)
  (let iter ((result 0) (i a))
    (if (> i b)
        result
        (iter (+ result (term i)) (next i)))))
(define (simpson f a b n)
  (let* ((ne (if (even? n) n (+ n 1)))
         (h (/ (- b a) ne))
         (y (lambda (i) (f (+ a (* i h)))))
         (next (lambda (n) (+ n 2))))
    (/ (* h (+ (f a)
               (* 4 (sum y 1 next (- ne 1)))
               (* 2 (sum y 2 next (- ne 2)))
               (f b))) 3)))

;;; 問題1.30

(define (sum term a next b)
  (let iter ((result 0) (i a))
    (if (> i b)
        result
        (iter (+ result (term i)) (next i)))))

;;; 問題1.31

;; a

(define (product term a next b)
  (let iter ((result 1) (i a))
    (if (> i b)
        result
        (iter (* result (term i)) (next i)))))

(define (factorial n)
  (product (lambda (x) x) 1 (lambda (x) (+ x 1)) n))

(define (wallis n)
  (* 4.0 (product (lambda (x) (/ (* (+ x 2) (+ x 4)) (square (+ x 3))))
                     0 (lambda (x) (+ x 2)) n)))

;; b

(define (product-recursive term a next b)
  (if (> a b)
      1
      (* (term a) (product-recursive term (next a) next b))))

;;; 問題1.32

;; a

(define (accumulate combiner null-value term a next b)
    (let iter ((result null-value) (i a))
    (if (> i b)
        result
        (iter (combiner result (term i)) (next i)))))
(define (sum term a next b)
  (accumulate + 0 term a next b))
(define (product term a next b)
  (accumulate * 1 term a next b))

;; b

(define (accumulate-recursive combiner null-value term a next b)
  (if (> a b)
      null-value
      (combiner (term a) (accumelate-recursive combiner null-value term (next a) next b))))

;;; 問題1.33

(define (filtered-accumulate combiner filter null-value term a next b)
  (let iter ((result null-value) (i a))
    (if (> i b)
        result
        (iter (if (filter i)
                  (combiner result (term i))
                  result)
              (next i)))))

;; a

(define (sum-square-prime a b)
  (filtered-accumulate + fermat-all-test 0 square a (lambda (x) (+ x 1)) b))

;; b

(define (gcd-product n)
  (filtered-accumulate * (lambda (x) (= (gcd n x) 1)) 1 (lambda (x) x) 1 (lambda (x) (+ x 1)) n))

;;; 問題1.36

(define tolerance 0.00001)

(define ([[fixed-point]] f first-guess)
  (define (close-enough? v1 v2)
    (< (/ (abs (- v1 v2)) v2) tolerance))
  (define (try guess i)
    (display i)
    (display " : ")
    (display guess)
    (newline)
    (let ((next (/ (+ (f guess) guess) 2.0)))
      (if (close-enough? guess next)
          next
          (try next (+ i 1)))))
  (try first-guess 0))

;;; 問題1.37

;; a

(define (cont-frac n d k)
  (define (sub-cont-frac i)
    (if (= i k) (/ (n i) (d i))
        (/ (n i) (+ (d i) (sub-cont-frac (+ i 1))))))
  (sub-cont-frac 1))

;; b

(define (cont-frac n d k)
  (let iter ((result 0) (i k))
    (if (= i 0) result
        (iter (/ (n i) (+ (d i) result)) (- i 1)))))

;;; 問題1.38

(define (euler-e)
  (+ (cont-frac (const 1.0) (lambda (i)
                              (if (= (remainder i 3) 2)
                                  (* (+ (quotient i 3) 1) 2)
                                  1)) 10)
     2))

;;; 問題1.39

(define (tan-cf x k)
  (cont-frac (lambda (i)
               (if (= i 1) x
                   (- (square x))))
             (lambda (i) (- (* 2 i) 1)) k))

;;; 問題1.42

(define (compose f g)
  (lambda (x) (f (g x))))

;;; 問題1.43

;; 問題1.32のaccumulateを使用する

(define (repeated f n)
  (accumulate compose identity (const f) 1 inc n))

;;; 問題1.44

(define dx 0.00001)
(define (smoothing f)
  (/ (+ (f (- x dx)) (f x) (f (+ x dx))) 3.0))
(define (n-fold-smoothing (f n))
  (repeated smoothing n))

;;; 問題1.45

;;; 問題1.46