Scheme - データによる抽象の構築(記号データ(例: Huffman 符号化木(記号と頻度の対のリスト, 木の生成)))

計算機プログラムの構造と解釈[第2版]
(翔泳社)
ハロルド エイブルソン (著) ジュリー サスマン (著)
ジェラルド・ジェイ サスマン (著)
Harold Abelson (原著) Julie Sussman (原著)
Gerald Jay Sussman (原著) 和田 英一 (翻訳)

開発環境

• OS X Yosemite - Apple (OS)
• Emacs(Text Editor)
• Scheme (プログラミング言語)
• kscheme, Gauche, GNU Guile (処理系)

計算機プログラムの構造と解釈[第2版](ハロルド エイブルソン (著)、ジュリー サスマン (著)、ジェラルド・ジェイ サスマン (著)、Harold Abelson (原著)、Julie Sussman (原著)、Gerald Jay Sussman (原著)、和田 英一 (翻訳)、翔泳社、原書: Structure and Interpretation of Computer Programs (MIT Electrical Engineering and Computer Science)(SICP))の2(データによる抽象の構築)、2.3(記号データ)、2.3.4(例: Huffman 符号化木)、問題2.69.を解いてみる。

その他参考書籍

• Instructor's Manual to Accompany Structure & Interpretation of Computer Programs
• プログラミングGauche (Kahuaプロジェクト (著), 川合 史朗 (監修), オライリージャパン)
• Scheme手習い

問題2.69.

コード(Emacs)

(define make-leaf
  (lambda (symbol weight)
    (list (quote leaf) symbol weight)))
 
(define leaf?
  (lambda (object)
    (eq? (car object) (quote leaf))))
(define symbol-leaf (lambda (x) (cadr x)))
(define weight-leaf (lambda (x) (caddr x)))
(define left-branch (lambda (tree) (car tree)))
(define right-branch (lambda (tree) (cadr tree)))
(define symbols
  (lambda (tree)
    (if (leaf? tree)
        (list (symbol-leaf tree))
        (caddr tree))))
(define weight
  (lambda (tree)
    (if (leaf? tree)
        (weight-leaf tree)
        (cadddr tree))))
(define make-code-tree
  (lambda (left right)
    (list left
          right
          (append (symbols left)
                  (symbols right))
          (+ (weight left)
             (weight right)))))

(define generate-huffman-tree
  (lambda (pairs)
    (successive-merge (make-leaf-set pairs))))

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

(define make-leaf-set
  (lambda (pairs)
    (if (null? pairs)
        (quote ())
        (let ((pair (car pairs)))
          (adjoin-set (make-leaf (car pair)
                                 (cadr pair))
                      (make-leaf-set (cdr pairs)))))))

(define adjoin-set
  (lambda (x set)
    (cond ((null? set) (list x))
          ((< (weight x)
              (weight (car set)))
           (cons x set))
          (else (cons (car set)
                      (adjoin-set x
                                  (cdr set)))))))

(define pairs (list (list (quote A) 8)
                    (list (quote B) 3)
                    (list (quote C) 1)
                    (list (quote D) 1)
                    (list (quote E) 1)
                    (list (quote F) 1)
                    (list (quote G) 1)
                    (list (quote H) 1)))
(define tree (generate-huffman-tree pairs))

(define print (lambda (x) (display x) (newline)))
(define print-tree
  (lambda (tree)
    (if (leaf? tree)
        (print tree)
        (begin (print-tree (left-branch tree))
               (print (cddr tree))
               (print-tree (right-branch tree))))))
(begin (newline)
       (print-tree tree))               

入出力結果(Terminal(kscheme), REPL(Read, Eval, Print, Loop))

$ kscheme < sample69.scm
kscm> kscm> kscm> kscm> kscm> kscm> kscm> kscm> kscm> kscm> kscm> kscm> kscm> kscm> kscm> kscm> kscm> kscm> 
(leaf A 8)
((A H G F E D C B) 17)
(leaf H 1)
((H G) 2)
(leaf G 1)
((H G F E) 4)
(leaf F 1)
((F E) 2)
(leaf E 1)
((H G F E D C B) 9)
(leaf D 1)
((D C) 2)
(leaf C 1)
((D C B) 5)
(leaf B 3)
#<undefined>
kscm> $