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

LZ77圧縮 -DEFLATE用-

common lisp algorithm

gzip圧縮/解凍器作成の3。

軽く整理

  1. gzipはデータの圧縮に(主に)DEFLATEアルゴリズム(or DEFLATE圧縮データフォーマット)を利用している
  2. DEFLATEでは以下のような方法でデータの圧縮が行われる
    1. 入力データをLZ77アルゴリズムで圧縮する
    2. 上記圧縮データをさらにハフマン符号化を用いて圧縮する
  3. gzipRFC1952で、DEFLATEはRFC1951で定義されている ※ 左のリンク先は、どちらもその日本語訳

今回は、この内のLZ77による圧縮(及び解凍)を扱う。

LZ77

まず、RFC1951内でLZ77の要旨について言及している箇所を引用する。

圧縮データ(LZ77圧縮データ ※引用者注)は、2 種類の連続要素から構成されます。(前の 32K 入力バイトの中に複製されたと検出されなかったストリングの)文字バイトと、複製されたストリングへのポインターです。そのポインターは、一対の <長さ、戻る距離> として表現されるものです。"deflate" フォーマットで使われるその表現は、距離を 32K バイトまでに、長さを 258 バイトまでに制限されています。

RFC 1951 DEFLATE Compressed Data Format Specification version 1.3 日本語訳 - futomi's CGI Cafe

これだけでは分かりにくいので少し補足しつつLZ77アルゴリズムをまとめてみると、多分次のようになる。※ RFC1951から判断する限り

  1. 入力データを順に走査する
  2. 現在走査している箇所から始まるデータが既にどこかで出てきているかをチェックする 重複データの検出
  3. 重複がある場合は、その分のデータを<長さ(重複するデータ長)、戻る距離(現在位置-重複検出位置)>で置き換える
    • 例えば、"abc123abc456"という文字列の場合は、"abc123<3,6>456"と置換されることになる
  4. 残りのデータを走査し、同様の処理を行う

これに加えて、DEFLATEの場合は長さが最大258バイト(※最小は3バイト)、戻り距離が最大32Kバイトという制限がある。


これを実装したのが以下のコード。
参照: find-max, octet, nlet-acc, nlet

;;;;;;;;;;;;;;;
;;;; パッケージ
(defpackage lz77
  (:use :common-lisp)
  (:export :encode    ; 圧縮関数
           :decode    ; 解凍関数
           :to-deflate-codes
           :from-deflate-codes))
(in-package :lz77)

;;;;;;;;;
;;;; 定数
(defconstant MAX-LENGTH 258)                 ; LZ77の"長さ"の最大長
(defconstant MIN-LENGTH 3)                   ; LZ77の"長さ"の最小長
(defconstant BACKWORD-DISTANCE-LIMIT #x8000) ; LZ77の"戻り距離"の最大長

;;;;;;;;;;;
;;;; 構造体
;; 重複(一致)情報を保持する構造体
(defstruct (match (:constructor match (length backword-distance)))
  length
  backword-distance)

;; 簡便なアクセサ
(defmacro match-len  (match) `(match-length ,match))
(defmacro match-dist (match) `(match-backword-distance ,match))

(defmethod print-object ((o match) stream)
  (format stream "<~D,-~D>" (match-len o) (match-dist o)))

;;;;;;;;;;;;;;;;         
;;;; encode関数系 
;; 候補の中から、最も長い一致を見つけて返す
;;  ary: 入力データ
;;  cur-pos: 現在の走査位置
;;  chained-pos-list: cur-posから始まるデータと、最初の三要素が一致した位置のリスト 
(defun maximal-length-match (ary cur-pos chained-pos-list)
  (multiple-value-bind (pos length)
      (find-max (lambda (chained-pos)
                  (let ((start1 (+ MIN-LENGTH chained-pos))
                        (start2 (+ MIN-LENGTH cur-pos))
                        (end1   (min cur-pos (+ chained-pos MAX-LENGTH))))
                    (if (> start1 end1)
                        ;; 開始位置が終了位置を越えている(cur-posとchained-posにデータ共有がある)場合は、0を返す
                        0
                      ;; 一致数を求める
                      (- (or (mismatch ary ary :start1 start1 :end1 end1 :start2 start2) end1)
                         chained-pos))))
                chained-pos-list)
    (when (and pos (not (zerop length)))
      ;; 一致するデータある場合は、match構造体を作成する
      (match length (- cur-pos pos)))))

;; LZ77アルゴリズムを用いて入力の(一次元)配列を圧縮する
;; 重複(一致)データの判定方法は http://www.futomi.com/lecture/japanese/rfc1951.html#s4 を参考にしている
;;  ※ ただし、現時点ではソースコードの可読性を優先しているため、非効率な(及び圧縮率最大ではない)実装となっている
(defun encode (ary)
  (let ((chain (make-hash-table :test #'equalp)) ; 一致候補位置のリストを保持するchainedハッシュテーブル
        (acc '())                                ; エンコード結果を保持するリスト
        (prev-end -1)                            ; 重複データの終了位置を保持する変数
        (len (length ary)))           ; 入力データ長

            ;; 遠すぎる(= 32KB以上戻る必要がある)一致位置を候補から削除する関数
    (flet ((chain-delete-far-pos (key cur-pos)
             (setf #1=(gethash key chain)
                   (delete-if (lambda (pos) (> (- cur-pos pos) BACKWORD-DISTANCE-LIMIT)) #1#))))

      (loop FOR i FROM 0 BELOW len
            FOR key = (subseq ary i (min (+ i MIN-LENGTH) len)) DO
        (unless (< i prev-end)   ; 現在位置が、以前重複を検出したデータの範囲内なら、処理を飛ばす
          (chain-delete-far-pos key i)
          ;; 重複データを取得する
          (let ((m (maximal-length-match ary i (gethash key chain))))
            (if m
                ;; 重複あり: match構造体を追加
                (progn (push m acc)
                       (setf prev-end (+ i (match-len m))))
              ;; 重複なし: リテラルデータを追加
              (push (aref ary i) acc))))

        ;; chainedハッシュテーブルに一致候補位置を追加する
        (push i (gethash key chain)))
      (nreverse acc))))

;;;;;;;;;;;;;;;
;;;; decode関連
;; 上記encode関数により返されたリストをデコード(解凍)する
;;  element-type:  デコードされる配列の要素の型
;;  encoded-list:  encode関数の戻り値
;;  previous-data: encoded-listの前に続くデータ。encoded-listが入力データの途中の部分から始まる場合、match構造体を実際にデータで展開するために必要
(defun decode (element-type encoded-list &optional (previous-data (make-array 0)))
  (let ((buf (make-array #1=(length previous-data)
                         :element-type element-type
                         :initial-contents previous-data
                         :fill-pointer #1#
                         :adjustable t)))
    (loop FOR e IN encoded-list COLLECT
      (if (not (match-p e))
          ;; リテラルデータを追加
          (vector-push-extend e buf)
        ;; match構造体は、buf[現在位置-戻り距離,長さ]のデータに展開して追加
        (loop FOR i FROM (- (fill-pointer buf)
                            (match-dist e))
              REPEAT (match-len e)
              DO (vector-push-extend (aref buf i) buf))))
    (copy-seq buf)))

例:
参照: read-file, read-binary-file

;; データ: 夏目漱石『こころ』
> (in-package :common-lisp-user)
> (defvar *kokoro*        (read-file "/path/to/kokoro"))
> (defvar *kokoro-octets* (read-binary-file "/path/to/kokoro"))  ; これは後で使う

;; オリジナルデータ
> (subseq *kokoro* 0 500)
"こころ
夏目漱石

-------------------------------------------------------
【テキスト中に現れる記号について】

《》:ルビ
(例)私《わたくし》はその人を常に先生と呼んでいた

|:ルビの付く文字列の始まりを特定する記号
(例)先生一人|麦藁帽《むぎわらぼう》を

[#]:入力者注 主に外字の説明や、傍点の位置の指定
   (数字は、JIS X 0213の面区点番号、または底本のページと行数)
(例)※[#「てへん+劣」、第3水準1-84-77]
-------------------------------------------------------

  上 先生と私


     一

 私《わたくし》はその人を常に先生と呼んでいた。だからここでもただ先生
と書くだけで本名は打ち明けない。これは世間を憚《はば》かる遠慮というよ
りも、その方が私にとって自然だからである。私はその人の記憶を呼び起すご
とに、すぐ「先生」といいたくなる。筆を執《と》っても心持は同じ事である。
よそよそしい"


;; LZ77圧縮結果
> (format nil "~{~A~}" (lz77:encode (subseq *kokoro* 0 500)))
"こころ
夏目漱石

---<3,-3><6,-6><12,-12><24,-24><7,-7>
【テキスト中に現れる記号について】<4,-78>《》:ルビ
(例)私《わたくし》はその人を常に先生と呼んでいた<4,-36>|<3,-35>の付
く文字列の始まりを特定す<3,-66><5,-52>先生一人|麦藁帽《むぎわらぼう》
を<4,-47>[#]:入力者注 主に外字の説明や、傍点の位置の指定
   (数字は、JIS X 0213の面区点番号、または底本のページと行数)<5,-92>
※[#「てへん+劣」、第3水準1-84-77]<59,-257><4,-127>上 <3,-218>私<4,-12>
<5,-141>  一<5,-10><22,-253>。だからここでもただ<3,-18>書くだけで本名
は打ち明けない。これは世間を憚《はば》かる遠慮というよりも、その方が私に
とって自然<3,-60>である。私<4,-84>の記憶を呼び起すごとに、すぐ「先生」と
いいたくなる。筆を執《と》っても心持は同じ事<4,-50>よそよそしい"

> (length (lz77:encode (subseq *kokoro* 0 500)))
--> 327  ; 500文字を対象にした場合、要素数的には約65%に圧縮されている

DEFLATE用コード列に変換

ここまででLZ77の基本的な実装は終了したが、DEFLATEで利用するには、さらにlz77:encode関数の結果を加工し整数列に変換する必要がある。
変換の仕様は若干ややこしいので、オリジナルの文書(RFC1951「3.2.5. 圧縮ブロック (長さ・距離コード)」)を参照してもらうとして、ここではそのためのコードだけを載せておくことにする。

(in-package :lz77)

;;;;;;;;;;;;;
;;;; 補助関数
;; ツリーをリストに変換する: ex. (flatten '((1) 2 ((3 4))) => '(1 2 3 4)
(defun flatten (lst)
  (nlet-acc self ((x lst))
    (if (consp x)
        (progn (self (car x)) (self (cdr x)))
      (when x
        (accumulate x)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; to-deflate-codes関数系
;; lz77の"長さ"をDEFLATE用のコードに変換する
(defun length-to-code (n)
  (let* ((n-3   (- n 3))
         (len   (integer-length n-3))
         (len-3 (- len 3)))
    (case n
      ((3 4 5 6 7 8 9 10) (+ 254 n))
      (258                285)
      (otherwise 
       (multiple-value-bind (base extra) (floor n-3 (expt 2 len-3))
         `(,(+ 257 (* 4 len-3) base) ,extra))))))

;; lz77の"戻り距離"をDEFLATE用のコードに変換する
(defun distance-to-code (n)
  (let* ((n-1   (1- n))
         (len   (integer-length n-1))
         (len-2 (- len 2)))
    (case len
          ((0 1 2)   n-1)
          (otherwise
           (multiple-value-bind (base extra) (floor n-1 (expt 2 len-2))
             `(,(+ (* 2 len-2) base) ,extra))))))

;; match構造体(<長さ,戻り距離>)をDEFLATE用のコード(コード列)に変換する
(defun match-to-code (match)
  (list (length-to-code   (match-len  match))
        (distance-to-code (match-dist match))))

;; NOTE: 256(ブロック終端を示すコード)は返り値のリストに含めない
;; lz77:encode関数の結果を、DEFLATE用のコード列に変換する
(defun to-deflate-codes (encoded-list)
  (flatten
   (loop FOR e IN encoded-list COLLECT
     (etypecase e
       (octet e)
       (match (match-to-code e))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; from-deflate-codes関数系
;; コード列からmatch構造体を復元する
(defun match-from-codes (codes)
  (let ((code (car codes))
        (m    (match 0 0)))
    
    ;; コード列から、match-lengthの値を復元する
    (setf (match-len m)
          (cond ((<= 257 code 264) (- code 254))
                ((= code 285)      258)
                (t (let ((md (mod (1- code) 4))
                         (pw (ceiling (- code 264) 4)))
                     (prog1 (+ (+ 3 (expt 2 (+ pw 2)))
                               (* md (expt 2 pw))
                               (second codes))
                       (setf codes (cdr codes)))))))
    (setf codes (cdr codes)
          code  (car codes))

    ;; コード列から、match-backword-distanceの値を復元する
    (setf (match-dist m)
          (if (<= 0 code 3)
              (1+ code)
            (let ((md (mod code 2))
                  (pw (ceiling (- code 3) 2)))
              (prog1 (+ (1+ (expt 2 (1+ pw)))
                        (* md (expt 2 pw))
                        (second codes))
                (setf codes (cdr codes))))))
    
    ;; 復元したmatch構造体と残りのコード列を返す
    (values m (cdr codes))))
              
;; NOTE: codesには、256(ブロック終端を示すコード)は含まれないことが前提。 ※ codesの終端 = ブロックの終端
;; to-deflate-codes関数の結果を、encode関数の結果に復元する
;;  (equalp #1=(encode ...) (from-deflate-codes (to-deflate-codes #1#))) ==> T
(defun from-deflate-codes (codes)
  (flet ((literal? (code)      (<= 0 code 255))
         (end-of-block? (code) (= code 256)))
    (nlet self ((codes codes) acc)
      (if (null codes)
          (nreverse acc)
        (destructuring-bind (code . rest) codes
          (cond ((literal? code)      #|リテラルデータ|#  (self rest (cons code acc)))
                ((end-of-block? code) #|終端コード:不正|# (error "Unexpected code ~A" code))
                (t                    #|エンコードされた<長さ、戻り距離>データ|#
                 (multiple-value-bind (match rest) (match-from-codes codes)
                   (self rest (cons match acc))))))))))

例:

> (in-package :common-lisp-user)

;; 『こころ』のバイトデータをLZ77で圧縮
> (defvar *lz77* (lz77:encode *kokoro-octets*))
--> *LZ77*

> (subseq *lz77* 10000 10050)
--> (<16,-20268> <5,-1627> <11,-4572> <6,-9255> <25,-479> <4,-1456> <4,-587>
     <14,-10087> <15,-5807> <8,-19944> <6,-2031> <6,-4979> <8,-25767> <12,-57>
     <8,-13692> <7,-9410> <10,-6635> <23,-8895> <15,-6557> <18,-17588> <4,-16505>
     138 177 <11,-2567> <6,-4006> <12,-2573> <7,-20087> <24,-13794> <3,-179> 233
     135 <6,-1683> <3,-562> <3,-1003> <6,-14312> <10,-15528> <23,-27616> 167
     <9,-997> <26,-9476> <3,-640> 183 <8,-16529> <6,-2897> <3,-536> <7,-16532>
     <5,-3713> <5,-365> <7,-23861> 175)

;; DEFLATE用のコード列に変換
> (lz77:to-deflate-codes *)
--> (267 1 28 3883 259 21 90 265 0 24 475 260 26 1062 270 2 17 94 258 20 431 258 18
     74 266 1 26 1894 267 0 24 1710 262 28 3559 260 21 494 260 24 882 262 29 1190
     265 1 11 8 262 27 1403 261 26 1217 264 25 490 270 0 26 702 267 0 25 412 268 1
     28 1203 258 28 120 138 177 265 0 22 518 260 23 933 265 1 22 524 261 28 3702
     270 1 27 1505 257 14 50 233 135 260 21 146 257 18 49 257 19 234 260 27 2023
     264 27 3239 270 0 29 3039 167 263 19 228 270 3 26 1283 257 18 127 183 262 28
     144 260 22 848 257 18 23 261 28 147 259 23 640 259 16 108 261 28 7476 175)

> (defvar *codes* (lz77:to-deflate-codes *lz77*))
--> *CODES*

;; 復元テスト
> (equalp (lz77:from-deflate-codes *codes*) *lz77*)
--> T

;; 各々の列の長さ
> (length *kokoro-octets*)
--> 554722

> (length *lz77*)
--> 84091

> (length *codes*)
--> 234288

以上で、DEFLATEのLZ77に関する実装は(ほぼ)終了。

2010/01/05: 関数追加

DEFLATE処理用の便利関数をいくつか追加。

;;;;;;;;;;;;;;;
;;;; パッケージ修正
(defpackage lz77
  (:use :common-lisp)
  (:export :encode
           :decode
           :to-deflate-codes
           :from-deflate-codes

           ;; この下の三つを追加
	   :length-code?
	   :extra-length
	   :extra-distance))
(in-package :lz77)

;;;;;;;;;;;;;
;;;; 追加関数
;; コードが"長さ"を表しているかどうか
(defun length-code? (code)
  (<= 257 code 285))

;; "長さ"コードに付随する拡張コードのビット数
;; 拡張コードが続かない場合は、nilが返される
(defun extra-length (code)
  (if (<= 265 code 284)
      (let ((base (- code 261)))
	(values (floor base 4)))
    nil))

;; "戻り距離"コードに付随する拡張コードのビット数
;; 拡張コードが続かない場合は、nilが返される
(defun extra-distance (code)
  (if (<= 4 code 29)
      (let ((base (- code 2)))
	(values (floor base 2)))
    nil))