Hatena::Groupcadr

わだばLisperになる このページをアンテナに追加 RSSフィード

2004 | 12 |
2005 | 01 | 02 | 07 | 10 | 11 |
2006 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2007 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2008 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2009 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2010 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2011 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 11 |

2008-03-31

ArcでL-99 (P50 ハフマン符号化)

| 20:35 | ArcでL-99 (P50 ハフマン符号化) - わだばLisperになる を含むブックマーク はてなブックマーク - ArcでL-99 (P50 ハフマン符号化) - わだばLisperになる

算術と符号化篇の最後である、今回のお題は、ハフマン符号化です。

出現頻度の高いものには、より短い符号を与えることにより圧縮を実現する符号化のようで、LHAや、JPEG等の圧縮で用いられているそうです。

(huffman-table '(a b c d e f g g g g g e))
;=> ((g "1") (f "011") (c "0101") (d "0100") (a "0011") (b "0010") (e "000"))

;; ----
(def freq (lst)
  (let h (table)
    (each item lst 
      (if (h item)
          (++ (h item))
          (= (h item) 1)))
    (tablist h)))

;(freq '(a b c d e f g g g g g e))
;=> ((a 1) (d 1) (b 1) (e 2) (c 1) (f 1) (g 5))

(def huffman-tree (lst)
  ((afn (lst)
     (if single.lst caar.lst
         'else
         (let ((ai an) (bi bn) . rest) (sort (fn ((_ a) (_ b)) (< a b)) 
                                             lst)
           (self `(((,ai ,bi) ,(+ an bn))
                   ,@rest)))))
   freq.lst))

;(huffman-tree '(a b c d e f g g g g g e))
;=> (g ((f (b c)) ((a d) e)))

;;動作状況
;-> ((a d) 2), (b 1), (c 1), (f 1), (e 2), (g 5)
;-> ((b c) 2), (f 1), ((a d) 2), (e 2), (g 5)
;-> ((f (b c)) 3), ((a d) 2), (e 2), (g 5)
;-> (((a d) e) 4), ((f (b c)) 3), (g 5)
;-> (((f (b c)) ((a d) e)) 7), (g 5)
;-> ((g ((f (b c)) ((a d) e))) 12)
;=> (g ((f (b c)) ((a d) e)))

(def huffman-code-tree (lst)
  ((afn (tree (o code ""))
     (if (no alist.tree) `(,tree ,code)
         no.tree ()
         'else
         `(,(self car.tree (+ code "1"))
           ,(self cadr.tree (+ code "0")))))
   (huffman-tree lst)))

;(huffman-code-tree '(a b c d e f g g g g g e))
;=> ((g "1") (((f "011") ((c "0101") (d "0100"))) (((a "0011") (b "0010")) (e "000"))))

(def huffman-table (lst)
  (pair:flat:huffman-code-tree lst))
  • 符号化と復号化を試してみる。

"% huffman(Fs,Hs) :- Hs is the Huffman code table for the frequency table Fs"

という75文字の文字列の場合、下記のenhuffmanでは、326ビットになります。

元の文字列が1文字あたり6ビット(64種類の文字が可能)だとすると、450ビットなので、元より100ビット位圧縮されている、という解釈で良いんでしょうか?(´▽`*)…。

(withs (lst (coerce "% huffman(Fs,Hs) :- Hs is the Huffman code table for the frequency table Fs" 'cons)
        tab (huffman-table lst))
  (let code (enhuffman lst tab)
    (prn "\nencode:\n" (string lst) " => " code)
    (prn "\ndecode:\n" code " => " (string (dehuffman code tab)))
    nil))
;==>>
;encode:
;% huffman(Fs,Hs) :- Hs is the Huffman code table for the frequency table Fs => 10001000000111010010010001001110110100110101011011000101101100010000101101010000101000101111000010000101000101101010100011000011111100001000010010010001001110110100110000100111001010001111100011001101100000111111100000101001001101000110000111111000001001101111101110010011110011010011101001000110011011000001111111000011000101
;
;decode:
;10001000000111010010010001001110110100110101011011000101101100010000101101010000101000101111000010000101000101101010100011000011111100001000010010010001001110110100110000100111001010001111100011001101100000111111100000101001001101000110000111111000001001101111101110010011110011010011101001000110011011000001111111000011000101 => % huffman(Fs,Hs) :- Hs is the Huffman code table for the frequency table Fs
;nil

; ----
(def exch-key/val (lst)
  (map (fn ((a b)) (list b a))
       lst))

;(exch-key/val (huffman-table '(a b c d e f g g g g g e)))
;=> (("1" g) ("011" f) ("0101" c) ("0100" d) ("0011" a) ("0010" b) ("000" e))

(def enhuffman (lst tab)
  (let h (listtab tab)
    (apply + (map [h _] lst))))

;(let lst '(a b c d e f g g g g g e)
;  (let tab (huffman-table lst)
;    (enhuffman lst tab)))
;=> "001100100101010000001111111000"

(def dehuffman (code tab)
  (with (h (listtab (exch-key/val tab)) res () cur "")
    (each c code
      (zap + cur (string c))
      (awhen (h cur)
        (push it res)
        (= cur "")))
    rev.res))

;(let lst '(a b c d e f g g g g g e)
;  (let tab (huffman-table lst)
;    (let code "001100100101010000001111111000"
;      (dehuffman code tab))))
;=> (a d b c e f g g g g g e)