SICP 読み (47) 2.3.4 例: Huffman 符号化木

scheme SICP

考え続けてはいるんですが、さすがに集中できん連休中は。
と言いつつスデに連休も明け、ばたばたしている間にこんな時間。(昨晩の独り言)

問題 2.69

何のためなんだ、と思っていた weight という手続きがようやく日の目を見るのか。

それは良いのですが、具体的な手続きが思いつかん。試験ドリブンでやってみる。とりあえず、こんな試験を。

  (assert-equal '((leaf B 1) (leaf A 1) (B A) 2)
                (successive-merge '((leaf A 1) (leaf B 1))))

通すのみであればこれで大丈夫。

(define (successive-merge l)
 (make-code-tree (cadr l) (car l)))

あるいは

  (assert-equal '((leaf C 1) ((leaf B 1) (leaf A 1) (B A) 2) (C B A) 3)
                (successive-merge '((leaf A 1) (leaf B 1) (leaf C 1))))

だったらこんなカンジですか。

(define (successive-merge l)
 (if (= (length l) 2)
     (make-code-tree (cadr l) (car l))
     (make-code-tree (caddr l)
                     (make-code-tree (cadr l) (car l)))))

こんな事をいつまで続けててもキリがない。現時点の実装では重みの判断が全然ないな。例えば例示されているナニで言えば

(make-code-tree (leaf A 8)
              (make-code-tree
               (make-code-tree (leaf B 3)
                               (make-code-tree (leaf C 1)
                                               (leaf D 1)))
               (make-code-tree (make-code-tree (leaf E 1)
                                               (leaf F 1))
                               (make-code-tree (leaf G 1)
                                               (laef H 1)))))

な手続き、にならないとイケナイんだけども。(困

うーん。問題文によれば

successive-merge は自分で書く手続きで、make-code-tree を使い、集合の最小重みの順に合体させ、要素が一つになったら止める。

とある。(他にも参考になった記述があったのですが、引用は略)

とりあえず、重みが最初の要素と同じ間、な繰り返しが必要か。紙の上で検証してみても大体は合っているみたい。方針は以下。

  • 引数で受けたリストを修正しながら処理を進める。最終的に length が 1 になったら終了すれば良い
  • 先に先頭二つの make-code-tree はやっておく
  • 要素が二つだけの場合は merge の先頭に戻る。(処理終了)
  • 要素が三つだった場合、make-code-tree の結果リストに cddr を append して先頭に戻る (要素は二つになる)
  • 要素が四以上ある場合は繰り返しにおいて、(weight 先頭) と三番目以降の要素の weight が同じ値であれば、その要素とその後の要素を make-code-tree する

同じリストを使い回す、という方針 (戦略??) が微妙だったのか、リストの扱いでハマりまくってしまいました。

で、現時点での実装は以下なんですが

(define (successive-merge l)
 (let f ((l l))
  (if (= (length l) 1)
      (car l)
      (let g ((w (weight (car l)))
              (ll (cddr l))
              (ret (list (make-code-tree (cadr l) (car l)))))
        (cond ((null? ll) (f ret))
              ((null? (cdr ll))
               (f (append ret ll)))
              ((= w (weight (car ll)))
               (g w (cddr ll) (append ret (list (make-code-tree (cadr ll) (car ll))))))
              (else
               (f (append ret ll))))))))

なんか微妙。以下の試験はパスしている模様。

  (assert-equal '((leaf B 1) (leaf A 1) (B A) 2)
                (successive-merge '((leaf A 1) (leaf B 1))))
  (assert-equal '((leaf C 1) ((leaf B 1) (leaf A 1) (B A) 2) (C B A) 3)
                (successive-merge '((leaf A 1) (leaf B 1) (leaf C 1))))

  (assert-equal '((leaf A 3) ((leaf B 1) (leaf C 1) (B C) 2) (A B C) 5)
                (successive-merge '((leaf C 1) (leaf B 1) (leaf A 3))))
  (assert-equal '((leaf A 8) (((leaf B 3) ((leaf C 1) (leaf D 1) (C
D) 2) (B C D) 5) (((leaf E 1) (leaf F 1) (E F) 2) ((leaf G 1) (leaf H
1) (G H) 2) (E F G H) 4) (B C D E F G H) 9) (A B C D E F G H) 17)
                (successive-merge '((leaf H 1) (leaf G 1) (leaf F 1)
                                    (leaf E 1) (leaf D 1) (leaf C 1)
                                    (leaf B 3) (leaf A 8))))

手続きを見直すリキは今んトコ無い。