オンラインSICP読書女子会 #29 (2.3.3)

オンラインSICP読書女子会 #29 (2.3.3)

練習問題 2.64 - 2.66

ex-2.64. list->tree

前回の続き〜

ex-2.64 (a) partial-tree の動作詳細と処理結果

a. partial-tree がどのように動くのか、できるだけ明確に文章で答えよ。リスト (1 3 5 7 9 11) に対して list->tree が生成する木を描け。

quotient は商の算出. 剰余は 0 に向かって丸められる (0 に向かって切り捨て).

先に結果の tree 構築結果:

                    5
          +---------+---------+
          1                   7
       +--+--+           +----+----+
      nil    3           9         11
          +--+--+     +--+--+   +--+--+
         nil   nil   nil   nil nil   nil

                 5
               ／ ＼
             ／     ＼
           ／         ＼
         ／             ＼
       ／                 ＼
      1                     7
    ／ ＼                 ／ ＼
  ／     ＼             ／     ＼
 ()        3           9        11
         ／ ＼       ／ ＼    ／  ＼
        ()   ()     ()   ()  ()    ()

続けて動作の説明. 詳細に書いたけど明確かというと…ノω`;

というか原文,

Write a short paragraph explaining as clearly as you can how partial-tree works.

Write a short paragraph …ノω＜；

読み飛ばすときは ex-2.64 (b) ステップ数 までどうぞー＞ヮ＜；

S, L, R はそれぞれ Start, Left, Right.
(n) は後述の「ex-2.64 (b) ステップ数」の実装のコメントに書いてある番号に対応.

• 入力 '(1 3 5 7 9 11)
• [1S#(1)] elts = '(1 3 5 7 9 11), n = 6
• [1S#(-)] ; elts のうち '(1 3 5 7 9 11) を tree に変換する.
• [1S#(-)] ; 復帰値の car は [tree-of '(1 3) 5 '(7 9 11)] になる.
• [1S#(-)] ; 復帰値の cdr は '() になる.
• [1S#(2)] -> else clause へ.
• [1L#(4)] left-size = (quotient (- n 1) 2) = (quotient (- 6 1) 2) = (quotient 5 2) = 2
• [1L#(5)] left-result = (partial-tree elts left-size) = ...
  • [2S#(1)] elts = (1 3 5 7 9 11), n = 2
  • [2S#(-)] ; elts のうち '(1 3) を tree に変換する.
  • [2S#(-)] ; 復帰値の car は [tree-of '() 1 '(3)] になる.
  • [2S#(-)] ; 復帰値の cdr は '(5 7 9 11) になる.
  • [2S#(2)] -> else clause へ.
  • [2L#(4)] left-size = (quotient (- n 1) 2) = (quotient (- 2 1) 2) = (quotient 1 2) = 0
  • [2L#(5)] left-result = (partial-tree elts left-size) = ...
    • [3-#(1)] elts = (1 3 5 7 9 11), n = 0
    • [3-#(-)] ; elts のうち '() を tree に変換する.
    • [3-#(-)] ; 復帰値の car は [empyt-tree] になる.
    • [3-#(-)] ; 復帰値の cdr は '(1 3 5 7 9 11) になる.
    • [3-#(2)] -> then clause へ.
    • [3-#(3)] (cons '() elts) = (cons '() '(1 3 5 7 9 11))
  • [2L#(5)] left-result <- (cons '() '(1 3 5 7 9 11))
  • [2L#(6)] LEFT-TREE = (car left-result) = '() ; "1" から左下に伸びる空の足.
  • [2R#(7)] non-left-elts = (cdr left-result) = '(1 3 5 7 9 11)
  • [2R#(8)] right-size = (- n (+ left-size 1))) = (- 2 (+ 0 1))) = (- 2 1) = 1
  • [2R#(9)] THIS-ENTRY = (car non-left-elts) = 1 ; 節点 "1"
  • [2R#(10)] right-result = (partial-tree (cdr non-left-elts) right-size) = (partial-tree (cdr '(1 3 5 7 9 11)) 1) = (partial-tree '(3 5 7 9 11) 1)
    • [3S#(1)] elts = '(3 5 7 9 11), n = 1
    • [3S#(-)] ; elts のうち '(3) を tree に変換する.
    • [3S#(-)] ; 復帰値の car は [tree-of '() 3 '()] になる.
    • [3S#(-)] ; 復帰値の cdr は '(5 7 9 11) になる.
    • [3S#(2)] -> else clause へ.
    • [3L#(4)] left-size = (quotient (- n 1) 2) = (quotient (- 1 1) 2) = (quotient 1 2) = 0
    • [3L#(5)] left-result = (partial-tree elts left-size) = ...
      • [4-#(1)] elts = (3 5 7 9 11), n = 0
      • [4-#(-)] ; elts のうち '() を tree に変換する.
      • [4-#(-)] ; 復帰値の car は [empty-tree] になる.
      • [4-#(-)] ; 復帰値の cdr は '(5 7 9 11) になる.
      • [4-#(2)] -> then clause へ.
      • [4-#(3)] (cons '() elts) = (cons '() '(3 5 7 9 11))
    • [3L#(5)] left-result <- (cons '() '(3 5 7 9 11))
    • [3L#(6)] LEFT-TREE = (car left-result) = '() ; "3" から左下に伸びる空の足.
    • [3R#(7)] non-left-elts = (cdr left-result) = '(3 5 7 9 11)
    • [3R#(8)] right-size = (- n (+ left-size 1))) = (- 1 (+ 0 1))) = (- 1 1) = 0
    • [3R#(9)] THIS-ENTRY = (car non-left-elts) = 3 ; 節点 "3"
    • [3R#(10)] right-result = (partial-tree (cdr non-left-elts) right-size) = (partial-tree (cdr '(3 5 7 9 11)) 0) = (partial-tree '(5 7 9 11) 0)
      • [4-#(1)] elts = (5 7 9 11), n = 0
      • [4-#(-)] ; elts のうち '() を tree に変換する.
      • [4-#(-)] ; 復帰値の car は [empty-tree] になる.
      • [4-#(-)] ; 復帰値の cdr は '(5 7 9 11) になる.
      • [4-#(2)] -> then clause へ.
      • [4-#(3)] (cons '() elts) = (cons '() '(5 7 9 11))
    • [3R#(10)] right-result = '(() (5 7 9 11))
    • [3R#(11)] RIGHT-TREE = (car right-result) = '()
    • [3R#(12)] remaining-elts = (cdr right-result) = '(5 7 9 11)
    • [3R#(13)] result.car = [tree-of LEFT-TREE THIS-ENTRY RIGHT-TREE] = [tree-of '() 3 '()]
    • [3R#(13)] result.cdr = '(5 7 9 11)
  • [2R#(10)] right-result <- (cons [tree-of '() 3 '()] '(5 7 9 11))
  • [2R#(11)] RIGHT-TREE = (car right-result) = [tree-of '() 3 '()]
  • [2R#(12)] remaining-elts = (cdr right-result) = '(5 7 9 11)
  • [2R#(13)] result.car = [tree-of LEFT-TREE THIS-ENTRY RIGHT-TREE] = [tree-of '() 1 [tree-of '() 3 '()])
  • [2R#(13)] result.cdr = '(5 7 9 11)
• [1L#(5)] left-result <- (cons [tree-of '() 1 [tree-of '() 3 '()]] '(5 7 9 11))
• [1L#(6)] LEFT-TREE = (car left-result) = [tree-of '() 1 [tree-of '() 3 '()]] ; "5" から左下に伸びる部分枝.
• [1R#(7)] non-left-elts = (cdr left-result) = '(5 7 9 11)
• [1R#(8)] right-size = (- n (+ left-size 1))) = (- 6 (+ 2 1))) = (- 6 3) = 3
• [1R#(9)] THIS-ENTRY = (car non-left-elts) = 5 ; 根節点 "5"
• [1R#(10)] right-result = (partial-tree (cdr non-left-elts) right-size) = (partial-tree (cdr '(7 9 11)) 3) = (partial-tree '(7 9 11) 3)
  • [2S#(1)] elts = (7 9 11), n = 3
  • [2S#(-)] ; elts のうち '(7 9 11) を tree に変換する.
  • [2S#(-)] ; 復帰値の car は [tree-of [tree-of '() 7 '()] 9 [tree-of '() 11 '()]] になる.
  • [2S#(-)] ; 復帰値の cdr は '() になる.
  • [2S#(2)] -> else clause へ.
  • [2L#(4)] left-size = (quotient (- n 1) 2) = (quotient (- 3 1) 2) = (quotient 2 2) = 1
  • [2L#(5)] left-result = (partial-tree elts left-size) = ...
    • [3S#(1)] elts = '(7 9 11), n = 1
    • [3S#(-)] ; elts のうち '(7) を tree に変換する.
    • [3S#(-)] ; 復帰値の car は [tree-of '() 7 '()] になる.
    • [3S#(-)] ; 復帰値の cdr は '(9 11) になる.
    • [3S#(2)] -> else clause へ.
    • [3L#(4)] left-size = (quotient (- n 1) 2) = (quotient (- 1 1) 2) = (quotient 1 2) = 0
    • [3L#(5)] left-result = (partial-tree elts left-size) = ...
      • [4-#(1)] elts = (7 9 11), n = 0
      • [4-#(-)] ; elts のうち '() を tree に変換する.
      • [4-#(-)] ; 復帰値の car は [empty-tree] になる.
      • [4-#(-)] ; 復帰値の cdr は '(7 9 11) になる.
      • [4-#(2)] -> then clause へ.
      • [4-#(3)] (cons '() elts) = (cons '() '(7 9 11))
    • [3L#(5)] left-result <- (cons '() '(7 9 11))
    • [3L#(6)] LEFT-TREE = (car left-result) = '() ; "7" から左下に伸びる空の足.
    • [3R#(7)] non-left-elts = (cdr left-result) = '(9 11)
    • [3R#(8)] right-size = (- n (+ left-size 1))) = (- 1 (+ 0 1))) = (- 1 1) = 0
    • [3R#(9)] THIS-ENTRY = (car non-left-elts) = 7 ; 節点 "7"
    • [3R#(10)] right-result = (partial-tree (cdr non-left-elts) right-size) = (partial-tree (cdr '(9 11)) 0) = (partial-tree '(11) 0)
      • [4-#(1)] elts = (9 11), n = 0
      • [4-#(-)] ; elts のうち '() を tree に変換する.
      • [4-#(-)] ; 復帰値の car は [empty-tree] になる.
      • [4-#(-)] ; 復帰値の cdr は '(9 11) になる.
      • [4-#(2)] -> then clause へ.
      • [4-#(3)] (cons '() elts) = (cons '() '(9 11))
    • [3R#(10)] right-result = '(() (9 11))
    • [3R#(11)] RIGHT-TREE = (car right-result) = '()
    • [3R#(12)] remaining-elts = (cdr right-result) = '(9 11)
    • [3R#(13)] result.car = [tree-of LEFT-TREE THIS-ENTRY RIGHT-TREE] = [tree-of '() 7 '()]
    • [3R#(13)] result.cdr = '(9 11)
  • [2L#(5)] left-result <- (cons '() '(9 11))
  • [2L#(6)] LEFT-TREE = (car left-result) = '() ; "9" から左下に伸びる空の足.
  • [2R#(7)] non-left-elts = (cdr left-result) = '(9 11)
  • [2R#(8)] right-size = (- n (+ left-size 1))) = (- 3 (+ 1 1))) = (- 3 2) = 1
  • [2R#(9)] THIS-ENTRY = (car non-left-elts) = 9 ; 節点 "9"
  • [2R#(10)] right-result = (partial-tree (cdr non-left-elts) right-size) = (partial-tree (cdr '(9 11)) 1) = (partial-tree '(11) 1)
    • [3S#(1)] elts = '(11), n = 1
    • [3S#(-)] ; elts のうち '(11) を tree に変換する.
    • [3S#(-)] ; 復帰値の car は [tree-of '() 11 '()] になる.
    • [3S#(-)] ; 復帰値の cdr は '() になる.
    • [3S#(2)] -> else clause へ.
    • [3L#(4)] left-size = (quotient (- n 1) 2) = (quotient (- 1 1) 2) = (quotient 0 2) = 0
    • [3L#(5)] left-result = (partial-tree elts left-size) = ...
      • [4-#(1)] elts = (11), n = 0
      • [4-#(-)] ; elts のうち '() を tree に変換する.
      • [4-#(-)] ; 復帰値の car は [empty-tree] になる.
      • [4-#(-)] ; 復帰値の cdr は '(11) になる.
      • [4-#(2)] -> then clause へ.
      • [4-#(3)] (cons '() elts) = (cons '() '(11))
    • [3L#(5)] left-result <- (cons '() '(11))
    • [3L#(6)] LEFT-TREE = (car left-result) = '() ; "11" から左下に伸びる空の足.
    • [3R#(7)] non-left-elts = (cdr left-result) = '(11)
    • [3R#(8)] right-size = (- n (+ left-size 1))) = (- 1 (+ 0 1))) = (- 1 1) = 0
    • [3R#(9)] THIS-ENTRY = (car non-left-elts) = 11 ; 節点 "11"
    • [3R#(10)] right-result = (partial-tree (cdr non-left-elts) right-size) = (partial-tree (cdr '(11)) 0) = (partial-tree '() 0)
      • [4-#(1)] elts = (), n = 0
      • [4-#(-)] ; elts のうち '() を tree に変換する.
      • [4-#(-)] ; 復帰値の car は [empty-tree] になる.
      • [4-#(-)] ; 復帰値の cdr は '() になる.
      • [4-#(2)] -> then clause へ.
      • [4-#(3)] (cons '() elts) = (cons '() '())
    • [3R#(10)] right-result = '(() ())
    • [3R#(11)] RIGHT-TREE = (car right-result) = '()
    • [3R#(12)] remaining-elts = (cdr right-result) = '()
    • [3R#(13)] result.car = [tree-of LEFT-TREE THIS-ENTRY RIGHT-TREE] = [tree-of '() 11 '()]
    • [3R#(13)] result.cdr = '()
  • [2R#(10)] right-result <- (cons [tree-of '() 11 '()] '())
  • [2R#(11)] RIGHT-TREE = (car right-result) = [tree-of '() 11 '()]
  • [2R#(12)] remaining-elts = (cdr right-result) = '()
  • [2R#(13)] result.car = [tree-of LEFT-TREE THIS-ENTRY RIGHT-TREE] = [tree-of [tree-of '() 7 '()] 9 [tree-of '() 11 '()])
  • [2R#(13)] result.cdr = '()
• [1R#(10)] right-result <- (cons [tree-of [tree-of '() 7 '()] 9[tree-of '() 11 '()]] '())
• [1R#(11)] RIGHT-TREE = (car right-result) = [tree-of [tree-of '() 7 '()] 9 [tree-of '() 11 '()]]
• [1R#(12)] remaining-elts = (cdr right-result) = '()
• [1R#(13)] result.car = [tree-of LEFT-TREE THIS-ENTRY RIGHT-TREE] = [tree-of [tree-of '() 1 [tree-of '() 3 '()]] 5 [tree-of [tree-of '() 7 '()] 9 [tree-of '() 11 '()]]
• [1R#(13)] result.cdr = '()
• 完了!

なが〜い＝ω＝；

頑張って書いたけど読む気力ががo__)o

ex-2.64 (b) ステップ数

b. list->tree が n 要素のリストを変換するのに必要なステップ数の増加オーダはどのようになるだろうか。

後戻りすることなく単純に一度の走査で構築できるので, $O(n)$ で変換できるといえる.

ex-2.64. 実装

; [ex-2.64.scm]
;
(define (ex-2.64)
    (for-each
        (lambda (list)
            (print "---");
            (print "list = " list)
            (print "list->tree = " (list->tree list)))
        (map sort (sample-sources)))
    #t)


(load "./sec-2.3.3-c")


(define (list->tree elements)
    (car (partial-tree elements (length elements))))


(define (partial-tree elts n)                                         ; (1)
    (if
        (= n 0)                                                       ; (2)
        (cons '() elts)                                               ; (3)
        (let ((left-size (quotient (- n 1) 2)))                       ; (4)
            (let ((left-result (partial-tree elts left-size)))        ; (5)
                (let
                    (
                        (left-tree     (car left-result))             ; (6)
                        (non-left-elts (cdr left-result))             ; (7)
                        (right-size    (- n (+ left-size 1)))         ; (8)
                    )
                    (let (
                            (this-entry   (car non-left-elts))        ; (9)
                            (right-result (partial-tree (cdr non-left-elts) right-size))  ; (10)
                        )
                        (let (
                                (right-tree      (car right-result))  ; (11)
                                (remaining-elts (cdr right-result))   ; (12)
                            )
                            (cons                                     ; (13)
                                (make-tree this-entry left-tree right-tree)
                                remaining-elts))))))))

ex-2.64. 実行結果

gosh> (ex-2.64)
---
list = (1 3 5 7 9 11)
list->tree = (5 (1 () (3 () ())) (9 (7 () ()) (11 () ())))
---
list = (1 3 5 7 9 11)
list->tree = (5 (1 () (3 () ())) (9 (7 () ()) (11 () ())))
---
list = (1 3 5 7 9 11)
list->tree = (5 (1 () (3 () ())) (9 (7 () ()) (11 () ())))
---
list = (1 2 3 4 5 6 7)
list->tree = (4 (2 (1 () ()) (3 () ())) (6 (5 () ()) (7 () ()

ex-2.65. 二分木による Θ(n) な集合演算

練習問題 2.63と練習問題 2.64の結果を使って、集合を (バランスの取れた) 二分木として $\Theta(n)$ で実装せよ。

集合の実装に必要なのは以下の 4 つの操作:

1. union-set
2. intersection-set
3. element-of-set?
4. adjoin-set

$\Theta(n)$ でっていうのは 4 つすべてを $\Theta(n)$ 以下でということ…？・ｘ・；

そもそも $\Theta$ ってオーダーのどれだっけ…ってことで定義よみよみ

大きさ $n$ の問題についてプロセスが必要とするリソースの量を $R(n)$ とします。
...
任意の十分に大きな $n$ に対して、 $n$ と独立な正の定数 $k_1$ と $k_2$ が存在し、任意の十分に大きな $n$ に対して、 $n$ と独立な正の定数 $k_1$ と $k_2$ が存在し、 $k_1 f(n) \le R(n) \le k_2 f (n)$ を満たすとき、 $R(n)$ は増加オーダーが $\Theta(f(n))$ であると言い、 $R(n) = \Theta(f(n))$ と書きます。
(1.2.3 増加オーダー (p.44) より)

2.3.3 (b) 順序つき unique リストとしての集合, 練習問題 2.61, 練習問題 2.62 で作った順序付きuniqueリストの実装を使うと, 4 つ全てでちょうど $\Theta(n)$ のオーダーになっているのでこれを基本に利用することにする.

そして練習問題 2.63 (b) で確認したようにその tree->list-2 は $\Theta(n)$ でバランスされた木を元に順序付き unique リストに変換でき,
練習問題 2.64 で提示された list->tree は順序付き unique リストを元に $\Theta(n)$ でバランスされた二分木を構築できる.

1. (union-set set1 set2).

以下のように実装する:

(define (union-set tree1 tree2)
    (list->tree
        ; oul- は ordered-unique-list の略. 以下同様.
        (oul-union-set
            (tree->list tree1)
            (tree->list tree2))))

ステップ数は tree->list 部分が $\Theta(length(tree1) + length(tree2))$ で $length(tree1) + length(tree2) = n$ なので合計 $\Theta(n)$.
oul-union-set list1 list2 部分が $\Theta(n)$.
list->tree 部分が $\Theta(n)$.
それぞれの箇所は内部処理中で再帰しているわけではないので単純に加算しあえばよいので $\Theta(n + n + n) = \Theta(3 * n) = \Theta(n)$ で処理できる.

2. intersection-set

(define (intersection-set tree1 tree2)
    (list->tree
        (oul-intersection-set
            (tree->list tree1)
            (tree->list tree2))))

処理量については (1) (union-set set1 set2) の場合と同様で $\Theta(3 * n) = \Theta(n)$.

3. element-of-set?

順序付き unique リストに変換することで $\Theta(n)$ での処理が可能.
しかし二分岐を素直に辿る実装を書き下ろすことで $\Theta(\log{n})$ の処理量を実現できる.
そしてその手順は「2.3.3 (c) 二分木としての集合」にて既に提示されている.

(define (element-of-set? x set)
    (cond
        ((null? set) #f)
        ((= x (entry set)) #t)
        ((< x (entry set)) (element-of-set? x (left-branch set)))
        ((> x (entry set)) (element-of-set? x (right-branch set)))))

4. adjoin-set

(define (adjoin-set elem tree)
    (list->tree
        (oul-adjoin-set elem (tree->list tree))))

処理量については (1) (union-set set1 set2) と同様で $\Theta(3 * n) = \Theta(n)$.

ex-2.65. 実装

;  [ex-2.65.scm]
;
(define (ex-2.65)
    (print "(adjoin-set 1 '())")
    (print ";==> " (adjoin-set 1 '()))
    (print "(fold adjoin-set '() (list 1 2 3 4 5))")
    (print ";==> " (fold adjoin-set '() (list 1 2 3 4 5)))
    (print "(union-set (fold adjoin-set '() (list 7 3 1 2)) (fold adjoin-set '() (list 5 6 4)))")
    (print ";==> " (union-set (fold adjoin-set '() (list 7 3 1 2)) (fold adjoin-set '() (list 5 6 4))))
    (print "(intersection-set (fold adjoin-set '() (list 1 3 5 7 9)) (fold adjoin-set '() (list 2 3 5 7 11)))")
    (print ";==> " (intersection-set (fold adjoin-set '() (list 1 3 5 7 9)) (fold adjoin-set '() (list 2 3 5 7 11))))
    #t)


; `tree->list` には 「ex-2.63. tree->list の 2 つの実装」の `tree->list-2` を
; 使用.
(define (tree->list tree) (tree->list-2 tree))


(define (bintree-union-set tree1 tree2)
    (list->tree
        (oul-union-set
            (tree->list tree1)
            (tree->list tree2))))


(define (bintree-intersection-set tree1 tree2)
    (list->tree
        (oul-intersection-set
            (tree->list tree1)
            (tree->list tree2))))


; bintree-element-of-set? は「2.3.3 (c) 二分木としての集合」の実装をそのまま使用.
(define (bintree-element-of-set? elem tree)
    (cond
        ((null? tree) #f)
        ((= elem (entry tree)) #t)
        ((< elem (entry tree)) (bintree-element-of-set? elem (left-branch tree)))
        ((> elem (entry tree)) (bintree-element-of-set? elem (right-branch tree)))))


(define (bintree-adjoin-set elem tree)
    (list->tree
        (oul-adjoin-set elem (tree->list tree))))


; alias.
(define union-set        bintree-union-set)
(define intersection-set bintree-intersection-set)
(define element-of-set?  bintree-element-of-set?)
(define adjoin-set       bintree-adjoin-set)


; 「2.3.3 (b) 順序つきリストとしての集合」より.
;
(define (oul-element-of-set? x set)
    (cond
        ((null? set) #f)
        ((= x (car set)) #t)
        ((< x (car set)) #f)
        (else (oul-element-of-set? x (cdr set)))))


; 「2.3.3 (b) 順序つきリストとしての集合」より.
;
(define (oul-intersection-set set1 set2)
    (if (or (null? set1) (null? set2))
        ()
        (let ((x1 (car set1)) (x2 (car set2)))
            (cond
                ((= x1 x2) (cons x1 (oul-intersection-set (cdr set1) (cdr set2))))
                ((< x1 x2) (oul-intersection-set (cdr set1) set2))
                ((< x2 x1) (oul-intersection-set set1 (cdr set2)))))))


; 「ex-2.61. adjoin-set の実装」より.
;
(define (oul-adjoin-set x set)
    (cond
        ((null? set) (list x))
        ((= x (car set)) set)
        ((< x (car set)) (cons x set))
        (else (cons (car set) (oul-adjoin-set x (cdr set))))))


; 「ex-2.62. union-set の実装」より.
;
(define (oul-union-set set1 set2)
    (cond
        ((null? set1) set2)
        ((null? set2) set1)
        (else
            (let ((x1 (car set1)) (x2 (car set2)))
                (cond
                    ((= x1 x2)
                        (cons x1 (oul-union-set (cdr set1) (cdr set2))))
                    ((< x1 x2)
                        (cons x1 (oul-union-set (cdr set1) set2)))
                    ((< x2 x1)
                        (cons x2 (oul-union-set set1 (cdr set2)))))))))


; 「2.3.3 (c) 二分木としての集合」より.
;
(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))


; 「ex-2.63. tree->list の 2 つの実装」より.
;
(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 '()))


; 「ex-2.64 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))))))))

ex-2.65. 実行結果

gosh> (ex-2.65)
(adjoin-set 1 '())
;==> (1 () ())
(fold adjoin-set '() (list 1 2 3 4 5))
;==> (3 (1 () (2 () ())) (4 () (5 () ())))
(union-set (fold adjoin-set '() (list 7 3 1 2)) (fold adjoin-set '() (list 5 6 4)))
;==> (4 (2 (1 () ()) (3 () ())) (6 (5 () ()) (7 () ())))
(intersection-set (fold adjoin-set '() (list 1 3 5 7 9)) (fold adjoin-set '() (list 2 3 5 7 11)))
;==> (5 (3 () ()) (7 () ()))
#t

sec-2.3.3 (d) 集合と情報検索

sec-2.3.3 (d) 実装

; [sec-2.3.3-d.scm]
;
(define (sec-2.3.3-d)
    (print "(sample-records)")
    (print ";==> " (sample-records))
    (print "(lookup 'one (sample-records))")
    (print ";==> " (lookup 'one (sample-records)))
    (print "(lookup 'three (sample-records))")
    (print ";==> " (lookup 'three (sample-records)))
    (print "(lookup 'inf (sample-records))")
    (print ";==> " (lookup 'inf (sample-records)))
    #t)


(define (key sample-record)
    (car sample-record))


(define (sample-records)
    (list
        (list 'one 1)
        (list 'two 2)
        (list 'three 3)
        ))


(define (lookup given-key set-of-records)
    (cond
        ((null? set-of-records)
            #f)
        ((equal? given-key (key (car set-of-records)))
            (car set-of-records))
        (else
            (lookup given-key (cdr set-of-records)))))

sec-2.3.3 (d) 実行結果

gosh> (sec-2.3.3-d)
(sample-records)
;==> ((one 1) (two 2) (three 3))
(lookup 'one (sample-records))
;==> (one 1)
(lookup 'three (sample-records))
;==> (three 3)
(lookup 'inf (sample-records))
;==> #f

ex-2.66. 二分木によるレコード集合の実装

レコードの集合が、キーの数値の大小によって順序づけられた二分木という構造になっている場合について、 lookup 手続きを実装せよ。

二分木は ex-2.65 のものをベースに使用.

ex-2.66. 実装

; [ex-2.66.scm]
;
(define (ex-2.66)
    (print "(sample-records)")
    (print ";==> " (sample-records))
    (print "(lookup 1 (sample-records))")
    (print ";==> " (lookup 1 (sample-records)))
    (print "(lookup 3 (sample-records))")
    (print ";==> " (lookup 3 (sample-records)))
    (print "(lookup 99 (sample-records))")
    (print ";==> " (lookup 99 (sample-records)))
    #t)


(define (key sample-record)
    (car sample-record))


(define (sample-records)
    (fold
        adjoin-set
        '()
        (list
            (list 1 'one)
            (list 2 'two)
            (list 3 'three))))


; lookup には「2.3.3 (c) 二分木としての集合」の element-of-set? の実装を
; ベースに key セレクタの適用を追加と, 見つかった場合は #t ではなく
; 見つかった要素そのものを返すように変更.
(define (bintree2-lookup elem-key tree)
    (cond
        ((null? tree) #f)
        ((= elem-key (key (entry tree))) (entry tree))
        ((< elem-key (key (entry tree))) (bintree2-lookup elem-key (left-branch tree)))
        ((> elem-key (key (entry tree))) (bintree2-lookup elem-key (right-branch tree)))))


; 「ex-2.65. 二分木による $\Theta(n)$ な集合演算」より.
; 要素比較時に key セレクタを適用する版の順序付き unique リストによる集合実装
; (後述) を使用.
;
(define (bintree2-adjoin-set elem tree)
    (list->tree
        (oul2-adjoin-set elem (tree->list tree))))


; 「ex-2.61. adjoin-set の実装」より.
; 要素比較時に key セレクタを適用.
;
(define (oul2-adjoin-set x set)
    (cond
        ((null? set) (list x))
        (else
            (let
                (
                    (x-key (key x))
                    (car-key (key (car set)))
                )
                (cond
                    ((= x-key car-key) set)
                    ((< x-key car-key) (cons x set))
                    ((> x-key car-key) (cons (car set) (oul2-adjoin-set x (cdr set)))))))))


; 「2.3.3 (c) 二分木としての集合」より.
;
(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))


; `tree->list` には 「ex-2.63. tree->list の 2 つの実装」の `tree->list-2` を
; 使用.
(define (tree->list tree) (tree->list-2 tree))


; 「ex-2.63. tree->list の 2 つの実装」より.
;
(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 '()))


; 「ex-2.64 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))))))))


; alias.
(define adjoin-set bintree2-adjoin-set)
(define lookup     bintree2-lookup)

ex-2.66. 実行結果

gosh> (ex-2.66)
(sample-records)
;==> ((2 two) ((1 one) () ()) ((3 three) () ()))
(lookup 1 (sample-records))
;==> (1 one)
(lookup 3 (sample-records))
;==> (3 three)
(lookup 99 (sample-records))
;==> #f
#t