やろーじだい

ブログです

Aizu SICP 第 15 回 part 2

part1 の続きです。

リストに対するマップ

練習問題 2.21

 穴埋め問題。  以前から利用していたため今更だがラムダ式の表記として、 Gauche で用意されている別名である ^ を利用している。参考

(define (square-list1 items)
  (if (null? items)
      nil
      (cons (* (car items) (car items))
            (square-list1 (cdr items)))))

(define (square-list2 items)
  (map (^x (* x x)) items))

(test-section "ex 2.21")

(test* "square-list1.1" (list 1 4 9) (square-list1 '(1 2 3)))
(test* "square-list1.2" (list 1 1 1) (square-list1 '(1 1 1)))

(test* "square-list2.1" (list 1 4 9) (square-list2 '(1 2 3)))
(test* "square-list2.2" (list 1 1 1) (square-list2 '(1 1 1)))

練習問題 2.22

(define (square-list items)
  (define (iter things answer)
    (if (null? things)
        answer
        (iter (cdr things)
              (cons (square (car things))
                    answer))))
  (iter items nil))

(square-list '(1 2 3)) というのを展開していく。

(square-list '(1 2 3))
;; ↓
(iter '(1 2 3) nil)
;; ↓
(iter '(2 3) (cons 1 nil))
;; ↓
(iter '(3) (cons 4 (cons 1 nil)))

という形になり、nil に対して iter の第二引数として渡されるリストの先頭を二乗した数を順に nil に追加していくので逆順になってしまう。

(define (square-list items)
  (define (iter things answer)
    (if (null? things)
        answer
        (iter (cdr things) (cons answer (square (car things))))))
  (iter items nil))

修正したものに関しても展開してみる。

(square-list '(1 2 3))
;; ↓
(iter '(1 2 3) nil)
;; ↓
(iter '(2 3) (cons nil 1))

ここで、リストというのは終端が nil であるようなコンスの連なりであるので、(1 2 3) とは (1 . (2 . (3 . nil))) であることに注意する。上の式の (cons nil 1) を評価すると (nil . 1) というものになりリストにならない。

練習問題 2.23

(define (my-for-each proc lis)
  (define (proc-iter l)
    (proc (car l))
    (my-for-each proc (cdr l)))
  (if (not (null? lis))
      (proc-iter lis)))

if は以下のように条件が偽でありながら第3式が無い場合は #<undef> という未定義の値になる。参考 今回はとりあえず #<undef> を返すようにした。

gosh> (if #f 1)
#<undef>
gosh> (my-for-each (^ (x)
                      (newline)
                      (display x))
                   (list 1 2 3))

1
2
3#<undef>

2.2.2 階層構造

例えば、次の式によって構築されるオブジェクト '((1 2) 3 4) は、 (cons (list 1 2) (list 3 4)) 三つの項目を持つリストとして見ることができ、その一つ目の項目はそれ自身 が (1 2) というリストということになります。

(Page 115)

読書会の参加者もそうであったが (cons (list 1 2) (list 3 4)) を評価すると (1 2 3 4) となるのではないかと考えてしまう場合が多いので、勘違いした場合は図 2.5 を見てよくみてみること。((1 2) 3 4)(1 2 3 4) は構造としては全く違ったものになる。

練習問題 2.24

gosh> (list 1 (list 2 (list 3 4)))
(1 (2 (3 4)))

このプログラムは以下のように cons で書き直せる。

(cons 1
      (cons (cons 2
                  (cons (cons 3
                              (cons 4 nil))
                        nil))
            nil))

(test* "" (list 1 (list 2 (list 3 4)))
          (cons 1 (cons (cons 2 (cons (cons 3 (cons 4 nil)) nil)) nil)))

練習問題 2.25

(test-section "ex 2.25")

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

(car (cdr l)) というのは (cadr l) と書ける。Gauche では cxr という形のアクセッサーは最大4回の操作をまとめたものが定義されている。 R7RS cxrアクセサ

練習問題 2.26

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

(test-section "ex 2.26")

(test* "" '(1 2 3 4 5 6) (append x y))
(test* "" '((1 2 3) 4 5 6) (cons x y))
(test* "" '((1 2 3) (4 5 6)) (list x y))

練習問題 2.27

まず my-reverse という名前で通常の reverse を実装した。

(define (my-reverse lis)
  (define (iter lis acm)
    (if (null? lis)
        acm
        (iter (cdr lis) (cons (car lis) acm))))
  (iter lis nil))

それを使って deep-reverse を実装する。

(define (deep-reverse lis)
  (if (not (pair? lis))
      lis
      (map deep-reverse (my-reverse lis))))
(test-section "ex 2.27")

(test* "deep-reverse1" '(1) (deep-reverse '(1)))
(test* "deep-reverse2" '(3 2 1) (deep-reverse '(1 2 3)))
(test* "deep-reverse3" '((4 3) (2 1)) (deep-reverse '((1 2) (3 4))))
(test* "deep-reverse4" '((1 2) ((4 3) (2 1))) (deep-reverse '(((1 2) (3 4)) (2 1))))

(test* "deep-reverse5" '((4 3) (2 1)) (deep-reverse '((1 2) (3 4))))
(test* "deep-reverse6" '((4 (3 2)) 1) (deep-reverse '(1 ((2 3) 4))))

(test* "deep-reverse7" '((2 1)) (deep-reverse '((1 2))))
(test* "deep-reverse8" '((4 3) (2 1)) (deep-reverse '((1 2) (3 4))))

練習問題 2.28

葉を集めるプログラム。

(define (fringe tree)
  (cond ((not (pair? tree))
         tree)
        ((not (pair? (car tree)))
         (cons (car tree) (fringe (cdr tree))))
        (else (append (fringe (car tree)) (fringe (cdr tree))))))

(test-section "ex 2.28")

(test* "fringe1" '(1 2 3 4 5) (fringe '(1 2 (3) 4 5)))
(test* "fringe2" '(1 2 3 4 5) (fringe '((1) (2) (3) (4) (5))))
(test* "fringe3" '(1 2 3 4 5) (fringe '(1 (2 (3) 4) 5)))
(test* "fringe4" '(1 2 3 4 5) (fringe '(1 (2 (3) 4) 5)))

練習問題 2.29

 まずモビールとは何かということで困った問題。二枝モビールの例  上記画像のように、任意の長さの棒と、その両端にはある長さの紐があり、そこには重りかまた別な棒がぶら下がっている。それらがバランスを取りあっているような再帰的構造を持つ飾りのことを指すようだ。

;; 両端に何かがぶら下がっているある棒を表すデータである mobile を定義する関数
(define (make-mobile left right)
  (list left right))

;; mobile の両端にぶら下がっている紐の長さと、そこに付いているデータからなる branch を定義する関数
;; structure には make-mobile で作られたものか、重りを表す数値が入る
(define (make-branch length structure)
  (list length structure))
a
(define (left-branch mobile)
  (car mobile))

(define (right-branch mobile)
  (cadr mobile))

(define (branch-length branch)
  (car branch))

(define (branch-structure branch)
  (cadr branch))

(test-section "ex 2.29")

(test* "left-branch" '(1 2 3) (left-branch (make-mobile '(1 2 3) '(4 5 6))))
(test* "right-branch" '(4 5 6) (right-branch (make-mobile '(1 2 3) '(4 5 6))))

(test* "branch-length" 3 (branch-length (make-branch 3 '(4 5 6))))
(test* "branch-structure" '(4 5 6) (branch-structure (make-branch 3 '(4 5 6))))

(cdr mobile) では余分なリストにくるまれた状態になってしまうのでそこから取り出すために cadr を使っている。

b
(define (total-weight mobile)
  (if (pair? mobile)
      (+ (total-weight (branch-structure (left-branch mobile)))
         (total-weight (branch-structure (right-branch mobile))))
      mobile))

(test* "total-weight" 5
       (total-weight (make-mobile (make-branch 2 2) (make-branch 3 3))))

(test* "total-weight" 7
       (total-weight (make-mobile (make-branch 2 (make-mobile (make-branch 1 2)
                                                              (make-branch 1 2)))
                                  (make-branch 3 3))))

(test* "total-weight"
       15
       (total-weight (make-mobile (make-branch 3
                                               (make-mobile (make-branch 2 5)
                                                            (make-branch 1 5)))
                                  (make-branch 3 5))))
c
;; branch を受けとって紐の長さと総重量の積を取る。
(define (get-torque branch)
  (* (branch-length branch) (total-weight (branch-structure branch))))

(define (balanced? mobile)
  (= (get-torque (left-branch mobile)) (get-torque (right-branch mobile))))

;;   |
;; -----
;; |   |
;; |   |
;; 2   |
;;     3
(test* "get-torque1"
       5
       (get-torque (make-branch 1
                                (make-mobile (make-branch 2 2)
                                             (make-branch 3 3)))))

(test* "balanced?1"
       #f
       (balanced? (make-mobile (make-branch 2 2)
                               (make-branch 3 3))))

(test* "get-torque2"
       14
       (get-torque (make-branch 2
                                (make-mobile
                                 (make-branch 2
                                              (make-mobile
                                               (make-branch 1 2)
                                               (make-branch 1 2)))
                                 (make-branch 3 3)))))

(test* "get-torque3"
       45
       (get-torque (make-branch 3
                                (make-mobile
                                 (make-branch 3
                                              (make-mobile
                                               (make-branch 2 5)
                                               (make-branch 1 5)))
                                 (make-branch 3 5)))))

(test* "balanced?2"
       #t
       (balanced?
        (make-mobile
         (make-branch 3
                      (make-mobile
                       (make-branch 3
                                    (make-mobile
                                     (make-branch 2 5)
                                     (make-branch 1 5)))
                       (make-branch 3 5)))
         (make-mobile 9
                      (make-mobile
                       (make-branch 2 2)
                       (make-branch 3 3))))))

(test* "balanced?3"
       #f
       (balanced?
        (make-mobile
         (make-branch 3
                      (make-mobile
                       (make-branch 3
                                    (make-mobile
                                     (make-branch 2 5)
                                     (make-branch 1 5)))
                       (make-branch 3 5)))
         (make-mobile 4
                      (make-mobile
                       (make-branch 2 2)
                       (make-branch 3 3))))))

(define test-b
  (make-mobile
   (make-branch 3 6)
   (make-branch 2
                (make-mobile
                 (make-branch 1 4)
                 (make-branch 1 5)))))

(test* "check-balanced"
       #t
       (balanced? test-b))

テストに統一性が無いが他の人のものもそのまま掲載した。

d

この変更に対しては right-branchbranch-structure (cadr でアクセスしていた二つ) を以下のように cdr でアクセスするように変更するだけでよい。

(define (make-mobile left right)
  (cons left right))

(define (make-branch length structure)
  (cons length structure))

(define (right-branch mobile)
  (cdr mobile))

(define (branch-structure branch)
  (cdr branch))

(test* "total-weight-d" 5
       (total-weight (make-mobile (make-branch 2 2) (make-branch 3 3))))

(test* "total-weight-d"
       15
       (total-weight (make-mobile (make-branch 3
                                               (make-mobile (make-branch 2 5)
                                                            (make-branch 1 5)))
                                  (make-branch 3 5))))

(test* "get-torque1-d"
       5
       (get-torque (make-branch 1
                                (make-mobile (make-branch 2 2)
                                             (make-branch 3 3)))))
(test* "get-torque2-d"
       14
       (get-torque (make-branch 2
                                (make-mobile
                                 (make-branch 2
                                              (make-mobile
                                               (make-branch 1 2)
                                               (make-branch 1 2)))
                                 (make-branch 3 3)))))

練習問題 2.30

二倍にする関数を square として定義する。

(define (square x)
  (* x x))
;; 高階関数を使わない版
(define (square-tree1 tree)
  (cond ((null? tree) '())
        ((not (pair? tree)) (square tree))
        (else (cons (square-tree1 (car tree)) (square-tree1 (cdr tree))))))

;; 使う版
(define (square-tree2 tree)
  (map (lambda (sub-tree)
         (if (pair? sub-tree)
             (square-tree2 sub-tree)
             (square sub-tree)))
       tree))

(test-section "ex 2.30")

(test* "square-tree1" '(1 (4 (9 16) 25) (36 49)) (square-tree1 '(1 (2 (3 4) 5) (6 7))))
(test* "square-tree2" '(1 (4 (9 16) 25) (36 49)) (square-tree2 '(1 (2 (3 4) 5) (6 7))))

練習問題 2.31

(define (tree-map proc tree)
  (map (lambda (sub-tree)
         (if (pair? sub-tree)
             (tree-map proc sub-tree)
             (proc sub-tree)))
       tree))

(define (square-tree3 tree)
  (tree-map square tree))

(test-section "ex 2.31")

(test* "square-tree3.a" '(1 (4 (9 16) 25) (36 49)) (square-tree3 '(1 (2 (3 4) 5) (6 7))))
(test* "square-tree3.b" (square-tree1 '(1 (2 (3 4) 5) (6 7))) (square-tree3 '(1 (2 (3 4) 5) (6 7))))

練習問題 2.32

(define (subsets s)
  (if (null? s)
      (list nil)
      (let ((rest (subsets (cdr s))))
        (append rest (map (lambda (e) (cons (car s) e))
                          rest)))))

(test-section "2.32")

(test* "" '(() (3) (2) (2 3) (1) (1 3) (1 2) (1 2 3)) (subsets '(1 2 3)))
(test* "" '(() (2) (1) (1 2)) (subsets '(1 2)))

(subsets '(1 2)) と実行することにする。rest の値を求める為に subsets が繰り返し呼ばれることに注目する。毎回 subsets 引数の s ('(1 2)) が cdr によって小さくなっていくので、一番底の呼び出しである subsets (ここでこの関数を subsets-last と呼ぶ) は '() が渡されることになり、そこでは if の分岐により (list '()) が実行され (()) が返る。この subsets-last の呼び出し元である subtests ではその (())rest に束縛され、そこでは s'(2) が束縛されている。これは (append rest (map (lambda (e) (cons (car s) e)) rest)) によって、(append '(()) '(2)) から (() '(2)) になる。これはまさに '(2) の部分集合である。次にこの subsets を読んでいる subsets がある。これを subsets-top と呼ぶことにする。subsets-top では rest に対して '(() (2)) が束縛され、それに対して subsets-tops ('(1 2)) の先頭である 1 がコンスされ、restappend されることによって (() (2) (1) (1 2)) が作られる。  このようにある集合の全ての部分集合の集合というのは、ある集合の先頭を抜いた集合の全ての部分集合と、それらの部分集合にその先頭を追加したものの集合和という意味になる。(append rest (map (lambda (e) (cons (car s) e)) rest)) というのはまさにそれを表している。