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.70.を解いてみる。

その他参考書籍

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

問題2.70.

コード(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 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))))))

(define encode
  (lambda (message tree)
    (if (null? message)
        (quote ())
        (append (encode-symbol (car message) tree)
                (encode (cdr message) tree)))))
(define encode-symbol
  (lambda (symbol tree)
    (cond ((and (leaf? tree)
                (eq? symbol (symbol-leaf tree)))
           (quote ()))          
          ((leaf? tree) (display "error"))
          ((memq symbol (symbols (left-branch tree)))
           (cons 0
                 (encode-symbol symbol
                                (left-branch tree))))
          ((memq symbol (symbols (right-branch tree)))
           (cons 1
                 (encode-symbol symbol
                                (right-branch tree))))
          (else (display "error")))))

(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) 2)
                    (list (quote NA) 16)
                    (list (quote BOOM) 1)
                    (list (quote SHA) 3)
                    (list (quote GET) 2)
                    (list (quote YIP) 9)
                    (list (quote JOB) 2)
                    (list (quote WAH) 1)))

(define tree (generate-huffman-tree pairs))

(define message (list (quote GET)
                      (quote A)
                      (quote JOB)
                      (quote SHA)
                      (quote NA)
                      (quote NA)
                      (quote NA)
                      (quote NA)
                      (quote NA)
                      (quote NA)
                      (quote NA)
                      (quote NA)
                      (quote GET)
                      (quote A)
                      (quote JOB)
                      (quote SHA)
                      (quote NA)
                      (quote NA)
                      (quote NA)
                      (quote NA)
                      (quote NA)
                      (quote NA)
                      (quote NA)
                      (quote NA)
                      (quote WAH)
                      (quote YIP)
                      (quote YIP)
                      (quote YIP)
                      (quote YIP)
                      (quote YIP)
                      (quote YIP)
                      (quote YIP)
                      (quote YIP)
                      (quote YIP)
                      (quote SHA)
                      (quote BOOM)))

(define encoded (encode message tree))

(begin (newline)
       (print "Huffman 木の場合")
       (print encoded)
       (print (length encoded))
       (print "8記号アルファベットの固定長符号の場合")
       (print (* 3 (length message))))

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

$ kscheme < sample70.scm
kscm> kscm> kscm> kscm> kscm> kscm> kscm> kscm> kscm> kscm> kscm> kscm> kscm> kscm> kscm> kscm> kscm> kscm> kscm> kscm> kscm> kscm> 
Huffman 木の場合
(1 1 1 1 1 1 1 0 0 1 1 1 1 0 1 1 1 0 0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 0 0 1 1 1 1 0 1 1 1 0 0 0 0 0 0 0 0 0 1 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 1 1 0 1 1 0 1 1)
84
8記号アルファベットの固定長符号の場合
108
#<undefined>
kscm> $