Scheme - データによる抽象の構築(記号データ(例: Huffman 符号化木(encode)))

計算機プログラムの構造と解釈[第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.68.を解いてみる。

その他参考書籍

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

問題2.68.

コード(Emacs)

(define for-each
  (lambda (proc items)
    (if (not (null? items))
        (begin (proc (car items))
               (for-each proc (cdr items)))
        (quote done))))
(define print (lambda (x) (display x) (newline)))
(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 make-code-tree
  (lambda (left right)
    (list left
          right
          (append (symbols left)
                  (symbols right))
          (+ (weight left)
             (weight right)))))
(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 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"))
          ((eq? symbol (car (symbols tree)))
           (cons 0
                 (encode-symbol symbol
                                (left-branch tree))))
          (else (cons 1
                      (encode-symbol symbol
                                     (right-branch tree)))))))
(define decode
  (lambda (bits tree)
    (define decode-1
      (lambda (bits current-branch)
        (if (null? bits)
            (quote ())
            (let ((next-branch
                   (chose-branch (car bits) current-branch)))
              (if (leaf? next-branch)
                  (cons (symbol-leaf next-branch)
                        (decode-1 (cdr bits) tree))
                  (decode-1 (cdr bits) next-branch))))))
    (decode-1 bits tree)))

(define chose-branch
  (lambda (bit branch)
    (cond ((= bit 0) (left-branch branch))
          ((= bit 1) (right-branch branch)))))

(define sample-tree
  (make-code-tree (make-leaf (quote A) 4)
                  (make-code-tree (make-leaf (quote B) 2)
                                  (make-code-tree (make-leaf (quote D) 1)
                                                  (make-leaf (quote C) 1)))))
(define sample-message (quote (0 1 1 0 0 1 0 1 0 1 1 1 0 )))

(define decoded (decode sample-message sample-tree))
(define encoded (encode decoded sample-tree))
(define re-decoded (decode encoded sample-tree))

(begin (newline)
       (for-each print
                 (list decoded
                       encoded
                       sample-message
                       re-decoded)))

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

$ kscheme < sample68.scm
kscm> kscm> kscm> kscm> kscm> kscm> kscm> kscm> kscm> kscm> kscm> kscm> kscm> kscm> kscm> kscm> kscm> kscm> kscm> kscm> kscm> 
(A D A B B C A)
(0 1 1 0 0 1 0 1 0 1 1 1 0)
(0 1 1 0 0 1 0 1 0 1 1 1 0)
(A D A B B C A)
done
kscm> $