Geek-Side

Resource > SICP Chapter2
Exercise 2.61
Exercise 2.62
Exercise 2.66
Exercise 2.67
Exercise 2.68

Exercise 2.1

dが負数の場合は、正数に変換する。
 (define (make-rat n d)
   (let ((g (gcd n d)))
     (if (< d 0)
 	(cons (/ n g) (/ (- d) g))
 	(cons (/ n g) (/ d g)))))

Exercise 2.2

 (define (make-segment start end)
   (cons start end))
 (define (start-segment x) (car x))
 (define (end-segment x) (cdr x))
 (define(make-point  x y)
   (cons x y))
 (define (x-point x) (car x))
 (define (y-point x) (cdr x))
 (define (mid-point line)
   (make-segment (average (x-point (start-segment line)) (x-point (end-segment line))) 
 		(average (y-point (start-segment line)) (y-point (end-segment line))) ))
 (define (average n m)
   (/ (+ n m) 2))

 (use gauche.test)
 (test-start "中間点")
 (test* "y = 2xを考える"  '(2 . 4) (mid-point '((1 . 2) . (3 . 6))))
 (test* "y = -x + 5を考える"  '(2 . 3) (mid-point '((1 . 4) . (3 . 2))))
 (test-end)

Exercise 2.3

 (define (rectangle x1 y1 x2 y2)
   (make-segment (make-point x1 y1) (make-point x2 y2)))
 (define (perimeter rectangle)
   (let ((start (start-segment rectangle))
 	(end (end-segment rectangle)))
     (* 2 (+ (abs (- (x-point start) (x-point end)))
 	    (abs (- (y-point start) (y-point end)))))))
 (define (area rectangle)
   (let ((start (start-segment rectangle))
 	(end (end-segment rectangle)))
   (abs (* (- (x-point start) (x-point end))
 	  (- (y-point start) (y-point end))))))

 (use gauche.test)
 (test-start "面積と周")
 (test* "面積"  8 (area (rectangle 1 2 3 6)))
 (test* "周"  12 (perimeter (rectangle 1 2 3 6)))
 (test-end)

Exercise 2.4

 (define (cons x y)
   (lambda (m) (m x y)))

 (define (car z)
   (z (lambda (p q) p)))

 (define (cons z)
   (z (lambda (p q) q)))

Exercise 2.5

 (define (cons a b)
     (* (expt 2 a) (expt 3 b)))
 (define (count-divide n m)
   (define (iter x y)
     (if (= (remainder x m) 0) 
 	(iter (quotient x m) (+ y 1))
 	y))
   (iter n 0))
 (define (car c)
   (count-divide c 2))
 (define (cdr c)
   (count-divide c 3))

 (use gauche.test)
 (test-start "2のa乗、3のb乗の積をconsとする場合")
 (test* "count-divideのテスト1" 2 (count-divide 4 2))
 (test* "count-divideのテスト2" 2 (count-divide 12 2))
 (test* "count-divideのテスト2" 1 (count-divide 12 3))
 (test* "consのテスト" 72 (cons 3 2))
 (test* "carのテスト" 3 (car 72))
 (test* "cdrのテスト" 2 (cdr 72))
 (test-end)

Exercise 2.6

 (define zero (lambda (f) (lambda (x) x)))
 (define (add-1 n)
   (lambda (f) (lambda (x) (f ((n f) x)))))

 ;(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)))
 (define one
   (lambda (f) (lambda (x) (f x))))

 (add-1 one)
 ;; -> (lambda (f) (lambda (x) (f ((one f) x))))
 ;; -> (lambda (f) (lambda (x) (f (((lambda (f) (lambda (x) (f x))) f) x))))
 ;; -> (lambda (f) (lambda (x) (f ((lambda (x) (f x)) x))))
 ;; -> (lambda (f) (lambda (x) (f (f x))))
 (define two
   (lambda (f) (lambda (x) (f (f x)))))

 (define (to-integer n)
   ((n (lambda (x) (+ 1 x))) 0))

+演算子の定義がわからない。
 (define (add a b)
   (lambda (f) (lambda (x) ((a f) ((b f) x)))))

Exercise 2.7

 (define (upper-bound n) (cdr n))
 (define (lower-bound n) (car n))

Exercise 2.8

 (define (sub-interval x y)
   (make-interval (- (lower-bound x) (upper-bound y)) (- (upper-bound x) (lower-bound y))))

Exercise 2.9

 (define (width z) (/ (- (upper-bound z) (lower-bound z)) 2))

 (width (add-interval x y))
 ;;->(/ (- (+ (upper-bound x) (upper-bound y)) (+ (lower-bound x) (lower-bound y))) 2)
 ;;->(/ (+ (- (upper-bound x) (lower-bound x)) (- (upper-bound y) (lower-bound y))) 2)
 ;;->(+ (width x) (width y))
 (width (sub-interval x y))
 ;;->(/ (- (- (upper-bound x) (lower-bound y)) (- (lower-bound x) (upper-bound y))) 2)
 ;;->(/ (- (+ (upper-bound x) (- lower-bound y)) (+ (lower-bound x) (- upper-bound y))) 2)
 ;;->(/ (+ (upper-bound x) (- lower-bound y) (- lower-bound x) (upper-bound y)) 2)
 ;;->(/ (+ (upper-bound x) (- lower-bound y) (- lower-bound x) (upper-bound y)) 2)
 ;;->(+ (width x) (width y))

Exercise 2.10

0を跨ぐと無限大になるため。
 (define (div-interval x y)
   (if (and (> (upper-bound y) 0) (< (lower-bound y) 0))
       (display "error!")
       (mul-interval x 
 		    (make-interval (/ 1.0 (upper-bound y))
 				   (/ 1.0 (lower-bound y))))))

Exercise 2.11

 (define (mul-interval x y)
   (let ((xl (lower-bound x))
 	(xu (upper-bound x))
 	(yl (lower-bound y))
 	(yu (upper-bound y)))
     (cond [(< xu 0)
 	   (cond [(> yl 0) (make-interval (* xl yu) (* xu yl))]
 		 [(< yu 0) (make-interval (* xu yu) (* xl yl))]
 		 [else (make-interval (* xl yu) (* xl yl))])]
 	  [(> xl 0)
 	   (cond [(> yl 0) (make-interval (* xl yl) (* xu yu))]
 		 [(< yu 0) (make-interval (* xu yl) (* xl yu))]
 		 [else (make-interval (* xu yl) (* xl yu))])]
 	  [else  [(> yl 0) (make-interval (* xl yu) (* xu yu))]
 		 [(< yu 0) (make-interval (* xu yl) (* xl yl))]
 		 [else (make-interval (min (* xl yu) (* xu yl)) (max (* xl yl) (* xu yu)))]])))

Exercise 2.12


 (define (make-center-width c w)
   (make-interval (- c w) (+ c w)))
 (define (center i)
   (/ (+ (lower-bound i) (upper-bound i)) 2))
 (define (width i)
   (/ (- (upper-bound i) (lower-bound i)) 2))

 (define (make-center-percent c percent)
   (make-center-width c (/ (* c percent) 100)))
 (define (persent i)
   (* (/ (width i) (center i)) 100))

Exercise 2.13

小さなパーセントのトレランスにおいて、インターバルの掛け算が簡単な公式で表せるか。
 (define a (make-center-percent 2 0.05))
 (define b (make-center-percent 1 0.03))
 (percent (mul-interval a b))
 ;;-> 0.079999987999993
 (define a (make-center-percent 2 0.01))
  (define b (make-center-percent 1 0.01))
  (percent (mul-interval a b))
 ;;-> 0.01999999979999225
パーセンテージの足し算になる。

Exercise 2.14

 (define (par1 r1 r2)
   (div-interval (mul-interval r1 r2)
                 (add-interval r1 r2)))
 (define (par2 r1 r2)
   (let ((one (make-interval 1 1))) 
     (div-interval one
                   (add-interval (div-interval one r1)
                                 (div-interval one r2)))))
 (define a (make-center-percent 4.0 0.1))
 (define b (make-center-percent 3.0 0.1))
 (par1 a b)
 (par2 a b)

 ;結果は
 ;gosh> (1.7091497074354216 . 1.7194354354354353)
 ;gosh> (1.7125714285714284 . 1.716)

Exercise 2.17

 (define (last-pair lis)
   (define (ite i)
     (if (null? (cdr i))
 	i
 	(ite (cdr i))))
   (ite lis)
   )

 (use gauche.test)
 (test-start "Exercise 2.17")
 (test* "last-pairのテスト" '(34) (last-pair (list 23 72 149 34)))
 (test-end)

Exercise 2.18

 (define (revers lis)
   (define (ite result obj)
     (if (null? obj)
 	result
 	(ite (cons (car obj) result) (cdr obj))))
   (ite '() lis))

 (use gauche.test)
 (test-start "Exercise 2.18")
 (test* "reverseのテスト" '(25 16 9 4 1) (reverse (list 1 4 9 16 25)))
 (test-end)

Exercise 2.19

 (define (cc amount coins)
   (cond ((= amount 0) 1)
 	((or (< amount 0) (null? coins)) 0)
 	(else (+ (cc amount
 		     (cdr coins))
 		 (cc (- amount
 			(car coins))
 		     coins)))))
 (define us-coins (list 50 25 10 5 1))
 (define uk-coins (list 100 50 20 10 5 2 1 0.5))

 (use gauche.test)
 (test-start "Exercise 2.19")
 (test* "100の場合" 292 (cc 100 us-coins))
 (test* "10の場合" 4 (cc 10 us-coins))
 (test* "0の場合" 1 (cc 0 us-coins))
 (test-end)

Exercise 2.20

 (use srfi-1)
 (define (same-parity x . y)
   (if (even? x)
       (cons x (filter even? y))
       (cons x (filter odd? y))))

 (use gauche.test)
 (test-start "Exercise 2.20")
 (test* "奇数で始まる場合" '(1 3 5 7) (same-parity 1 2 3 4 5 6 7))
 (test* "偶数で始まる場合" '(2 4 6) (same-parity 2 3 4 5 6 7))
 (test-end)

Exercise 2.21

 ; square
 (define (square x)
   (* x x))
 ; nil
 (define nil '())
 ; mapを使わない場合
 (define (square-list items)
   (if (null? items)
       nil
       (cons (square (car items)) (square-list (cdr items)))))
 ; mapを使う場合
 (define (square-list items)
   (map square items))

 (use gauche.test)
 (test-start "Exercise 2.21")
 (test* "通常" '(1 4 9 16) (square-list (list 1 2 3 4)))
 (test* "空リスト" '() (square-list '()))
 (test* "0" '(0 0 0) (square-list '(0 0 0)))
 (test-end)

Exercise 2.22

最初の関数におけるバグは、iter関数が再帰的に対象のcarをconsしていくから
2つ目の関数が動作しないのは、再帰的に処理されるiter関数に与えられるanswerの初期値がnilのため、
cons処理の第一引数が nil の状態になるため。

Exercise 2.23

 (define (for-each proc lis)
   (if (null? lis)
       #t
       (begin (proc (car lis))
 	     (for-each proc (cdr lis)))))
副作用のテストはどうするの?

Exercise 2.24

 (1 (2 (3 4)))

Exercise 2.25

 (car (cdaddr '(1 3 (5 7) 9)))
 (caar '((7)))
 (cadadr(cadadr (cadadr'(1 (2 (3 (4 (5 (6 7))))))))

Exercise 2.26

 (define x (list 1 2 3))
 (define y (list 4 5 6))

 gosh> (append x y)
 (1 2 3 4 5 6)
 gosh> (cons x y)
 ((1 2 3) 4 5 6)
 gosh> (list x y)
 ((1 2 3) (4 5 6))


Exercise 2.27

 (define (deep-reverse lis)
   (define (ite result obj)
     (if (null? obj)
 	result
 	(ite (cons (deep-reverse (car obj)) result) (cdr obj))))
   (if (pair? lis)
       (ite '() lis)
       lis))
 (define x (list (list 1 2) (list 3 4)))
 
 (use gauche.test)
 (test-start "Exercise 2.27")
 (test* "((1 2) (3 4))" '((4 3) (2 1)) (deep-reverse x))
 (test-end)

Exercise 2.28

 (define (fringe lis)
   (define (ite result l)
     (cond [(null? l) result]
 	  [(pair? l) (append (ite result (car l)) (ite result (cdr l)))]
 	  [else (reverse (cons l (reverse result)))]))
   (ite '() lis))
 
 (use gauche.test)
 (test-start "Exercise 2.28")
 (test* "((1 2) (3 4))の場合" '(1 2 3 4) (fringe '((1 2) (3 4))))
 (test* "((1 2) (3 4) (5 (6 7)))の場合" '(1 2 3 4 5 6 7) (fringe '((1 2) (3 4) (5 (6 7)))))
 (test-end)

Exercise 2.29

 (define (make-mobile left right)
   (list left right))
 (make-mobile 1 3)

 (define (make-branch length structure)
   (if (pair? length)
       (error "length must be number!")
       (list length structure)))


Exercise 2.29 a

 (define left-branch car)
 (define right-branch cadr)
 (define branch-length car)
 (define branch-structure cadr)

 (use gauche.test)
 (test-start "Exercise 2.29 a")
 (test* "left is list" '(1 2) (left-branch '((1 2) 2)))
 (test* "normal" 1 (left-branch '(1 2)))
 (test* "right is list" '(1 2) (right-branch '(1 (1 2))))
 (test* "normal" 2 (right-branch '(1 2)))
 (test* "normal length" 1 (branch-length '(1 2)))
 (test* "normal structure" '(1 2) (branch-structure '(1 (1 2))))
 (test-end)

Exercise 2.29 b

 (define (total-weight m)
   (define (ite total l)
     (let ((length (branch-length l))
 	  (weight (branch-structure l)))
     (if (number? weight)
 	(if (pair? length)
 	    (ite (+ total weight) (left-branch l))
 	    (+ total weight))
 	(if (pair? length)
 	    (ite (+ total (ite total weight)) (left-branch l))
 	    (ite total weight)))))
     (ite 0 m))

 (use gauche.test)
 (test-start "Exercise 2.29 b")
 (test* "normal" 6 (total-weight '((1  2) (3 4))))
 (test* "nest1" 9 (total-weight '(((1 3) 2) (3 4))))
 (test* "nest2" 10 (total-weight '(((1 3) 2) ((3 1) 4))))
 (test* "nest3" 7 (total-weight '((1  (1 2)) ((3 1) 4))))
 (test-end)

Exercise 2.29 c

 (define (tolque mobile pre)
   (let ((right (right-branch mobile))
 	(left (left-branch mobile)))
     (cond [(and (number? left) (number? right))	(* (+ pre left) right)]
 	  [(and (number? left) (pair? right))(tolque right (+ pre left))]
 	  [(and (pair? left) (number? right))(raise "length must be number")]
 	  [else (+ (tolque left  pre) (tolque right pre))])))
 (use gauche.test)
 (test-start "calc tolque")
 (test* "standard" 14 (tolque '((1 2) (3 4)) 0))
 (test* "nested" 18 (tolque '((1 2) (3 (1 4))) 0))
 (test* "nested2" 23 (tolque '(((1 3) (2 2)) (3 (1 4))) 0))
 (test-end)

 (define (balanced? mobile)
   (if (= (tolque (left-branch mobile) 0) (tolque (right-branch mobile) 0))
       #t #f))
 (use gauche.test)
 (test-start "balanced test")
 (test* "standard unbalance" #f (balanced? '((1 2) (3 4))))
 (test* "nested unbalance" #f (balanced? '((1 2) (3 (1 4)))))
 (test* "standard balance" #t (balanced? '((1 2) (2 1))))
 (test* "nested balance" #t (balanced? '((5 2) (2 (3 2)))))
 (test-end)

Exercise 2.29 d

下記の関数を変更する必要がある。
(define left-branch car)
(define right-branch cadr)
(define branch-length car)
(define branch-structure cadr)

Exercise 2.30

 ; 直接版
 (define (square-tree tree)
   (cond [(null? tree) '()]
 	[(not (pair? tree)) (* tree tree)]
 	[else (cons (square-tree (car tree)) (square-tree (cdr tree)))]))
 ; map版
 (define (square-tree tree)
   (map (lambda (sub-tree)
          (if (pair? sub-tree)
              (square-tree sub-tree)
              (* sub-tree sub-tree)))
        tree))
 (use gauche.test)
 (test-start "square-tree")
 (test* "normal list" '(1 4 9 16) (square-tree '(1 2 3 4)))
 (test* "normal list" '(1 (4 (9 16) 25) (36 49)) (square-tree '(1 (2 (3 4) 5) (6 7))))
 (test-end)

Exercise 2.31

 (define (square-tree tree) (tree-map square tree))
 (define (square x)
   (* x x))
 (define (tree-map proc tree)
   (map (lambda (sub-tree)
 	 (if (pair? sub-tree)
 	     (tree-map proc sub-tree)
 	     (proc sub-tree))) tree))
  (use gauche.test)
  (test-start "square-tree")
  (test* "normal list" '(1 4 9 16) (square-tree '(1 2 3 4)))
  (test* "normal list" '(1 (4 (9 16) 25) (36 49)) (square-tree '(1 (2 (3 4) 5) (6 7))))
  (test-end)

Exercise 2.33

 (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)) '() sequence))
 (define (append seq1 seq2)
   (accumulate cons seq2 seq1))
 (define (length sequence)
   (accumulate (lambda (x y) (+ 1 y)) 0 sequence))

 (use gauche.test)
 (test-start "Exercise 2.33")
 (test* "mapのテスト" '(2 4 6) (map (lambda (x) (* x 2)) '(1 2 3)))
 (test* "appendのテスト" '(1 2 3 4) (append '(1 2) '(3 4)))
 (test* "lengthのテスト" 3 (length '(1 2 3 )))
 (test-end)

2.2.3

 (define (accumulate op initial sequence)
   (if (null? sequence)
       initial
       (op (car sequence)
           (accumulate op initial (cdr sequence)))))
 (use gauche.test)
 (test-start "accumulate")
 (test* "15" 15 (accumulate + 0 (list 1 2 3 4 5)))
 (test* "120" 120 (accumulate * 1 (list 1 2 3 4 5)))
 (test* "(1 2 3 4 5)" '(1 2 3 4 5) (accumulate cons '() (list 1 2 3 4 5)))
 (test* "(1 2 3 4 5)" '(1 2 3 4 5) (accumulate append '() '((1 2) (3 4 5))))
 (test-end)
 
 (define (append list1 list2)
   (if (null? list1)
       list2
       (cons (car list1) (append (cdr list1) list2))))
 
 (define (flatmap proc seq)
   (accumulate append '() (map proc seq)))
 
 (define (permutations s)
   (if (null? s)                    ; empty set?
       (list '())                   ; sequence containing empty set
       (flatmap (lambda (x)
                  (map (lambda (p) (cons x p))
                       (permutations (remove x s))))
                s)))
 
 (define (remove item sequence)
   (filter (lambda (x) (not (= x item)))
           sequence))
 
 (define (filter predicate sequence)
   (cond ((null? sequence) '())
         ((predicate (car sequence))
          (cons (car sequence)
                (filter predicate (cdr sequence))))
         (else (filter predicate (cdr sequence)))))

Exercise 2.40

2.3.2

Exercise 2.56
Exercise 2.57

2.4.3

関数名が同じで実装が異なる定義を持つことが出来る。
 (define (install-rectangular-package)
   ;; internal procedures
   (define (real-part z) (car z))
   (define (imag-part z) (cdr z))
   (define (make-from-real-imag x y) (cons x y))
   (define (magnitude z)
     (sqrt (+ (square (real-part z))
 	     (square (imag-part z)))))
   (define (angle z)
     (atan (imag-part z) (real-part z)))
   (define (make-from-mag-ang r a)
     (cons (* r (cos a)) (* r (sin a))))
   
   ;; interface to the rest of the system
   (define (tag x) (attach-tag 'rectangular x))
   (put 'real-part '(rectangular) real-part)
   (put 'imag-part '(rectangular) imag-part)
   (put 'magnitude '(rectangular) magnitude)
   (put 'angle '(rectangular) angle)
   (put 'make-from-real-imag 'rectangular
        (lambda (x y) (tag (make-from-real-imag x y))))
   (put 'make-from-mag-ang 'rectangular
        (lambda (r a) (tag (make-from-mag-ang r a))))
   'done)
 
 (define (install-polar-package)
   ;; internal procedures
   (define (magnitude z) (car z))
   (define (angle z) (cdr z))
   (define (make-from-mag-ang r a) (cons r a))
   (define (real-part z)
     (* (magnitude z) (cos (angle z))))
   (define (imag-part z)
     (* (magnitude z) (sin (angle z))))
   (define (make-from-real-imag x y)
     (cons (sqrt (+ (square x) (square y)))
 	  (atan y x)))
   ;; interface to the rest of the system
   (define (tag x) (attach-tag 'polar x))
   (put 'real-part '(polar) real-part)
   (put 'imag-part '(polar) imag-part)
   (put 'magnitude '(polar) magnitude)
   (put 'angle '(polar) angle)
   (put 'make-from-real-imag 'polar
        (lambda (x y) (tag (make-from-real-imag x y))))
   (put 'make-from-mag-ang 'polar
        (lambda (r a) (tag (make-from-mag-ang r a))))
   'done)
 (define (apply-generic op . args)
   (let ((type-tags (map type-tag args)))
     (let ((proc (get op type-tags)))
       (if proc
           (apply proc (map contents args))
           (error
             "No method for these types -- APPLY-GENERIC"
             (list op type-tags))))))
 

新しい実装方法が加わっても、下記定義は変わらない。
 (define (real-part z) (apply-generic 'real-part z))
 (define (imag-part z) (apply-generic 'imag-part z))
 (define (magnitude z) (apply-generic 'magnitude z))
 (define (angle z) (apply-generic 'angle z))
Exercise 2.73