Common Lisp Programming

bitio

bitio はビット単位でファイル入出力を行うためのライブラリです。bitio には整数を符号化するための関数も含まれています。詳しい説明は以下の拙作のページをお読みください。

• Common Lisp 入門:
• ハフマン符号 (2)
• 整数の符号化

●インストール

アーカイブファイル minlib.tar.gz をインストールする、または プログラムリスト にある以下の 4 つのファイルを、~/common-lisp/ 以下の適当なサブディレクトリ (たとえば bitio など) に配置してください。

• bitio.lisp
• bitio.asd
• bitio_tst.lisp
• bitio_tst.asd

●仕様

• パッケージ名 :bitio
• データ型 bit-io, (ビットストリームを表す構造体)
• 型述語 bit-io-p

• ファイルのオープン
• call-with-byte-input-file filename proc
  入力用バイトストリームをオープンし、それを関数 proc に渡して呼び出します。
  proc は 1 引数の関数です。filename はオープンするファイル名です。
• call-with-byte-output-file filename proc
  出力用バイトストリームをオープンし、それを関数 proc に渡して呼び出します。
  proc は 1 引数の関数です。filename はオープンするファイル名です。
• call-with-bit-input-file filename proc
  入力用ビットストリームをオープンし、それを関数 proc に渡して呼び出します。
  proc は 1 引数の関数です。filename はオープンするファイル名です。
• call-with-bit-output-file filename proc
  出力用ビットストリームをオープンし、それを関数 proc に渡して呼び出します。
  proc は 1 引数の関数です。filename はオープンするファイル名です。

• 入出力関数
• getbit bs
  ビットストリーム bs より 1 ビット読み込みます。ファイルの終了は nil を返します。
• getbits bs b
  ビットストリーム bs より n ビット読み込みます。ファイルの終了は nil を返します。
• putbit bs bit
  ビットストリーム bs へ 1 ビット出力します。
• putbits bs n code
  ビットストリーム bs へ code の下位 n ビットを出力します。
• alpha_encode bs n
  整数 n を α符号で符号化し、それをビットストリーム bs へ出力します。
• alpha_decode bs
  ビットストリーム bs よりα符号を読み込んで整数 n を返します。
• gamma_encode bs n
  整数 n を γ符号で符号化し、それをビットストリーム bs へ出力します。
• gamma_decode bs
  ビットストリーム bs より γ符号を読み込んで整数 n を返します。
• delta_encode bs n
  整数 n を δ符号で符号化し、それをビットストリーム bs へ出力します。
• delta_decode bs
  ビットストリーム bs より δ符号を読み込んで整数 n を返します。
• cbt-encode bs n m k
  整数 n を CBT 符号 (パラメータ m, k) で符号化し、それをビットストリーム bs へ出力します。
• cbt-decode bs m k
  ビットストリーム bs より CBT 符号 (パラメータ m, k) を読み込んで整数 n を返します。
• rice-encode bs n m k
  整数 n を rice 符号 (パラメータ k) で符号化し、それをビットストリーム bs へ出力します。
• rice-decode bs k
  ビットストリーム bs より rice 符号 (パラメータ k) を読み込んで整数 n を返します。

●簡単なテスト

* (asdf:test-system :bitio)
; ... 略 ...

----- test start -----

(PUTBIT BS 0)
=> NIL OK

(PUTBIT BS 1)
=> NIL OK

(PUTBITS BS 4 10)
=> NIL OK

(PUTBITS BS 8 85)
=> NIL OK

(ALPHA-ENCODE BS 16)
=> NIL OK

(GAMMA-ENCODE BS 17)
=> NIL OK

(DELTA-ENCODE BS 18)
=> NIL OK

(CBT-ENCODE BS 11 12 4)
=> NIL OK

(RICE-ENCODE BS 15 3)
=> NIL OK

(GETBIT BS)
=> 0 OK

(GETBIT BS)
=> 1 OK

(GETBITS BS 4)
=> 10 OK

(GETBITS BS 8)
=> 85 OK

(ALPHA-DECODE BS)
=> 16 OK

(GAMMA-DECODE BS)
=> 17 OK

(DELTA-DECODE BS)
=> 18 OK

(CBT-DECODE BS 12 4)
=> 11 OK

(RICE-DECODE BS 3)
=> 15 OK

----- test end -----
TEST: 18
OK: 18
NG: 0
ERR: 0
T

●サンプルプログラム

• ハフマン符号
• 詳しい説明は拙作のページをお読みください。
• ヒープとハフマン符号
• ハフマン符号 (2)

;;;
;;; huffman.lisp : ハフマン符号によるファイルの圧縮
;;;
;;; Copyright (c) 2023 Makoto Hiroi
;;;
;;; Released under the MIT license
;;; https://opensource.org/license/mit/
;;;
(require :heap)
(use-package :heap)
(require :bitio)
(use-package :bitio)

;;; 符号語のサイズ
(defconstant code-size 256)

;;; 符号木の節
(defstruct node
  (sym nil) (cnt 0) (left nil) (right nil))

;;; 葉か？
(defun leafp (node) (numberp (node-sym node)))

;;; 記号の出現頻度を求める
(defun make-frequency (filename)
  (call-with-byte-input-file
   filename
   (lambda (in)
     (do ((table (make-array code-size :initial-element 0))
          (cnt 0 (1+ cnt))
          (c (read-byte in nil) (read-byte in nil)))
         ((null c) (values cnt table))
         (incf (aref table c))))))

;;; 符号木の生成
(defun make-huffman-tree (freq)
  (let ((hp (make-heap :key #'node-cnt)))
    (dotimes (x code-size)
      (when (plusp (aref freq x))
        (heap-push hp (make-node :sym x :cnt (aref freq x)))))
    (case (heap-count hp)
      ((0) nil)
      ((1)
       (let ((node (heap-pop hp)))
         (make-node :left node
                    :right (make-node :sym (if (plusp (node-sym node)) 0 1)))))
      (t
       (do ()
           ((= (heap-count hp) 1) (heap-pop hp))
         (let ((a (heap-pop hp)) (b (heap-pop hp)))
           (heap-push hp
                      (make-node :cnt (+ (node-cnt a) (node-cnt b))
                                 :left a
                                 :right b))))))))

;;; ハフマン符号の生成
(defun make-huffman-code (node n cs code)
  (if (leafp node)
      (setf (aref code (node-sym node)) (list n cs))
    (progn
      (make-huffman-code (node-left node) (1+ n) (logior (ash cs 1) 1) code)
      (make-huffman-code (node-right node) (1+ n) (ash cs 1) code))))

;;; ハフマン木の出力
(defun write-huffman-tree (bs node)
  (cond ((leafp node)
         (putbit bs 1)
         (putbits bs 8 (node-sym node)))
        (t
         (putbit bs 0)
         (write-huffman-tree bs (node-left node))
         (write-huffman-tree bs (node-right node)))))

;;; ハフマン木の入力
(defun read-huffman-tree (bs)
  (if (= (getbit bs) 1)
      (make-node :sym (getbits bs 8))
    (make-node :left (read-huffman-tree bs)
               :right (read-huffman-tree bs))))

;;; 符号化
(defun huffman-encode (in-file out-file)
  (multiple-value-bind
      (size freq)
      (make-frequency in-file)
    (call-with-bit-output-file
     out-file
     (lambda (bs)
       (putbits bs 32 size)
       (when (plusp size)
         (let ((tree (make-huffman-tree freq))
               (code (make-array code-size)))
           (make-huffman-code tree 0 0 code)
           (call-with-byte-input-file
            in-file
            (lambda (in)
              (write-huffman-tree bs tree)
              (dotimes (x size)
                (apply #'putbits bs (aref code (read-byte in))))))))))))

;;; 記号を復号する
(defun decode-symbol (node bs)
  (do ()
      ((leafp node) (node-sym node))
    (setf node (if (plusp (getbit bs))
                   (node-left node)
                 (node-right node)))))

;;; 復号
(defun huffman-decode (in-file out-file)
  (call-with-bit-input-file
   in-file
   (lambda (bs)
     (let* ((size (getbits bs 32))
            (tree (if (plusp size) (read-huffman-tree bs))))
       (call-with-byte-output-file
        out-file
        (lambda (out)
          (dotimes (x size)
            (write-byte (decode-symbol tree bs) out))))))))

;;; 簡単なテスト
(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)
       (huffman-encode (format nil "./canterbury/~a" file)
                       (format nil "~a.en" file))))
    ;;
    (format t "----- decode -----~%")
    (time
     (dolist (file files)
       (huffman-decode (format nil "~a.en" file)
                       (format nil "~a.de" file))))))

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

* (load "huffman.lisp")
T

* (test)
----- encode -----
Evaluation took:
  0.600 seconds of real time
  0.448260 seconds of total run time (0.447588 user, 0.000672 system)
  74.67% CPU
  27 lambdas converted
  1,454,019,454 processor cycles
  1,645,616 bytes consed

----- decode -----
Evaluation took:
  0.350 seconds of real time
  0.347864 seconds of total run time (0.347755 user, 0.000109 system)
  99.43% CPU
  834,886,537 processor cycles
  163,472 bytes consed

NIL

      表 : ハフマン符号の結果

  ファイル名      サイズ     下限値   ハフマン
  ---------------------------------------------
  alice29.txt    152,089     86,837     87,785
  asyoulik.txt   125,179     75,235     75,895
  cp.html         24,603     16,082     16,310
  fields.c        11,150      6,980      7,143
  grammar.lsp      3,721      2,155      2,269
  kennedy.xls  1,029,744    459,970    462,856
  lcet10.txt     426,754    249,071    250,673
  plrabn12.txt   481,861    272,936    275,690
  ptt5           513,216     77,636    106,754
  sum             38,240     25,473     25,968
  xargs.1          4,227      2,589      2,698
  ---------------------------------------------
  合計         2,810,784  1,274,964  1,314,041

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

• Move To Front 法
• 詳しい説明は拙作のページをお読みください。
• Common Lisp 入門: 整数の符号化
• Algorithms with Python: ブロックソート [1]

;;;
;;; mtf.lisp : move to front によるファイルの圧縮
;;;
;;; Copyright (c) 2023 Makoto Hiroi
;;;
;;; Released under the MIT license
;;; https://opensource.org/license/mit/
;;;
(require :bitio)
(use-package :bitio)

;;; n 番目の要素を先頭へ移動する
(defun move-to-front (table n)
  (when (plusp n)
    (do ((c (aref table n))
         (x n (1- x)))
        ((zerop x)
         (setf (aref table x) c))
      (setf (aref table x)
            (aref table (1- x))))))

;;; 初期化
(defun initialize-mtf-table (size)
  (let ((table (make-array size)))
    (dotimes (x size table)
      (setf (aref table x) x))))

;;; MTF による符号化
(defun mtf-encode (table c)
  (let ((n (position c table)))
    (move-to-front table n)
    n))

;;; MTF による復号
(defun mtf-decode (table n)
  (prog1
      (aref table n)
    (move-to-front table n)))

;;; ファイルの符号化
(defun mtf-encode-file (in-file out-file)
  (call-with-bit-output-file
   out-file
   (lambda (bs)
     (call-with-byte-input-file
      in-file
      (lambda (in)
        (let ((size (file-length in))
              (table (initialize-mtf-table 256)))
          (putbits bs 32 size)
          (when (plusp size)
            (dotimes (x size)
              (gamma-encode bs (mtf-encode table (read-byte in)))))))))))

;;; ファイルの復号
(defun mtf-decode-file (in-file out-file)
  (call-with-bit-input-file
   in-file
   (lambda (bs)
     (let ((size (getbits bs 32))
           (table (initialize-mtf-table 256)))
       (call-with-byte-output-file
        out-file
        (lambda (out)
          (when (plusp size)
            (dotimes (x size)
              (write-byte (mtf-decode table (gamma-decode bs))
                          out)))))))))

;;; 簡単なテスト
(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)
       (mtf-encode-file (format nil "./canterbury/~a" file)
                        (format nil "~a.en" file))))
    ;;
    (format t "----- decode -----~%")
    (time
     (dolist (file files)
       (mtf-decode-file (format nil "~a.en" file)
                        (format nil "~a.de" file))))))

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

* (load "mtf.lisp")
T

* (test)
----- encode -----
Evaluation took:
  1.409 seconds of real time
  1.418301 seconds of total run time (1.408051 user, 0.010250 system)
  100.64% CPU
  3,404,216,389 processor cycles
  64,176 bytes consed

----- decode -----
Evaluation took:
  0.810 seconds of real time
  0.808624 seconds of total run time (0.808599 user, 0.000025 system)
  99.88% CPU
  1,943,106,750 processor cycles
  64,000 bytes consed

NIL

表 : Move To Front 法 + 整数の符号化 の実行結果

  ファイル名      サイズ    γ符号
  ---------------------------------
  alice29.txt    152,089   127,306
  asyoulik.txt   125,179   110,855
  cp.html         24,603    22,767
  fields.c        11,150     9,391
  grammar.lsp      3,721     2,993
  kennedy.xls  1,029,744   583,363
  lcet10.txt     426,754   352,109
  plrabn12.txt   481,861   415,204
  ptt5           513,216   119,162
  sum             38,240    28,482
  xargs.1          4,227     3,722
  ---------------------------------
  合計         2,810,784 1,775,354

• 記号の出現確率を使って符号化するハフマン符号やレンジコーダにはかないませんが、このような簡単な方法でもデータを圧縮することができます。

●プログラムリスト

;;;
;;; bitio.lisp : ビット入出力
;;;
;;; Copyright (c) 2023 Makoto Hiroi
;;;
;;; Released under the MIT license
;;; https://opensource.org/license/mit/
;;;
(provide :bitio)
(defpackage :bitio (:use :cl))
(in-package :bitio)
(export '(bit-io
          bit-io-p
          call-with-bit-input-file
          call-with-byte-input-file
          call-with-bit-output-file
          call-with-byte-output-file
          getbit
          getbits
          putbit
          putbits
          alpha-encode
          alpha-decode
          gamma-encode
          gamma-decode
          delta-encode
          delta-decode
          cbt-encode
          cbt-decode
          rice-encode
          rice-decode))

;;; 型の定義
(defstruct bit-io direction file buff cnt)

;;; バイト入力用ファイルオープン
(defun call-with-byte-input-file (filename proc)
  (with-open-file (in filename
                      :direction :input
                      :element-type 'unsigned-byte)
    (funcall proc in)))

;;; バイト出力用ファイルオープン
(defun call-with-byte-output-file (filename proc)
  (with-open-file (out filename
                       :direction :output
                       :if-exists :rename-and-delete
                       :element-type 'unsigned-byte)
    (funcall proc out)))

;;; ビット入力用ファイルオープン
(defun call-with-bit-input-file (filename proc)
  (call-with-byte-input-file
   filename
   (lambda (in)
     (funcall proc (make-bit-io :direction :input
                                :file in
                                :cnt 0)))))

;;; ビット出力用ファイルオープン
(defun call-with-bit-output-file (filename proc)
  (call-with-byte-output-file
   filename
   (lambda (out)
     (let ((bs (make-bit-io :direction :output
                            :file out
                            :buff 0
                            :cnt 8)))
       (funcall proc bs)
       (if (< (bit-io-cnt bs) 8)
           (write-byte (bit-io-buff bs) out))))))

;;; 1 ビット入力
(defun getbit (bs)
  (decf (bit-io-cnt bs))
  (when (minusp (bit-io-cnt bs))
    (setf (bit-io-buff bs)
          (read-byte (bit-io-file bs) nil))
    (if (null (bit-io-buff bs))
        (return-from getbit nil))
    (setf (bit-io-cnt bs) 7))
  (if (logbitp (bit-io-cnt bs) (bit-io-buff bs)) 1 0))

;;; 1 ビット出力
(defun putbit (bs val)
  (decf (bit-io-cnt bs))
  (when (plusp val)
    (setf (bit-io-buff bs)
          (logior (bit-io-buff bs) (ash 1 (bit-io-cnt bs)))))
  (when (zerop (bit-io-cnt bs))
    (write-byte (bit-io-buff bs) (bit-io-file bs))
    (setf (bit-io-buff bs) 0
          (bit-io-cnt bs) 8)))

;;; n ビット入力
(defun getbits (bs n)
  (do ((pat (ash 1 (1- n)) (ash pat -1))
       (val 0))
      ((zerop pat) val)
    (case (getbit bs)
      (1 (setf val (logior val pat)))
      (nil (return)))))

;;; n ビット出力
(defun putbits (bs n x)
  (do ((pat (ash 1 (1- n)) (ash pat -1)))
      ((zerop pat))
      (putbit bs (logand x pat))))

;;;
;;; 整数の符号化
;;;

;;; α符号
(defun alpha-encode (bs n)
  (putbits bs n 0)
  (putbit bs 1))

(defun alpha-decode (bs)
  (do ((n 0 (1+ n)))
      ((plusp (getbit bs)) n)))

;;; γ符号
(defun gamma-encode (bs n)
  (do ((n1 0 (1+ n1))
       (n2 (ash (1+ n) -1) (ash n2 -1)))
      ((zerop n2)
       (alpha-encode bs n1)
       (if (plusp n1) (putbits bs n1 (1+ n))))))

(defun gamma-decode (bs)
  (let ((n1 (alpha-decode bs)))
    (if (zerop n1)
        0
      (+ (ash 1 n1) (getbits bs n1) -1))))

;;; δ符号
(defun delta-encode (bs n)
  (do ((n1 0 (1+ n1))
       (n2 (ash (1+ n) -1) (ash n2 -1)))
      ((zerop n2)
       (gamma-encode bs n1)
       (if (plusp n1) (putbits bs n1 (1+ n))))))

(defun delta-decode (bs)
  (let ((n1 (gamma-decode bs)))
    (if (zerop n1)
        0
      (+ (ash 1 n1) (getbits bs n1) -1))))

;;; CBT 符号
(defun cbt-encode (bs n m k)
  (let ((limit (- (ash 1 k) m)))
    (if (< n limit)
        (putbits bs (1- k) n)
      (putbits bs k (+ n limit)))))

(defun cbt-decode (bs m k)
  (let ((limit (- (ash 1 k) m))
        (n (getbits bs (1- k))))
    (if (< n limit)
        n
      (+ (ash n 1) (getbit bs) (- limit)))))

;;; Rice 符号
(defun rice-encode (bs n k)
  (alpha-encode bs (ash n (- k)))
  (putbits bs k n))

(defun rice-decode (bs k)
  (let ((n (alpha-decode bs)))
    (+ (ash n k) (getbits bs k))))

リスト : bitio.asd

(defsystem :bitio
  :description "bit input / output"
  :version "0.1.0"
  :author "Makoto Hiroi"
  :license "MIT"
  :depends-on ()
  :in-order-to ((test-op (test-op :bitio_tst)))
  :components ((:file "bitio")))

;;;
;;; bitio_tst.lisp : bitio のテスト
;;;
;;; Copyright (c) 2023 Makoto Hiroi
;;;
;;; Released under the MIT license
;;; https://opensource.org/license/mit/
;;;
(provide :bitio_tst)
(defpackage :bitio_tst (:use :cl :bitio :mintst))
(in-package :bitio_tst)
(export '(test))

(defvar bs nil)

(defun test ()
  (initial)
  (call-with-bit-output-file
   "bitio_tst.dat"
   (lambda (s)
     (setq bs s)
     (run (putbit bs 0) nil)
     (run (putbit bs 1) nil)
     (run (putbits bs 4 #b1010) nil)
     (run (putbits bs 8 #b01010101) nil)
     (run (alpha-encode bs 16) nil)
     (run (gamma-encode bs 17) nil)
     (run (delta-encode bs 18) nil)
     (run (cbt-encode bs 11 12 4) nil)
     (run (rice-encode bs 15 3) nil)
     (setq bs nil)))
  (call-with-bit-input-file
   "bitio_tst.dat"
   (lambda (s)
     (setq bs s)
     (run (getbit bs) 0)
     (run (getbit bs) 1)
     (run (getbits bs 4) #b1010)
     (run (getbits bs 8) #b01010101)
     (run (alpha-decode bs) 16)
     (run (gamma-decode bs) 17)
     (run (delta-decode bs) 18)
     (run (cbt-decode bs 12 4) 11)
     (run (rice-decode bs 3) 15)
     (setq bs nil)))
  (final))

リスト : bitio_tst.asd

(defsystem :bitio_tst
  :description "test for bitio"
  :version "0.1.0"
  :author "Makoto Hiroi"
  :license "MIT"
  :depends-on (:mintst :bitio)
  :components ((:file "bitio_tst"))
  :perform (test-op (o s) (symbol-call :bitio_tst :test)))