ビットストリーム -DEFLATE用-

RFC1951のDEFLATE圧縮データフォーマットを実装するために作成したビットストリーム。
DEFLATEを実装するのに当面必要な関数だけが定義してあり、インターフェースは適当。

;;;;;;;;;;;;;;;
;;;; パッケージ
(defpackage :bit-stream
  (:use :common-lisp)
  (:export :bit-stream
           :make-bit-stream
           :with-bit-stream
           :flush-bit-stream
           :read-bit
           :read-fixnum
           :write-bits
           :bits))
(in-package :bit-stream)

;;;;;;;;;;;
;;;; 構造体
;; バイナリストリームをラップしたビットストリーム用の構造体
(defstruct (bit-stream (:constructor make-bit-stream (stream)))
  stream    ; オリジナルのバイナリストリーム   ※ element-typeは(unsigned-byte 8)でなければならない
  (octet 0) ; 8bit整数: 要素数8のビットバッファ
  (pos 0))  ; octetの添字

;; 整数とビット長から、ビット配列を作成する
;; ex. (bits #b10 4) ==> #*0010
(defun bits (num bit-length)
  (let ((bits (make-array bit-length :element-type 'bit)))
    (dotimes (i bit-length bits)
      (setf (sbit bits i) (ldb (byte 1 (- bit-length 1 i)) num)))))

;; 引数のビット配列を出力する
;; reverse引数がtの場合は、bitsの上位ビットと下位ビットが逆転して出力される
;;  ex. (write-bits #*11110000 stream)            ==> 出力データ: #b11110000
;;      (write-bits #*11110000 stream :reverse t) ==> 出力データ: #b00001111
(defun write-bits (bits bit-stream &key reverse)
  (with-slots (stream octet pos) bit-stream
    (loop FOR bit ACROSS (if reverse bits (reverse bits)) DO
      (when (= 8 pos)
        (write-byte octet stream)
        (setf octet 0 pos 0))
      (setf (ldb (byte 1 pos) octet) bit)
      (incf pos))))

;; bit-streamのバッファに残っているデータを出力する
;; バッファ内のビット数が8未満の場合、足りない分は0ビットで埋められる
(defun flush-bit-stream (bit-stream)
  (with-slots (pos) bit-stream
    (write-bits (bits 0 (- 9 pos)) bit-stream)))

;; ビットストリームの作成および(確実な)終了を行うマクロ
(defmacro with-bit-stream ((stream source-binary-stream) &body body)
  `(let ((,stream (make-bit-stream ,source-binary-stream)))
     (unwind-protect
         (progn ,@body)
       (when (output-stream-p (bit-stream-stream ,stream))
         (flush-bit-stream ,stream)))))

;; ビットストリームから1ビット読み込む
(defun read-bit (bit-stream)
  (with-slots (stream octet pos) bit-stream
    (when (= 0 pos)
      (setf octet (read-byte stream))
      (setf pos 8))
    (prog1 
        (ldb (byte 1 (- 8 pos)) octet)
      (decf pos))))

;; ビットストリームからbit-lengthビット読み込む(固定ビット長の整数読込)
(defun read-fixnum (bit-length bit-stream)
  (loop FOR i FROM 0 BELOW bit-length 
        SUMMING (ash (read-bit bit-stream) i)))

使用例。

> (import 'bit-stream:bits)

;; ビット出力
> (with-open-file (out "test" :element-type '(unsigned-byte 8)
                              :direction :output)
    (bit-stream:with-bit-stream (bout out)
      (bit-stream:write-bits #*11100 bout)        ; 値:   28, ビット長: 5
      (bit-stream:write-bits (bits 1 4)     bout) ; 値:    1, ビット長: 4
      (bit-stream:write-bits (bits 2000 12) bout) ; 値: 2000, ビット長: 12
      'done))
--> DONE

;; ビット入力
> (with-open-file (in "test" :element-type '(unsigned-byte 8))
    (bit-stream:with-bit-stream (bin in)
      (print (bit-stream:read-fixnum 5  bin)) ; ビット長: 5
      (print (bit-stream:read-fixnum 4  bin)) ; ビット長: 4
      (print (bit-stream:read-fixnum 12 bin)) ; ビット長: 12
      'done))
28
1
2000
--> DONE