[Small-cl-src] bit I/O

[Zach Beane]

;;;; The following stuff is taken, verbatim and somewhat unpolished,
;;;; from something I'm currently working on.

;;;;
;;;; Bit-level I/O. The Flash spec has various structures packed into
;;;; bit fields.
;;;;
;;;; $Id: bitio.lisp,v 1.5 2004/07/08 02:47:20 xach Exp $

(in-package :flash)


(defclass bitstream ()
  ((current-byte :initarg :current-byte :accessor current-byte)
   (bits-left :initarg :bits-left :accessor bits-left)
   (stream :initarg :stream :reader stream))
  (:documentation
   "A class for writing or reading bits to or from an (UNSIGNED-BYTE 8) stream."))



;;; Input

(defun make-input-bitstream (stream &key (current-byte 0) (bits-left 0))
  "Return a bitstream suitable for reading. The CURRENT-BYTE and
BITS-LEFT, if specified, initialize the internal byte buffer and
count."
  (assert (input-stream-p stream))
  (assert (subtypep (stream-element-type stream) '(unsigned-byte 8)))
  (make-instance 'bitstream
                 :stream stream
                 :current-byte current-byte
                 :bits-left bits-left))

(defmethod read-bits (width (bitstream bitstream) &optional (signedp nil))
  (with-accessors ((bits-left bits-left) (input stream)
                   (current-byte current-byte))
    bitstream
    (loop with result = 0
          with bits-needed = width
          while (plusp bits-needed)
          if (> bits-needed bits-left) do
          (setf result (logior (ash result bits-left)
                               (ldb (byte bits-left 0) current-byte))
                bits-needed (- bits-needed bits-left)
                current-byte (read-byte input)
                bits-left 8)
          else do
          (setf result (logior (ash result bits-needed)
                               (ldb (byte bits-needed (- bits-left
                                                         bits-needed))
                                    current-byte))
                bits-left (- bits-left bits-needed)
                bits-needed 0)
          finally (if (and signedp
                           (logbitp (1- width) result))
                      (return (1- (- (logandc2 (1- (ash 1 width)) result))))
                      (return result)))))

(defmethod read-boolean ((bitstream bitstream))
  "Read and return a single bit from BITSTREAM as a boolean."
  (logbitp 0 (read-bits 1 bitstream)))

(defmacro with-input-bitstream ((bitstream stream
                                  &key (current-byte 0) (bits-left 0))
                                 &body body)
  "Evaluate BODY with a newly-created input bitstream bound to BITSTREAM."
  (let ((-current-byte- (gensym))
        (-bits-left- (gensym)))
    `(let* ((,-current-byte- ,current-byte)
            (,-bits-left- ,bits-left)
            (,bitstream (make-input-bitstream ,stream
                                              :current-byte ,-current-byte-
                                              :bits-left ,-bits-left-)))
      , at body)))


;;; Output

(defun make-output-bitstream (stream &key (current-byte 0) (bits-left 8))
  "Return a bitstream suitable for writing. The CURRENT-BYTE and
BITS-LEFT, if specified, initialize the internal byte buffer and
count."
  (assert (output-stream-p stream))
  (assert (subtypep (stream-element-type stream) '(unsigned-byte 8)))
  (make-instance 'bitstream
                 :stream stream
                 :current-byte current-byte
                 :bits-left bits-left))

(defmethod write-bits (integer width (bitstream bitstream))
  "Write the rightmost WIDTH bits from INTEGER to the bitstream"
  (with-accessors ((bits-left bits-left) (stream stream)
                   (current-byte current-byte))
    bitstream
    (when (minusp integer)
      (setf integer (ldb (byte width 0) integer)))
    (loop with bits-needed = width
          while (plusp bits-needed)
          if (> bits-needed bits-left) do
          (setf (ldb (byte bits-left 0) current-byte)
                (ldb (byte bits-left (- bits-needed bits-left)) integer)
                bits-needed (- bits-needed bits-left))
          (write-byte current-byte stream)
          (setf current-byte 0
                bits-left 8)
          else do
          (setf (ldb (byte bits-needed (- bits-left bits-needed)) current-byte)
                (ldb (byte bits-needed 0) integer)
                bits-left (- bits-left bits-needed)
                bits-needed 0))))

(defmethod write-bit (bit (bitstream bitstream))
  "Write a single bit to the bitstream."
  (write-bits bit 1 bitstream))

(defmethod write-boolean (boolean (bitstream bitstream))
  "Write BOOLEAN as a bit to the bitstream."
  (if boolean
      (write-bit 1 bitstream)
      (write-bit 0 bitstream)))

(defmethod finish-write ((bitstream bitstream))
  "Flush the output buffer byte of BITSTREAM. Uninitialized bits are
written as 0."
  (when (< (bits-left bitstream) 8)
    (write-byte (current-byte bitstream) (stream bitstream))
    (setf (current-byte bitstream) 0)
    (setf (bits-left bitstream) 8)))

(defmacro with-output-bitstream ((bitstream stream
                                  &key (current-byte 0) (bits-left 8))
                                 &body body)
  "Evaluate BODY with a newly-created output bitstream bound to
BITSTREAM. Pending output is flushed at the end of evaluation."
  (let ((-current-byte- (gensym))
        (-bits-left- (gensym)))
    `(let* ((,-current-byte- ,current-byte)
            (,-bits-left- ,bits-left)
            (,bitstream (make-output-bitstream ,stream
                                               :current-byte ,-current-byte-
                                               :bits-left ,-bits-left-)))
      (unwind-protect
           (progn , at body)
        (finish-write ,bitstream)))))



(defun test-bitstreams (file width integer)
  (with-open-file (output file :direction :output
                          :element-type '(unsigned-byte 8)
                          :if-exists :supersede
                          :if-does-not-exist :create)
    (with-output-bitstream (bitstream output)
      (write-bits integer width bitstream)))
  (with-open-file (input file :direction :input
                         :element-type '(unsigned-byte 8))
    (with-input-bitstream (bitstream input)
      (list (read-bits width bitstream t) integer))))


;;; Utility

(defun sufficient-bits (&rest numbers)
  "Return the number of bits necessary to represent the largest number
in NUMBERS."
  (loop for number in numbers
        maximizing (1+ (integer-length number))))