--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/LICENSE.markdown Sat Jul 18 22:27:52 2020 -0400
@@ -0,0 +1,19 @@
+Copyright (c) 2020 Steve Losh and contributors
+
+Permission is hereby granted, free of charge, to any person obtaining a copy
+of this software and associated documentation files (the "Software"), to deal
+in the Software without restriction, including without limitation the rights
+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+SOFTWARE.
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/README.markdown Sat Jul 18 22:27:52 2020 -0400
@@ -0,0 +1,2 @@
+Code from [The Data Compression Book (2nd edition)](https://amzn.to/2ZGCj5R) in
+Common Lisp.
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/bit-streams.lisp Sat Jul 18 22:27:52 2020 -0400
@@ -0,0 +1,95 @@
+(in-package :tdcb)
+
+;;;; Common -------------------------------------------------------------------
+(defclass bit-stream (trivial-gray-streams:fundamental-binary-stream)
+ ((underlying-stream :accessor underlying-stream :initarg :underlying-stream :type stream)
+ (rack :accessor rack :type (unsigned-byte 8) :initform 0)
+ (mask :accessor mask :type (unsigned-byte 8) :initform #b10000000)))
+
+(defmethod close ((stream bit-stream) &key abort)
+ (when (open-stream-p (underlying-stream stream))
+ (close (underlying-stream stream) :abort abort)))
+
+(defmethod stream-element-type ((stream bit-stream))
+ 'bit)
+
+(defmethod stream-file-position ((stream bit-stream))
+ (error "Cannot change position of a bit stream."))
+
+
+;;;; Output -------------------------------------------------------------------
+(defclass bit-output-stream (bit-stream trivial-gray-streams:fundamental-binary-output-stream) ())
+
+(defun make-bit-output-stream (stream)
+ (make-instance 'bit-output-stream :underlying-stream stream))
+
+
+(declaim (inline write-bit%))
+(defun write-bit% (stream bit)
+ (when (plusp bit)
+ (logiorf (rack stream) (mask stream)))
+ (when (zerop (ashf (mask stream) -1))
+ (write-byte (rack stream) (underlying-stream stream))
+ (setf (rack stream) 0
+ (mask stream) #b10000000)))
+(defun write-bits (stream byte &optional (count 1))
+ (loop :with mask = (ash 1 (1- count))
+ :until (zerop mask)
+ :do (progn (write-bit% stream (logand mask byte))
+ (ashf mask -1)))
+ byte)
+
+
+(defmethod trivial-gray-streams:stream-write-byte ((stream bit-output-stream) bit)
+ (write-bit% stream bit))
+
+(defmethod close ((stream bit-output-stream) &key abort)
+ (declare (ignore abort))
+ (unless (= (mask stream) #b10000000)
+ (write-byte (rack stream) (underlying-stream stream)))
+ (call-next-method))
+
+(with-open-stream (s (make-bit-output-stream *standard-output*)) (write-byte #b00101010 s))
+
+
+;;;; Input -------------------------------------------------------------------
+(defclass bit-input-stream (bit-stream trivial-gray-streams:fundamental-binary-input-stream) ())
+
+(defun make-bit-input-stream (stream)
+ (make-instance 'bit-input-stream :underlying-stream stream))
+
+
+(declaim (inline read-bit))
+(defun read-bit (stream)
+ (when (= (mask stream) #b10000000)
+ (setf (rack stream) (read-byte (underlying-stream stream))))
+ (prog1 (if (zerop (logand (mask stream) (rack stream)))
+ 0
+ 1)
+ (when (zerop (ashf (mask stream) -1))
+ (setf (mask stream) #b10000000))))
+
+(defun read-bits (stream count)
+ (loop :with result = 0
+ :with mask = (ash 1 (1- count))
+ :until (zerop mask)
+ :do (progn (when (plusp (read-bit stream))
+ (logiorf result mask))
+ (ashf mask -1))
+ :finally (return result)))
+
+
+(defmethod trivial-gray-streams:stream-read-byte ((stream bit-input-stream))
+ (read-bit stream))
+
+
+#; Scratch --------------------------------------------------------------------
+
+(defparameter *o* (make-bit-output-stream *standard-output*))
+
+(defparameter *s* (flexi-streams:make-in-memory-input-stream #(#b00101010 #b01010100)))
+(defparameter *i* (make-bit-input-stream *s*))
+
+(losh:bits (read-bits *i* 4))
+
+(read-byte *s*)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/package.lisp Sat Jul 18 22:27:52 2020 -0400
@@ -0,0 +1,3 @@
+(defpackage :tdcb
+ (:use :cl)
+ (:export))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/utilities.lisp Sat Jul 18 22:27:52 2020 -0400
@@ -0,0 +1,7 @@
+(in-package :tdcb)
+
+(define-modify-macro ashf (count) ash "Arithmetic shift in place")
+(define-modify-macro logiorf (&rest integers) logior "Logical inclusive or in place")
+
+
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/tdcb.asd Sat Jul 18 22:27:52 2020 -0400
@@ -0,0 +1,15 @@
+(asdf:defsystem :tdcb
+ :description "The Data Compression Book in Common Lisp"
+ :author "Steve Losh <steve@stevelosh.com>"
+
+ :license "MIT"
+
+ :depends-on (:trivial-gray-streams)
+
+ :serial t
+ :components ((:module "src" :serial t
+ :components ((:file "package")
+ (:file "utilities")
+ (:file "bit-streams")))))
+
+