# HG changeset patch # User Steve Losh # Date 1595125672 14400 # Node ID adcbdf9b281a396aff6539803b92f61ff9299e49 Initial commit diff -r 000000000000 -r adcbdf9b281a LICENSE.markdown --- /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. diff -r 000000000000 -r adcbdf9b281a README.markdown --- /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. diff -r 000000000000 -r adcbdf9b281a src/bit-streams.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*) diff -r 000000000000 -r adcbdf9b281a src/package.lisp --- /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)) diff -r 000000000000 -r adcbdf9b281a src/utilities.lisp --- /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") + + + diff -r 000000000000 -r adcbdf9b281a tdcb.asd --- /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 " + + :license "MIT" + + :depends-on (:trivial-gray-streams) + + :serial t + :components ((:module "src" :serial t + :components ((:file "package") + (:file "utilities") + (:file "bit-streams"))))) + +