;;;; 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))))