Common Lisp Programming

LZ77 符号

LZ 符号は Jacob Ziv 氏と Abraham Lempel 氏によって開発された「適応型辞書法」によるデータ圧縮アルゴリズムです。LZ 符号には多数のバリエーションが存在しますが、「LZ77 符号」と「LZ78 符号」の 2 つに大別されます。LZ77 符号は 1977 年に、LZ78 符号は 1978 年に発表されました。

両者の符号は互いに関係があるものの、辞書の作成方法はまったく異なっているので、混同しないように注意してください。LZ77 符号は「スライド辞書法」、 LZ78 符号は「動的辞書法」と呼ばれています。LZ77 符号の詳しい説明は以下に示す拙作のページをお読みください。

• Algorithms with Python
• LZSS 符号
• LZB 符号と LZH 符号
• バイナリレンジコーダー [2]

●LZSS 符号

;;;
;;; lzss.py : LZSS coding
;;;
;;; Copyright (C) 2023 Makoto Hiroi
;;;
;;; Released under the MIT license
;;; https://opensource.org/license/mit/
;;;
(require :bitio)
(use-package :bitio)

;;; 定数
(defconstant min-len 3)
(defconstant max-len 18)
(defconstant len-bits 4)
(defconstant pos-bits 13)
(defconstant slide-size (ash 1 pos-bits))
(defconstant slide-size2 (* slide-size 2))
(defconstant slide-limit (+ slide-size2 max-len))

;;; スライド窓
(defstruct slide-window stream buff ht data-size)

(defun initialize-slide-window (s)
  (let* ((buff (make-array slide-limit :element-type 'unsigned-byte))
         (data-size (read-sequence buff s)))
    (make-slide-window
     :stream s
     :buff buff
     :ht (make-hash-table)
     :data-size data-size)))

;;; ハッシュ値を求める
(defun hash-value (sw rp)
  (do ((buff (slide-window-buff sw))
       (value 0)
       (i 0 (1+ i)))
      ((>= i min-len) value)
      (setf value
            (+ (* value 256) (aref buff (+ rp i))))))

;;; データ入力
(defun read-data (sw start size)
  (read-sequence
   (slide-window-buff sw)
   (slide-window-stream sw)
   :start start
   :end (+ start size)))

;;; データ移動
(defun move-data (sw to from size)
  (let ((buff (slide-window-buff sw)))
    (dotimes (n size)
      (setf (aref buff (+ to n)) (aref buff (+ from n))))))

;;; スライド窓の更新
(defun update-slide (sw rp)
  (cond
   ((< (slide-window-data-size sw) slide-limit)
    ;; EOF
    rp)
   (t
    ;; buffer update
    (move-data sw 0 slide-size (+ slide-size max-len))
    (setf (slide-window-data-size sw)
          (read-data sw (+ slide-size max-len) slide-size))
    ;; hash update
    (maphash
     (lambda (k v)
       (if (< (car v) slide-size)
           (remhash k (slide-window-ht sw))
         (do ((xs v (cdr xs)))
             ((null xs))
             (decf (car xs) slide-size)
             (when (and (consp (cdr xs))
                        (< (cadr xs) slide-size))
               (setf (cdr xs) nil)))))
     (slide-window-ht sw))
    (- rp slide-size))))

;;; データの挿入
(defun insert-data (sw rp)
  (let ((value (hash-value sw rp))
        (ht (slide-window-ht sw)))
    (if (gethash value ht)
        (push rp (gethash value ht))
      (setf (gethash value ht) (list rp)))))

;;; 最長一致列の探索
(defun longest-match (buff s1 s2 &key (start 0) (limit max-len))
  (do ((i start (1+ i)))
      ((>= i limit) i)
      (unless (= (aref buff (+ s1 i)) (aref buff (+ s2 i)))
        (return i))))

(defun search-data (sw rp)
  (let ((buff (slide-window-buff sw))
        (value (hash-value sw rp))
        (low-limit (- rp slide-size))
        (match-len 0)
        (match-pos 0))
    (do ((xs (gethash value (slide-window-ht sw)) (cdr xs)))
        ((or (null xs)
             (< (car xs) low-limit)))
        (when (and (< (+ rp (max min-len match-len)) (slide-window-data-size sw))
                   (= (aref buff (+ rp match-len))
                      (aref buff (+ (car xs) match-len)))
          (let ((n (longest-match buff rp (car xs) :start 3)))
            (when (< match-len n)
              (setf match-len n
                    match-pos (car xs))
              (when (= n max-len)
                (return)))))))
    ;; データの終端をチェック
    (when (>= match-len (- (slide-window-data-size sw) rp))
      (setf match-len (- (slide-window-data-size sw) rp)))
    (values match-len match-pos)))

;;; LZSS 符号 : 符号化
(defun encode (fin fout)
  (do ((sw (initialize-slide-window fin))
       (rp 0))
      ((>= rp (slide-window-data-size sw)))
      (multiple-value-bind
       (match-len match-pos)
       (search-data sw rp)
       (cond
        ((< match-len min-len)
         (setf match-len 1)
         (putbit fout 0)
         (putbits fout 8 (aref (slide-window-buff sw) rp)))
        (t
         (putbit fout 1)
         (putbits fout len-bits (- match-len min-len))
         (putbits fout pos-bits (- rp match-pos 1))))
       ;;
       (do ((n match-len (1- n)))
           ((zerop n))
           (insert-data sw rp)
           (incf rp)
           (when (>= rp slide-size2)
             (setf rp (update-slide sw rp)))))))

;;; ファイルの符号化
(defun encode-file (in-file out-file)
  (call-with-bit-output-file
   out-file
   (lambda (fout)
     (call-with-byte-input-file
      in-file
      (lambda (fin)
        (let ((size (file-length fin)))
          (putbits fout 32 size)
          (when (plusp size)
            (encode fin fout))))))))

;;; LZSS 符号 : 復号
(defun decode (fin fout size)
  (do ((buff (make-array (ash 1 pos-bits) :element-type 'unsigned-byte))
       (rp 0))
      ((zerop size))
      (cond
       ((= (getbit fin) 1)
        (let ((num (+ (getbits fin len-bits) min-len))
              (pos (- rp (1+ (getbits fin pos-bits)))))
          (when (minusp pos)
            (incf pos (length buff)))
          (do ((num num (1- num)))
              ((zerop num))
              (let ((c (aref buff pos)))
                (write-byte c fout)
                (setf (aref buff rp) c)
                (incf pos)
                (incf rp)
                (when (>= pos (length buff))
                  (setf pos 0))
                (when (>= rp (length buff))
                  (setf rp 0))))
          (decf size num)))
       (t
        (let ((c (getbits fin 8)))
          (write-byte c fout)
          (setf (aref buff rp) c)
          (incf rp)
          (when (>= rp (length buff))
            (setf rp 0)))
        (decf size)))))

;;; ファイルの復号
(defun decode-file (in-file out-file)
  (call-with-bit-input-file
   in-file
   (lambda (fin)
     (let ((size (getbits fin 32)))
       (call-with-byte-output-file
        out-file
        (lambda (fout)
          (when (plusp size)
            (decode fin fout size))))))))

;;; 簡単なテスト
(defun test ()
  (let ((files '("alice29.txt" "asyoulik.txt" "cp.html" "fields.c" "grammar.lsp"
                 "kennedy.xls" "lcet10.txt" "plrabn12.txt" "ptt5" "sum" "xargs.1")))
    (format t "----- encode -----~%")
    (time
     (dolist (file files)
       (encode-file (format nil "./canterbury/~a" file)
                    (format nil "~a.en" file))))
    ;;
    (format t "----- decode -----~%")
    (time
     (dolist (file files)
       (decode-file (format nil "~a.en" file)
                    (format nil "~a.de" file))))))

• Canterbury Corpus で配布されているテストデータ The Canterbury Corpus の圧縮結果

* (load "lzss.lisp")
T

* (test)
----- encode -----
Evaluation took:
  1.660 seconds of real time
  1.414014 seconds of total run time (1.396977 user, 0.017037 system)
  [ Run times consist of 0.006 seconds GC time, and 1.409 seconds non-GC time. ]
  85.18% CPU
  3,972,550,531 processor cycles
  49,984,896 bytes consed

----- decode -----
Evaluation took:
  0.299 seconds of real time
  0.303218 seconds of total run time (0.302669 user, 0.000549 system)
  101.34% CPU
  727,757,440 processor cycles
  753,520 bytes consed

NIL

      表 : LZSS 符号の結果 (スライド窓 : 8192)

  ファイル名      サイズ    下限値   huffman     LZSS
  -----------------------------------------------------
  alice29.txt    152,089    86,837    87,785    68,332
  asyoulik.txt   125,179    75,235    75,895    61,789
  cp.html         24,603    16,082    16,310    10,278
  fields.c        11,150     6,980     7,143     3,859
  grammar.lsp      3,721     2,155     2,269     1,594
  kennedy.xls  1,029,744   459,970   462,856   291,968
  lcet10.txt     426,754   249,071   250,673   184,684
  plrabn12.txt   481,861   272,936   275,690   247,780
  ptt5           513,216    77,636   106,754   107,289
  sum             38,240    25,473    25,968    17,500
  xargs.1          4,227     2,589     2,698     2,198
  -----------------------------------------------------
  合計         2,810,784 1,274,964 1,314,041   997,271


  表 : 実行時間 (秒)

         : huff : LZSS
  -------+------+------
  符号化 : 0.60 : 1.66
   復号  : 0.35 : 0.30


実行環境 : SBCL 2.1.11, Ubunts 22.04 (WSL2), Intel Core i5-6200U 2.30GHz

• 最長一致系列の探索にはハッシュ表と連結リストを使っています
• この実装方法では、ハッシュ値の衝突が頻繁に発生すると、実行速度が極端に遅くなるという欠点があります
• LHA のプログラムは、この対応策が実装されていますが、今回は単純な方法でプログラムを作りました

●LZB 符号

;;;
;;; lzb.py : LZB coding
;;;
;;; Copyright (C) 2023 Makoto Hiroi
;;;
;;; Released under the MIT license
;;; https://opensource.org/license/mit/
;;;
(require :bitio)
(use-package :bitio)

;;; 定数
(defconstant min-len 3)
(defconstant max-len 256)
(defconstant pos-bits 16)                   ; 13 (8k), 15 (32k), 16 (64k)
(defconstant slide-size (ash 1 pos-bits))
(defconstant slide-size2 (* slide-size 2))
(defconstant slide-limit (+ slide-size2 max-len))

;;;
;;; 距離の符号化 (CBT 符号)
;;;
(defvar *pos-bits* 0)

;;; 更新
(defun update-pos-bits (rp)
  (when (< *pos-bits* pos-bits)
    (do ()
        ((<= rp (1- (ash 1 *pos-bits*))))
        (incf *pos-bits*))))

;;; 符号化
(defun pos-encode (fout rp pos)
  (if (< 1 *pos-bits* pos-bits)
      (cbt-encode fout pos rp *pos-bits*)
    (putbits fout pos-bits pos)))

;;; 復号
(defun pos-decode (fin rp)
  (if (< 1 *pos-bits* pos-bits)
      (cbt-decode fin rp *pos-bits*)
    (getbits fin pos-bits)))

;;; スライド窓
(defstruct slide-window stream buff ht data-size)

(defun initialize-slide-window (s)
  (let* ((buff (make-array slide-limit :element-type 'unsigned-byte))
         (data-size (read-sequence buff s)))
    (make-slide-window
     :stream s
     :buff buff
     :ht (make-hash-table)
     :data-size data-size)))

;;; ハッシュ値を求める
(defun hash-value (sw rp)
  (do ((buff (slide-window-buff sw))
       (value 0)
       (i 0 (1+ i)))
      ((>= i min-len) value)
      (setf value
            (+ (* value 256) (aref buff (+ rp i))))))

;;; データ入力
(defun read-data (sw start size)
  (read-sequence
   (slide-window-buff sw)
   (slide-window-stream sw)
   :start start
   :end (+ start size)))

;;; データ移動
(defun move-data (sw to from size)
  (let ((buff (slide-window-buff sw)))
    (dotimes (n size)
      (setf (aref buff (+ to n)) (aref buff (+ from n))))))

;;; スライド窓の更新
(defun update-slide (sw rp)
  (cond
   ((< (slide-window-data-size sw) slide-limit)
    ;; EOF
    rp)
   (t
    ;; buffer update
    (move-data sw 0 slide-size (+ slide-size max-len))
    (setf (slide-window-data-size sw)
          (read-data sw (+ slide-size max-len) slide-size))
    ;; hash update
    (maphash
     (lambda (k v)
       (if (< (car v) slide-size)
           (remhash k (slide-window-ht sw))
         (do ((xs v (cdr xs)))
             ((null xs))
             (decf (car xs) slide-size)
             (when (and (consp (cdr xs))
                        (< (cadr xs) slide-size))
               (setf (cdr xs) nil)))))
     (slide-window-ht sw))
    (- rp slide-size))))

;;; データの挿入
(defun insert-data (sw rp)
  (let ((value (hash-value sw rp))
        (ht (slide-window-ht sw)))
    (if (gethash value ht)
        (push rp (gethash value ht))
      (setf (gethash value ht) (list rp)))))

;;; 最長一致列の探索
(defun longest-match (buff s1 s2 &key (start 0) (limit max-len))
  (do ((i start (1+ i)))
      ((>= i limit) i)
      (unless (= (aref buff (+ s1 i)) (aref buff (+ s2 i)))
        (return i))))

(defun search-data (sw rp)
  (let ((buff (slide-window-buff sw))
        (value (hash-value sw rp))
        (low-limit (- rp slide-size))
        (match-len 0)
        (match-pos 0))
    (do ((xs (gethash value (slide-window-ht sw)) (cdr xs)))
        ((or (null xs)
             (< (car xs) low-limit)))
        (when (and (< (+ rp (max min-len match-len)) (slide-window-data-size sw))
                   (= (aref buff (+ rp match-len))
                      (aref buff (+ (car xs) match-len)))
          (let ((n (longest-match buff rp (car xs) :start 3)))
            (when (< match-len n)
              (setf match-len n
                    match-pos (car xs))
              (when (= n max-len)
                (return)))))))
    ;; データの終端をチェック
    (when (>= match-len (- (slide-window-data-size sw) rp))
      (setf match-len (- (slide-window-data-size sw) rp)))
    (values match-len match-pos)))

;;; LZSS 符号 : 符号化
(defun encode (fin fout)
  (do ((sw (initialize-slide-window fin))
       (rp 0))
      ((>= rp (slide-window-data-size sw)))
      (multiple-value-bind
       (match-len match-pos)
       (search-data sw rp)
       (cond
        ((< match-len min-len)
         (setf match-len 1)
         (putbit fout 0)
         (putbits fout 8 (aref (slide-window-buff sw) rp)))
        (t
         (putbit fout 1)
         (gamma-encode fout (- match-len min-len))
         (pos-encode fout rp (- rp match-pos 1))))
       ;;
       (do ((n match-len (1- n)))
           ((zerop n))
           (insert-data sw rp)
           (incf rp)
           (when (>= rp slide-size2)
             (setf rp (update-slide sw rp))))
       (update-pos-bits rp))))

;;; ファイルの符号化
(defun encode-file (in-file out-file)
  (setf *pos-bits* 0)
  (call-with-bit-output-file
   out-file
   (lambda (fout)
     (call-with-byte-input-file
      in-file
      (lambda (fin)
        (let ((size (file-length fin)))
          (putbits fout 32 size)
          (when (plusp size)
            (encode fin fout))))))))

;;; LZSS 符号 : 復号
(defun decode (fin fout size)
  (do ((buff (make-array (ash 1 pos-bits) :element-type 'unsigned-byte))
       (rp 0))
      ((zerop size))
      (cond
       ((= (getbit fin) 1)
        (let ((num (+ (gamma-decode fin) min-len))
              (pos (- rp (1+ (pos-decode fin rp)))))
          (when (minusp pos)
            (incf pos (length buff)))
          (do ((num num (1- num)))
              ((zerop num))
              (let ((c (aref buff pos)))
                (write-byte c fout)
                (setf (aref buff rp) c)
                (incf pos)
                (incf rp)
                (when (>= pos (length buff))
                  (setf pos 0))
                (when (>= rp (length buff))
                  (setf rp 0))))
          (decf size num)))
       (t
        (let ((c (getbits fin 8)))
          (write-byte c fout)
          (setf (aref buff rp) c)
          (incf rp)
          (when (>= rp (length buff))
            (setf rp 0)))
        (decf size)))
      (update-pos-bits rp)))

;;; ファイルの復号
(defun decode-file (in-file out-file)
  (setf *pos-bits* 0)
  (call-with-bit-input-file
   in-file
   (lambda (fin)
     (let ((size (getbits fin 32)))
       (call-with-byte-output-file
        out-file
        (lambda (fout)
          (when (plusp size)
            (decode fin fout size))))))))

;;; 簡単なテスト
(defun test ()
  (let ((files '("alice29.txt" "asyoulik.txt" "cp.html" "fields.c" "grammar.lsp"
                 "kennedy.xls" "lcet10.txt" "plrabn12.txt" "ptt5" "sum" "xargs.1")))
    (format t "----- encode -----~%")
    (time
     (dolist (file files)
       (encode-file (format nil "./canterbury/~a" file)
                    (format nil "~a.en" file))))
    ;;
    (format t "----- decode -----~%")
    (time
     (dolist (file files)
       (decode-file (format nil "~a.en" file)
                    (format nil "~a.de" file))))))

• Canterbury Corpus で配布されているテストデータ The Canterbury Corpus の圧縮結果

* (load "lzb.lisp")
T

* (test)
----- encode -----
Evaluation took:
  6.430 seconds of real time
  6.427791 seconds of total run time (6.418078 user, 0.009713 system)
  [ Run times consist of 0.008 seconds GC time, and 6.420 seconds non-GC time. ]
  99.97% CPU
  15,427,297,480 processor cycles
  63,294,944 bytes consed

----- decode -----
Evaluation took:
  0.280 seconds of real time
  0.277130 seconds of total run time (0.277130 user, 0.000000 system)
  98.93% CPU
  665,122,649 processor cycles
  5,799,664 bytes consed

NIL

                表 : LZB 符号の結果
         (スライド窓 : 64 k, 最長一致長 : 256)

  ファイル名      サイズ   huffman     LZSS       LZB
  -----------------------------------------------------
  alice29.txt    152,089    87,785    68,332    58,824
  asyoulik.txt   125,179    75,895    61,789    53,841
  cp.html         24,603    16,310    10,278     8,890
  fields.c        11,150     7,143     3,859     3,507
  grammar.lsp      3,721     2,269     1,594     1,424
  kennedy.xls  1,029,744   462,856   291,968   334,869
  lcet10.txt     426,754   250,673   184,684   156,919
  plrabn12.txt   481,861   275,690   247,780   213,135
  ptt5           513,216   106,754   107,289    67,264
  sum             38,240    25,968    17,500    14,845
  xargs.1          4,227     2,698     2,198     1,985
  -----------------------------------------------------
  合計         2,810,784 1,314,041   997,271   915,501


      表 : 実行時間 (秒)

         : huff : LZSS : LZB
  -------+------+------+------
  符号化 : 0.60 : 1.66 : 6.43
   復号  : 0.35 : 0.30 : 0.28


実行環境 : SBCL 2.1.11, Ubunts 22.04 (WSL2), Intel Core i5-6200U 2.30GHz

• LZB 符号は、一致長と距離の符号化に可変長符号を使って圧縮率を改善する方法
• 今回のプログラムでは長さの符号化にγ符号を、距離の符号化に CBT 符号を使っている
• スライド窓の大きさを 64 k byte に増やしているので、符号化には時間がかかるようになる

●LZRC 符号

;;;
;;; lzrc.py : LZSS + Binary Range Coder
;;;
;;; Copyright (C) 2023 Makoto Hiroi
;;;
;;; Released under the MIT license
;;; https://opensource.org/license/mit/
;;;
(require :brc)
(use-package '(:brc :rangecoder))

;;; 定数
(defconstant min-len 4)
(defconstant max-len 256)
(defconstant pos-bits 16)                   ; 13 (8k), 15 (32k), 16 (64k)
(defconstant slide-size (ash 1 pos-bits))
(defconstant slide-size2 (* slide-size 2))
(defconstant slide-limit (+ slide-size2 max-len))

;;; ファイルサイズの書き込み
(defun write-file-size (out size)
  (write-byte (logand (ash size -24) #xff) out)
  (write-byte (logand (ash size -16) #xff) out)
  (write-byte (logand (ash size -8) #xff) out)
  (write-byte (logand size #xff) out))

;;; ファイルサイズの読み込み
(defun read-file-size (in)
  (+ (ash (read-byte in) 24)
     (ash (read-byte in) 16)
     (ash (read-byte in) 8)
     (read-byte in)))

;;; スライド窓
(defstruct slide-window stream buff ht data-size)

(defun initialize-slide-window (s)
  (let* ((buff (make-array slide-limit :element-type 'unsigned-byte))
         (data-size (read-sequence buff s)))
    (make-slide-window
     :stream s
     :buff buff
     :ht (make-hash-table)
     :data-size data-size)))

;;; ハッシュ値を求める
(defun hash-value (sw rp)
  (do ((buff (slide-window-buff sw))
       (value 0)
       (i 0 (1+ i)))
      ((>= i min-len) value)
      (setf value
            (+ (* value 256) (aref buff (+ rp i))))))

;;; データ入力
(defun read-data (sw start size)
  (read-sequence
   (slide-window-buff sw)
   (slide-window-stream sw)
   :start start
   :end (+ start size)))

;;; データ移動
(defun move-data (sw to from size)
  (let ((buff (slide-window-buff sw)))
    (dotimes (n size)
      (setf (aref buff (+ to n)) (aref buff (+ from n))))))

;;; スライド窓の更新
(defun update-slide (sw rp)
  (cond
   ((< (slide-window-data-size sw) slide-limit)
    ;; EOF
    rp)
   (t
    ;; buffer update
    (move-data sw 0 slide-size (+ slide-size max-len))
    (setf (slide-window-data-size sw)
          (read-data sw (+ slide-size max-len) slide-size))
    ;; hash update
    (maphash
     (lambda (k v)
       (if (< (car v) slide-size)
           (remhash k (slide-window-ht sw))
         (do ((xs v (cdr xs)))
             ((null xs))
             (decf (car xs) slide-size)
             (when (and (consp (cdr xs))
                        (< (cadr xs) slide-size))
               (setf (cdr xs) nil)))))
     (slide-window-ht sw))
    (- rp slide-size))))

;;; データの挿入
(defun insert-data (sw rp)
  (let ((value (hash-value sw rp))
        (ht (slide-window-ht sw)))
    (if (gethash value ht)
        (push rp (gethash value ht))
      (setf (gethash value ht) (list rp)))))

;;; 最長一致列の探索
(defun longest-match (buff s1 s2 &key (start 0) (limit max-len))
  (do ((i start (1+ i)))
      ((>= i limit) i)
      (unless (= (aref buff (+ s1 i)) (aref buff (+ s2 i)))
        (return i))))

(defun search-data (sw rp)
  (let ((buff (slide-window-buff sw))
        (value (hash-value sw rp))
        (low-limit (- rp slide-size))
        (match-len 0)
        (match-pos 0))
    (do ((xs (gethash value (slide-window-ht sw)) (cdr xs)))
        ((or (null xs)
             (< (car xs) low-limit)))
        (when (and (< (+ rp (max min-len match-len)) (slide-window-data-size sw))
                   (= (aref buff (+ rp match-len))
                      (aref buff (+ (car xs) match-len)))
          (let ((n (longest-match buff rp (car xs) :start 3)))
            (when (< match-len n)
              (setf match-len n
                    match-pos (car xs))
              (when (= n max-len)
                (return)))))))
    ;; データの終端をチェック
    (when (>= match-len (- (slide-window-data-size sw) rp))
      (setf match-len (- (slide-window-data-size sw) rp)))
    (values match-len match-pos)))

;;; LZRC 符号 : 符号化
(defun encode (rc fin)
  (do ((freq-flag (initialize-alpha-model 2))
       (freq-code (initialize-binary-model 256))
       (freq-len  (initialize-gamma-model (1+ (- max-len min-len))))
       (freq-pos  (initialize-gamma-model slide-size))
       (sw (initialize-slide-window fin))
       (rp 0))
      ((>= rp (slide-window-data-size sw)))
      (multiple-value-bind
       (match-len match-pos)
       (search-data sw rp)
       (cond
        ((< match-len min-len)
         (setf match-len 1)
         (alpha-encode rc freq-flag 0)
         (bm-encode rc freq-code (aref (slide-window-buff sw) rp)))
        (t
         (alpha-encode rc freq-flag 1)
         (gamma-encode rc freq-len (- match-len min-len))
         (gamma-encode rc freq-pos (- rp match-pos 1))))
       ;;
       (do ((n match-len (1- n)))
           ((zerop n))
           (insert-data sw rp)
           (incf rp)
           (when (>= rp slide-size2)
             (setf rp (update-slide sw rp)))))))

;;; ファイルの符号化
(defun encode-file (in-file out-file)
  (call-with-byte-output-file
   out-file
   (lambda (fout)
     (call-with-byte-input-file
      in-file
      (lambda (fin)
        (let ((size (file-length fin)))
          (write-file-size fout size)
          (when (plusp size)
            (call-with-range-encoder
             fout
             (lambda (rc)
               (encode rc fin))))))))))

;;; LZSS 符号 : 復号
(defun decode (rc fout size)
  (do ((freq-flag (initialize-alpha-model 2))
       (freq-code (initialize-binary-model 256))
       (freq-len  (initialize-gamma-model (1+ (- max-len min-len))))
       (freq-pos  (initialize-gamma-model slide-size))
       (buff (make-array (ash 1 pos-bits) :element-type 'unsigned-byte))
       (rp 0))
      ((zerop size))
      (cond
       ((= (alpha-decode rc freq-flag) 1)
        (let ((num (+ (gamma-decode rc freq-len) min-len))
              (pos (- rp (1+ (gamma-decode rc freq-pos)))))
          (when (minusp pos)
            (incf pos (length buff)))
          (do ((num num (1- num)))
              ((zerop num))
              (let ((c (aref buff pos)))
                (write-byte c fout)
                (setf (aref buff rp) c)
                (incf pos)
                (incf rp)
                (when (>= pos (length buff))
                  (setf pos 0))
                (when (>= rp (length buff))
                  (setf rp 0))))
          (decf size num)))
       (t
        (let ((c (bm-decode rc freq-code)))
          (write-byte c fout)
          (setf (aref buff rp) c)
          (incf rp)
          (when (>= rp (length buff))
            (setf rp 0)))
        (decf size)))))

;;; ファイルの復号
(defun decode-file (in-file out-file)
  (call-with-byte-input-file
   in-file
   (lambda (fin)
     (let ((size (read-file-size fin)))
       (call-with-byte-output-file
        out-file
        (lambda (fout)
          (when (plusp size)
            (call-with-range-decoder
             fin
             (lambda (rc)
               (decode rc fout size))))))))))

;;; 簡単なテスト
(defun test ()
  (let ((files '("alice29.txt" "asyoulik.txt" "cp.html" "fields.c" "grammar.lsp"
                 "kennedy.xls" "lcet10.txt" "plrabn12.txt" "ptt5" "sum" "xargs.1")))
    (format t "----- encode -----~%")
    (time
     (dolist (file files)
       (encode-file (format nil "./canterbury/~a" file)
                    (format nil "~a.en" file))))
    ;;
    (format t "----- decode -----~%")
    (time
     (dolist (file files)
       (decode-file (format nil "~a.en" file)
                    (format nil "~a.de" file))))))

• Canterbury Corpus で配布されているテストデータ The Canterbury Corpus の圧縮結果

* (load "lzrc.lisp")
T

* (test)
----- encode -----
Evaluation took:
  6.380 seconds of real time
  6.375988 seconds of total run time (6.375988 user, 0.000000 system)
  [ Run times consist of 0.010 seconds GC time, and 6.366 seconds non-GC time. ]
  99.94% CPU
  15,303,440,155 processor cycles
  71,041,536 bytes consed

----- decode -----
Evaluation took:
  1.020 seconds of real time
  1.024066 seconds of total run time (1.024066 user, 0.000000 system)
  100.39% CPU
  2,457,839,249 processor cycles
  6,025,984 bytes consed

NIL

                表 : LZRC 符号の結果
         (スライド窓 : 64 k, 最長一致 : 256)
         (LZRC改は :limit #x200, :inc 4 に変更)

  ファイル名      サイズ   huffman     LZSS      LZB       LZRC     LZRC改
  -------------------------------------------------------------------------
  alice29.txt    152,089    87,785    68,332    58,824    53,551    52,811
  asyoulik.txt   125,179    75,895    61,789    53,841    48,758    48,017
  cp.html         24,603    16,310    10,278     8,890     8,002     7,957
  fields.c        11,150     7,143     3,859     3,507     3,148     3,116
  grammar.lsp      3,721     2,269     1,594     1,424     1,212     1,220
  kennedy.xls  1,029,744   462,856   291,968   334,869   156,500    88,097
  lcet10.txt     426,754   250,673   184,684   156,919   140,917   139,935
  plrabn12.txt   481,861   275,690   247,780   213,135   190,825   190,350
  ptt5           513,216   106,754   107,289    67,264    52,840    51,536
  sum             38,240    25,968    17,500    14,845    13,383    12,591
  xargs.1          4,227     2,698     2,198     1,985     1,734     1,732
  -------------------------------------------------------------------------
  合計         2,810,784 1,314,041   997,271   915,501   670,870   597,362


      表 : 実行時間 (秒)

         : huff : LZSS : LZB  : LZRC :  改
  -------+------+------+------+------+------
  符号化 : 0.60 : 1.66 : 6.43 : 6.38 : 6.46
   復号  : 0.35 : 0.30 : 0.28 : 1.02 : 1.06


実行環境 : SBCL 2.1.11, Ubunts 22.04 (WSL2), Intel Core i5-6200U 2.30GHz

• LZRC 符号は、符号化にレンジコーダーを使って圧縮率を改善する方法
• 今回のプログラムではバイナリレンジコーダを使っている
• 記号の増分値 (:inc) を大きくして、出現頻度表の上限値 (:limit) を小さくすると、圧縮率が高くなる場合がある
• :inc 4, :limit #x200 とすると、kennedy.xls の圧縮率は大幅に向上した