;;;; 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-))) ,@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 ,@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))))
(defpackage :bitstream (:use :cl))
(in-package :bitstream)
#|
An output bitstream.
The idea here is that there are three-ish values important when writing n bit chunks to a stream.
- a byte, acting as a buffer, accumulating the bits being written
- a counter to indicate when the byte buffer is full
- a stream to which full bytes are written
However, you can store the first two in a single unsigned 16-bit value. Then you can store the 16-bit value and the stream in a cons.
An empty byte buffer has the value #x00FF. Bits are added to the buffer by doing a LOGAND with a left shift. When the highest bit is set, the byte is written out and reset.
The number of bits written to the byte buffer so far is:
(logcount (logand #xFF00 buffer))
To finish writing a partially filled buffer, you can AND the high bits with the low bits to get the proper value:
(logand (ldb (byte 8 8) buffer) (ldb (byte 8 0) buffer))
FWIW, I don't know if this arrangement of the buffer is actually clever or useful. I spent a lot of time staring at the disassembly, so maybe it fried my brain.
|#
(defun make-output-bitstream (stream &key (current-byte 0) (bits-left 8)) (assert (output-stream-p stream)) (assert (subtypep (stream-element-type stream) '(unsigned-byte 8))) (cons stream (logior current-byte (ash #xFF (- 8 bits-left)))))
(declaim (inline iostream)) (defun iostream (bitstream) (car bitstream))
(declaim (inline buffer)) (defun buffer (bitstream) (the (unsigned-byte 16) (cdr bitstream)))
(declaim (inline (setf buffer))) (defun (setf buffer) (new-value bitstream) (declare (type (unsigned-byte 16) new-value)) (setf (cdr bitstream) new-value))
(declaim (inline write-bit)) (defun write-bit (bit bitstream) "Write the single BIT to BITSTREAM." (declare (bit bit) (optimize (speed 3) (safety 0))) (let ((n (buffer bitstream))) (cond ((logtest (ash 1 15) n) (write-byte (logand #xFF n) (iostream bitstream)) (setf (buffer bitstream) (logior (ash #x00FF 1) bit))) (t (setf (buffer bitstream) (logior (ash n 1) bit))))))
(defun write-bits (integer width bitstream) "Write the leftmost WIDTH bits of INTEGER to BITSTREAM." (declare (integer integer) (type (unsigned-byte 29) width) (optimize (speed 3) (safety 0))) (when (minusp integer) (setf integer (ldb (byte width 0) integer))) (loop for i downfrom (1- width) to 0 do (write-bit (ldb (byte 1 i) integer) bitstream)))
(defun finish-write (bitstream) (declare (optimize (speed 3) (safety 0))) (let* ((n (buffer bitstream)) (final-byte (logand (ldb (byte 8 8) n) (ldb (byte 8 0) n)))) (write-byte final-byte (iostream bitstream)) (setf (buffer bitstream) #xFF00)))
(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 ,@body) (finish-write ,bitstream)))))
(defun test-packed (file count value width) (with-open-file (stream file :direction :output :if-exists :supersede :element-type '(unsigned-byte 8)) (with-output-bitstream (bitstream stream) (dotimes (i count) (write-bits value width bitstream)))))
-
Zach Beane