読者です 読者をやめる 読者になる 読者になる

gzip圧縮

common lisp algorithm

gzip圧縮/解凍器作成の4。
ようやくgzip圧縮器の作成に着手。

gzipパッケージ

今回は、DEFLATEフォーマットに準拠したデータの作成/書き出し部分の実装が主となるが、それに取りかかる前にgzipファイル作成用のユーティリティパッケージを定義しておく。コード的には、非圧縮gzipファイル作成に載せたものとほぼ同様。ただし若干修正している。
gzipフォーマットに関する詳細は、RFC1952(日本語訳)を参照のこと。
参照: crc, read-binary-file, octet

(defpackage :gzip
  (:use :common-lisp)
  (:export :create-default-gzip-file))
(in-package :gzip)

(defun write-n-byte (n value binary-output-stream)
  ;; gzipはリトルエンディアン
  (dotimes (i n)
    (write-byte (ldb (byte 8 (* i 8)) value) binary-output-stream)))

(defun write-default-gzip-header (#1=binary-output-stream)
  (write-byte #x1F #1#)           ; ID1
  (write-byte #x8B #1#)           ; ID2
  (write-byte #x08 #1#)           ; Compression Method: deflate
  (write-byte #x00 #1#)           ; Flags
  (write-n-byte 4 #x00000000 #1#) ; Modification Time
  (write-byte #x00 #1#)           ; Extra Flags
  (write-byte #xFF #1#))          ; Operating System(OS): unknown

(defun write-gzip-footer (crc isize #1=binary-output-stream)
  (write-n-byte 4 crc   #1#)
  (write-n-byte 4 isize #1#))

;; source-fileのデータに対して、圧縮関数compress-fnを適用し、結果をdestination-fileに出力する
(defun create-default-gzip-file (source-file destination-file compress-fn)
   (with-open-file (in source-file :element-type 'octet)
    (with-open-file (out destination-file :element-type 'octet
                                         :direction :output
                                         :if-exists :supersede)
      ;; header
      (write-default-gzip-header out)
      
      ;; data
      (funcall compress-fn (read-binary-file in) out)

      ;; crc and isize
      (write-gzip-footer (crc (read-binary-file in))        ; CRC
                         (mod (file-length in) #x100000000) ; ISIZE
                         out)))) 

DEFLATEパッケージ

DEFLATEデータ作成/書き出しコード。
まずは、パッケージの作成とユーティリティ関数の定義など。
DEFLATEデータフォーマットの仕様に関する詳細は、RFC1951(日本語訳)を参照のこと。
参照: nlet, hash-trie, length-limited-huffman(修正版), bit-stream, lz77

;;;;;;;;;;;;;;;
;;;; パッケージ
(defpackage :deflate
  (:use :common-lisp :bit-stream)
  (:export :deflate-fix
           :deflate-custom))
(in-package :deflate)

;;;;;;;;;;;;;;;;;;;;;;;
;;;; パッケージに別名を定義
(rename-package #1=:hash-trie #1# '(:trie)) 
(rename-package #1=:length-limited-huffman #1# '(:llh))

;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; ユーティリティ関数など
;; アナフォリックwhen
(defmacro a.when (expr &body body)
  `(let ((it ,expr))
     (when ,expr
       ,@body)))

;; lz77:to-deflate-codes(=データ圧縮)の結果を、bit-streamに書き込む
;; "リテラル/長さ"コードおよび"戻り距離"コードは、それぞれlile-huffman-table、dist-huffman-tableに従って符号化される
;; この関数は以降の「固定ハフマン符号を使った圧縮」と「カスタムハフマン符号を使った圧縮」の両方で使用される
(defun write-codes (deflate-codes lile-huffman-table dist-huffman-table bit-stream)
  (macrolet ((next-code (code rest) 
               `(setf ,code (car ,rest) ,rest (cdr ,rest))))
    (nlet self ((codes deflate-codes))
      (when codes
        (destructuring-bind (code . rest) codes
          ;; "リテラル/長さ"コードの符号ビットを出力する
          (write-bits (aref lile-huffman-table code) bit-stream :reverse t)
          (when (lz77:length-code? code)
            ;; コードが"長さ"コードだった場合は、拡張ビットの有無をチェックする
            (a.when (lz77:extra-length code)
              (next-code code rest)
              ;; "長さ"の拡張ビットを出力
              (write-bits (bits code it) bit-stream))

            ;; "戻り距離"コードの符号ビットを出力する
            (next-code code rest)
            (write-bits (aref dist-huffman-table code) bit-stream :reverse t)
             
            ;; "戻り距離"コードの拡張ビットの有無をチェックする
            (a.when (lz77:extra-distance code)
              (next-code code rest)
              ;; "戻り距離"コードの拡張ビットを出力する
              (write-bits (bits code it) bit-stream)))
          (self rest)))))
     ;; ブロック終端コード(256)の符号ビットを出力する
     (write-bits (aref lile-huffman-table 256) bit-stream :reverse t))

固定ハフマン符号を使った圧縮

DEFLATEの圧縮には二種類の方法がある。
一つはあらかじめ決まっている固定のハフマン符号表を用いてコード列(lz77:to-deflate-codesの結果)の変換/出力(上記write-codes呼び出し)を行う方法で、もう一つはコード列から適切なハフマン符号を計算し、それを用いてコード列の変換/出力を行う方法。
より簡単なので、固定のハフマン符号表を用いる圧縮方法から始めることにする。

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; 固定ハフマン符号を使った圧縮
;;;; 参照: http://www.futomi.com/lecture/japanese/rfc1951.html#s3_2_6

;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; 固定ハフマン符号作成
;; "リテラル/長さ"用の固定ハフマン符号木  ※ lile = LIteral/LEngth
(defvar *lile-fix-huffman-trie*
  (let ((trie (trie:make-trie)))
    (loop FOR i FROM 0 TO 143 DO   ; 0-143のリテラルコードは、#b00110000から始まる8bit列に対応
      (setf (trie:get-elem (bits (+ #b00110000 i)          8) trie) i))

    (loop FOR i FROM 144 TO 255 DO ; 144-255のリテラルコードは、#b110010000から始まる9bit列に対応
      (setf (trie:get-elem (bits (+ #b110010000 (- i 144)) 9) trie) i))

    (loop FOR i FROM 256 TO 279 DO ; 257-279の"長さ"コードは、#b0000001から始まる7bit列に対応。ブロック終端コード(256)は#b0000000
      (setf (trie:get-elem (bits (+ #b0000000   (- i 256)) 7) trie) i))

    (loop FOR i FROM 280 TO 287 DO ; 280 - 287の"長さ"コードは、#b11000000から始まる8bit列に対応
      (setf (trie:get-elem (bits (+ #b11000000  (- i 280)) 8) trie) i))
    trie))

;; "戻り距離"用の固定ハフマン符号木
;; ※ 0-31の5bit表現が、そのまま使われる
(defvar *dist-fix-huffman-trie*
  (let ((trie (trie:make-trie)))
    (dotimes (i 32 trie)
      (setf (trie:get-elem (bits i 5) trie) i))))

;; ハフマン符号木から、ハフマン符号表を作成する
(defun trie-to-code->bits-table (trie table-size)
  (let ((table (make-array table-size :element-type '#1=simple-bit-vector
                                      :initial-element #*)))
    (trie:map-trie (lambda (bit-list code)
                     (setf (aref table code) (coerce bit-list '#1#)))
                   trie)
    table))

;; "リテラル/長さ"ハフマン符号表および"戻り距離"ハフマン符号表を作成
(defvar *lile-fix-huffman-table* (trie-to-code->bits-table *lile-fix-huffman-trie* 288))
(defvar *dist-fix-huffman-table* (trie-to-code->bits-table *dist-fix-huffman-trie* 32))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; DEFLATE圧縮(固定ハフマン符号)
(defun deflate-fix (octets out)
  (with-bit-stream (out out)
    (write-bits #*1  out) ; BFINAL: 最終ブロックを指定
    (write-bits #*01 out) ; BTYPE:  固定ハフマン符号を指定
    
    ;; 固定ハフマン符号を使って、圧縮コードを出力する
    (write-codes (lz77:to-deflate-codes (lz77:encode octets))
                 *lile-fix-huffman-table*
                 *dist-fix-huffman-table*
                 out)))

gzip圧縮ファイル作成。

;; 夏目漱石の『こころ』(UTF-8)を固定ハフマン符号を使って圧縮
> (gzip:create-default-gzip-file "/path/to/kokoro" 
                                 "kokoro.fix.gz"
                                 #'deflate-fix)

カスタムハフマン符号を使った圧縮

次は、コード列に対して最適なハフマン符号を計算して、それを用いる方法。※ RFC1951にはカスタムハフマン符号という名前。
計算したハフマン符号を(出力データの先頭に)保存しておくところが若干複雑。

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; カスタムハフマン符号を使った圧縮
;;;; 参照: http://www.futomi.com/lecture/japanese/rfc1951.html#s3_2_7

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; ハフマン符号関連
;; コード列から、"リテラル/長さ"コードおよび"戻り距離"コードの出現数をカウントする
;; その結果は、length-limited-huffman:calc-code-bit-lengthに渡され、適切なハフマン符号を求めるために使用される
;; codes: lz77:to-deflate-codesの返り値
(defun count-frequency (codes)
  (let ((literal-length-freq (make-array 286 :initial-element 0))
        (distance-freq       (make-array 32  :initial-element 0)))
    ;; 以下のコードの構造は、概ね既出のwrite-codes関数と等しい
    ;; この関数の場合は、write-codesでコードを出力している箇所で、代わりにその出現数をカウントしている
    (macrolet ((next-code (code rest)  `(setf ,code (car ,rest) ,rest (cdr ,rest))))
      (nlet self ((codes codes))
        (when codes
          (destructuring-bind (code . rest) codes
            (incf (aref literal-length-freq code)) ; "リテラル/長さ"コードのカウント
            (when (lz77:length-code? code)
              (and (lz77:extra-length code) (next-code code rest))

              (next-code code rest)
              (incf (aref distance-freq code))     ; "戻り距離"コードのカウント

              (and (lz77:extra-distance code) (next-code code rest)))
            (self rest)))))
    (values literal-length-freq distance-freq)))

;; ハフマン符号表の未使用の末尾部分を取り除く
;; 未使用=符号ビット長が0
(defun remove-no-use-tail (huffman-table)
  (subseq huffman-table
          0
          (1+ (or (position-if #'plusp huffman-table :from-end t :key #'length)
                  -1))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; カスタムハフマン符号表保存関連
;; ユーティリティ関数
;; リスト内で同じ数値が続いた場合、(数値 . 連続する個数)形式に置換する
;; '(0 1 1 1 1 2 3 3) => '(0 (1 . 4) 2 (3 . 2))
(defun compact-number-list (list &aux (beg (car list)))
  (labels ((get-eql-num-count (num list &optional (cnt 1))
             (if (eql num (car list))
                 (get-eql-num-count (car list) (cdr list) (1+ cnt))
               (values cnt list))))
    (when (consp list)
      (multiple-value-bind (cnt rest) (get-eql-num-count beg (cdr list))
        (cons (if (= 1 cnt) beg `(,beg . ,cnt))
              (compact-number-list rest))))))

;; ハフマン符号表を受け取り、表の各コードの符号長を(圧縮した形式で)保持したリストを返す
;; 符号長リストの圧縮形式に関しては、http://www.futomi.com/lecture/japanese/rfc1951.html#s3_2_7を参照
(defun huffman-code-length-list (huffman-table)
            ;; 符号長0が複数続いた場合の圧縮を行う
  (labels ((zero-len-codes (count)
             (cond ((< count 3)   (loop REPEAT count COLLECT 0))
                   ((< count 11)  `(17 ,(bits (- count 3) 3)))
                   ((< count 139) `(18 ,(bits (- count 11) 7)))
                   (t             `(18 #*1111111 ,@(zero-len-codes (- count 138))))))
            ;; 同じ符号長が複数続いた場合の圧縮を行う
           (n-len-codes (n count)
             (cond ((< count 3) (loop REPEAT count COLLECT n))
                   ((< count 7) `(16 ,(bits (- count 3) 2)))
                   (t           `(16 #*11 ,@(n-len-codes n (- count 6)))))))
    (mapcan
     (lambda (n)
       (if (numberp n)
           (list n)
         (destructuring-bind (n . cnt) n
           (if (zerop n)
               (zero-len-codes cnt)
             `(,n ,@(n-len-codes n (1- cnt)))))))

   (compact-number-list (loop FOR bits ACROSS huffman-table COLLECT (length bits))))))

;; "リテラル/長さ"及び"戻り距離"のハフマン符号長の情報を保存する
(defun save-huffman-code-lengths (lile-huf-table dist-huf-table out)
  (let ((lile-len (length lile-huf-table))
        (dist-len (length dist-huf-table)))
    (write-bits (bits (- lile-len 257)  5) out)  ; HLIT:  リテラル/長さ符号の個数 - 257
    (write-bits (bits (- dist-len 1)    5) out)  ; HDIST: 距離符号の個数 - 1
    (write-bits (bits (- 19 4)          4) out)) ; HCLEN: 長さ符号の個数 - 4  ※ 簡単のためにこの値は固定

         ;; "リテラル/長さ"及び"戻り距離"の符号長リストを取得
  (let ((len-codes (huffman-code-length-list (concatenate 'vector
                                                          lile-huf-table
                                                          dist-huf-table)))
         ;; 符号長リスト(len-codes)用のハフマン符号を求め、出力する(以下7行)
        (len-freq (make-array 19 :initial-element 0)))
    (dolist (len (remove-if-not #'numberp len-codes))
      (incf (aref len-freq len)))

    (let ((len-huf-table (llh:make-code->bits-table (llh:calc-code-bit-length len-freq 7))))
      (dolist (i '(16 17 18 0 8 7 9 6 10 5 11 4 12 3 13 2 14 1 15))
        (write-bits (bits (length (aref len-huf-table i)) 3) out))
    
      ;; "リテラル/長さ"及び"戻り距離"の符号長リストを出力する
      (dolist (c len-codes)
        (if (numberp c)
            (write-bits (aref len-huf-table c) out :reverse t)
          (write-bits c out))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; DEFLATE圧縮(カスタムハフマン符号)
(defun deflate-custom (octets out)
  (with-bit-stream (out out)
    (write-bits #*1  out) ; BFINAL: 最終ブロックを指定
    (write-bits #*10 out) ; BTYPE:  カスタムハフマン符号を指定
    
    (let ((codes (lz77:to-deflate-codes (lz77:encode octets))))
      (multiple-value-bind (lile-freq dist-freq) (count-frequency (cons 256 codes))
        (let ((lile-huf-table (remove-no-use-tail  ; "リテラル/長さ"コード用のハフマン符号表
                               (llh:make-code->bits-table 
                                (llh:calc-code-bit-length lile-freq 15))))
              (dist-huf-table (remove-no-use-tail  ; "戻り距離"コード用のハフマン符号表
                               (llh:make-code->bits-table
                                (llh:calc-code-bit-length dist-freq 15)))))
          ;; ハフマン符号表の情報を(解凍時に復元できるように)保存する
          (save-huffman-code-lengths lile-huf-table dist-huf-table out)
          
          (write-codes codes   ; カスタムハフマン符号を使ってlz77圧縮コードを出力
                       lile-huf-table
                       dist-huf-table
                       out))))))

gzip圧縮ファイル作成。

;; 夏目漱石の『こころ』(UTF-8)をカスタムハフマン符号を使って圧縮
> (gzip:create-default-gzip-file "/path/to/kokoro" 
                                 "kokoro.custom.gz"
                                 #'deflate-custom)

以上で、固定ハフマン符号とカスタムハフマン符号を使ったDEFLATEの実装は終了。

圧縮率

各圧縮方法(+ gzipコマンド)での圧縮率を簡単に比較してみる。

###
# まずは、ちゃんと圧縮できているかをチェック
$ if gzip -dc kokoro.fix.gz | diff /path/to/kokoro - >/dev/null; then echo OK; fi
OK

$ if gzip -dc kokoro.custom.gz | diff /path/to/kokoro - >/dev/null; then echo OK; fi
OK
# 大丈夫っぽい

###
# 圧縮率比較
# gzipコマンドを使って、デフォルト・低圧縮率・高圧縮率、の三種類のgzipファイルを作成する
$ gzip -c  /path/to/kokoro > kokoro.gz    # デフォルト
$ gzip -1c /path/to/kokoro > kokoro.1.gz  # 低圧縮率
$ gzip -9c /path/to/kokoro > kokoro.9.gz  # 高圧縮率

# 比較
$ du -h /path/to/kokoro *.gz
548K	/path/to/kokoro
228K	kokoro.1.gz
172K	kokoro.9.gz
180K	kokoro.custom.gz
212K	kokoro.fix.gz
176K	kokoro.gz

圧縮率は悪くはない。
速度的にはgzipコマンドとは比べるべくもないけど...*1

冬休み中にできたのはここまで。
残るはgzip解凍器。

*1:gzipコマンドのデフォルトの圧縮所要時間は0.054秒、deflate:deflate-fix(or deflate:deflate-custom)の圧縮所要時間は約3.5秒