SICP ex 2.67, 2.68, 2.69, 2.70, 2.71 Huffman符号木

;; Huffman符号木
(define (make-leaf symbol weight)
  (list 'leaf symbol weight))
(define (leaf? object)
  (eq? (car object) 'leaf))
(define (symbol-leaf x) (cadr x))
(define (weight-leaf x) (caddr x))
(define (make-code-tree left right)
  (list left
        right
        (append (symbols left) (symbols right))
        (+ (weight left) (weight right))))
(define (left-branch tree) (car tree))
(define (right-branch tree) (cadr tree))
(define (symbols tree)
  (if (leaf? tree)
      (list (symbol-leaf tree))
      (caddr tree)))
(define (weight tree)
  (if (leaf? tree)
      (weight-leaf tree)
      (cadddr tree)))
(define (decode bits tree)
  (define (decode-1 bits current-branch)
    (if (null? bits)
        '()
        (let ((next-branch
               (choose-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 (choose-branch bit branch)
  (cond ((= bit 0) (left-branch branch))
        ((= bit 1) (right-branch branch))
        (else (error "bad bit -- CHOOSE-BRANCH" bit))))
(define (adjoin-set 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 (make-leaf-set pairs)
  (if (null? pairs)
      '()
      (let ((pair (car pairs)))
        (adjoin-set (make-leaf (car pair)
                               (cadr pair))
                    (make-leaf-set (cdr pairs))))))

;; sicp ex 2.67
(define sample-tree
  (make-code-tree (make-leaf 'A 4)
                  (make-code-tree
                   (make-leaf 'B 2)
                   (make-code-tree (make-leaf 'D 1)
                                   (make-leaf 'C 1)))))
(define sample-message '(0 1 1 0 0 1 0 1 0 1 1 1 0))

;; 実行結果
;; gosh> (decode sample-message sample-tree)
;; (A D A B B C A)

;; sicp ex 2.68
(define (encode message tree)
  (if (null? message)
      '()
      (append (encode-symbol (car message) tree)
             (encode (cdr message) tree))))

;; これいらなかった。結局
;; (define (choose-branch-by-symbol symbol branch)
;;   (cond ((element-of-set? symbol (symbols (left-branch branch))) (left-branch branch))
;;         ((element-of-set? symbol (symbols (right-branch branch))) (right-branch branch))
;;         (else (error "bad symbol -- CHOOSE-BRANCH-BY-SYMBOL" symbol))))

(define (element-of-set? symbol symbols)
  (cond ((null? symbols) #f)
        ((eq? symbol (car symbols)) #t)
        (else (element-of-set? symbol (cdr symbols)))))

(define (encode-symbol symbol tree)
  (if (leaf? tree)
      '()
      (cond ((element-of-set? symbol (symbols (left-branch tree)))
             (cons 0 (encode-symbol symbol (left-branch tree))))
            ((element-of-set? symbol (symbols (right-branch tree)))
             (cons 1 (encode-symbol symbol (right-branch tree))))
            (else (error "bad symbol -- ENCODE-SYMBOL" symbol)))))

;; sicp ex 2.69
(define (generate-huffman-tree pairs)
  (successive-merge (make-leaf-set pairs)))
;; 上の successive-merge を実装する
;; pairsには順序づけられた集合が入っている
;; ex 
;; gosh> (make-leaf-set '((A 4) (B 2) (C 1) (D 1)))
;; ((leaf D 1) (leaf C 1) (leaf B 2) (leaf A 4))
;; まず、weightの軽い順に順序づけられた集合でpairsは与えられるので、
;; 前二つを使ってmake-code-treeによってブランチを作る。
;; それと残りとの集合をadjoin-setによって得る。この集合はadjoin-setによりまた順序づけらている。
;; 要素が１つのリストができるまでそれを繰り返せばよい。
;; よってsuccessive-mergeの実装は以下
(define (successive-merge pairs)
  (if (null? (cdr pairs))
      (car pairs)
      (successive-merge (adjoin-set (make-code-tree (car pairs)
                                                    (cadr pairs))
                                    (cddr pairs)))))

;; sicp ex 2.70
(define tree-2.70 (generate-huffman-tree '((A 2) (NA 16) (BOOM 1) (SHA 3) (GET 2) (YIP 9) (JOB 2) (WAH 1))))
(define message-2.70
  '(GET A JOB SHA NA NA NA NA NA NA NA NA
        GET A JOB SHA NA NA NA NA NA NA NA NA
        WAH YIP YIP YIP YIP YIP YIP YIP YIP YIP
        SHA BOOM))
;; 実行結果
;;gosh> (encode message-2.70 tree-2.70)
;;(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)
;; 確認
;;gosh> (define encoded (encode message-2.70 tree-2.70))
;;encoded
;;gosh> (decode encoded tree-2.70)
;;(GET A JOB SHA NA NA NA NA NA NA NA NA GET A JOB SHA NA NA NA NA NA NA NA NA WAH YIP YIP YIP YIP YIP YIP YIP YIP YIP SHA BOOM)
;;
;; 符号化に何ビット必要か？
;;gosh> (length encoded)
;;84
;; というわけで、84ビット必要
;;
;; 固定長符号を使う場合、符号の数が8つなので、１つの符号に3ビット必要。
;; messageの長さが
;;gosh> (length '(GET A JOB SHA NA NA NA NA NA NA NA NA GET A JOB SHA NA NA NA NA NA NA NA NA WAH YIP YIP YIP YIP YIP YIP YIP YIP YIP SHA BOOM))
;;36
;; と36なので
;; 36 * 3 = 108ビット必要
;; この結果から、可変長符号を使うことで節約ができていることがわかる。約２２％の節約。

;; sicp ex 2.71
;; 1,2,4...2^(n-1)
;; 記号のn番目の相対頻度が2^(n-1)で表されるとき、
;; n番目の相対頻度は、n-1番目までの相対頻度をすべて足したものよりも大きい。
;; よって、木は片側にどんどんのびて、各branchのもう片方は絶対にleafになるような木になる。
;; こういう木の時、最高頻度の記号では1ビットで、最低頻度の記号ではn-1ビット必要になる。

2.72は何となくはわかるものの、ちょっと不鮮明。
もうちょっと考えます。

やる前は、ちょっとできるかなと心配だったけど、
やってみたら思いのほかできた。

よしよし。