SICP問題2.69

教科書で定義されている手続き

(define (make-leaf-set pairs)
  (if (null? pairs)
      '()
      (let ((pair (car pairs)))
	(adjoin-set (make-leaf (car pair)   ; 記号
			       (cadr pair)) ; 頻度
		    (make-leaf-set (cdr pairs))))))
(define (make-code-tree left right)
  (list left
        right
        (append (symbols left) (symbols right))
        (+ (weight left) (weight right))))
; Huffman符号化木の生成
(define (generate-huffman-tree pairs)
  (successive-merge (make-leaf-set pairs)))

make-code-treeを使い集合の最小重みの要素を順に合体させ、要素が一つになったら止めるsuccessive-merge手続き。
考え方としては以下のようにmake-leaf を実行した時点で最小重みの要素順に葉は並んでいる

(make-leaf-set (list (cons 'A '(4)) (cons 'B '(2)) (cons 'C '(1)) (cons 'D '(1)) (cons 'E '(5))))
; ((leaf D 1) (leaf C 1) (leaf B 2) (leaf A 4) (leaf E 5))

ので、 make-code-tree で make-leaf-set の結果を順番にくっつけてけば良いと思われる。
というわけで定義

(define (successive-merge leaves)
  (define (iter sub-leaves tree)
    (if (null? sub-leaves)
	tree
	(iter (cdr sub-leaves) (make-code-tree (car sub-leaves) tree))))
  (iter (cdr leaves) (car leaves)))

テスト

(print (generate-huffman-tree (list (cons 'A '(4)) (cons 'B '(2)) (cons 'C '(1)) (cons 'D '(1)) (cons 'E '(5)))))
; ((leaf E 5) ((leaf A 4) ((leaf B 2) ((leaf C 1) (leaf D 1) (C D) 2) (B C D) 4) (A B C D) 8) (E A B C D) 13)
; #<undef>

でOK
と思ったが、問題で

この手続きは多少ややこしいが複雑ではない。複雑な手続きを設計していると思ったら、確実にどこか間違っている。順序付けられた集合の表現を使っていることを活用しなければならない

と書かれていたので他の人のをカンニング。
(今見るとInternal Server Error になっていますが)

make-leaf-setは葉を重みの小さい順に順序づけたリストを返すので、やるべき事は

1. 最初の２葉を make-code-tree で結合する
2. 結合してできた木を、３要素目以降の葉リストに adjoin-set する
3. リストに要素が１つしかなくなるまで繰り返す

実装：

(define (successive-merge leaf-set)
  (if (null? (cdr leaf-set))
      (car leaf-set)
      (successive-merge (adjoin-set (make-code-tree (car leaf-set)
                                                    (cadr leaf-set))
                                    (cddr leaf-set)))))

SICP memo:問題2.69

とかになってますねぇ。
結果は同じになりますが、こちらの方が全然素直です。