compressor.lisp

   1 ;;;
   2 ;;; Copyright (c) 2007 Zachary Beane, All Rights Reserved
   3 ;;;
   4 ;;; Redistribution and use in source and binary forms, with or without
   5 ;;; modification, are permitted provided that the following conditions
   6 ;;; are met:
   7 ;;;
   8 ;;;   * Redistributions of source code must retain the above copyright
   9 ;;;     notice, this list of conditions and the following disclaimer.
  10 ;;;
  11 ;;;   * Redistributions in binary form must reproduce the above
  12 ;;;     copyright notice, this list of conditions and the following
  13 ;;;     disclaimer in the documentation and/or other materials
  14 ;;;     provided with the distribution.
  15 ;;;
  16 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
  17 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
  18 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  19 ;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
  20 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  21 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
  22 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
  23 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
  24 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
  25 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
  26 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  27 ;;;
  28
  29 (in-package #:salza2)
  30
  31 (defun make-input ()
  32   (make-array 65536 :element-type 'octet))
  33
  34 (defun make-chains ()
  35   (make-array 65536
  36               :element-type '(unsigned-byte 16)
  37               :initial-element 0))
  38
  39 (defun make-hashes ()
  40   (make-array +hashes-size+
  41               :element-type '(unsigned-byte 16)
  42               :initial-element 0))
  43
  44 (defun error-missing-callback (&rest args)
  45   (declare (ignore args))
  46   (error "No callback given for compression"))
  47
  48 ;;; FIXME: MERGE-INPUT is pretty ugly. It's the product of incremental
  49 ;;; evolution and experimentation. It should be cleaned up.
  50 ;;;
  51 ;;; Its basic purpose is to use octets from INPUT to fill up 32k-octet
  52 ;;; halves of the 64k-octet OUTPUT buffer. Whenever a half fills up,
  53 ;;; the COMPRESS-FUN is invoked to compress that half. At the end, a
  54 ;;; partial half may remain uncompressed to be either filled by a
  55 ;;; future call to MERGE-INPUT or to get flushed out by a call to
  56 ;;; FINAL-COMPRESS.
  57
  58 (defun merge-input (input start count output offset compress-fun)
  59   "Merge COUNT octets from START of INPUT into OUTPUT at OFFSET;
  60 on reaching 32k boundaries within OUTPUT, call the COMPRESS-FUN
  61 with OUTPUT, a starting offset, and the count of pending data."
  62   (declare (type octet-vector input output))
  63   (let ((i start)
  64         (j (+ start (min count (- +input-limit+ (mod offset +input-limit+)))))
  65         (result (logand +buffer-size-mask+ (+ offset count))))
  66     (dotimes (k (ceiling (+ (logand offset +input-limit-mask+) count)
  67                          +input-limit+))
  68       (when (plusp k)
  69         (funcall compress-fun
  70                  output
  71                  (logxor offset #x8000)
  72                  +input-limit+))
  73       (replace output input :start1 offset :start2 i :end2 j)
  74       (setf offset (logand +input-limit+ (+ offset +input-limit+)))
  75       (setf i j
  76             j (min (+ start count) (+ j +input-limit+))))
  77     (when (zerop (logand result +input-limit-mask+))
  78       (funcall compress-fun output (logxor offset #x8000) +input-limit+))
  79     result))
  80
  81 (defun reinitialize-bitstream-funs (compressor bitstream)
  82   (setf (literal-fun compressor)
  83         (make-huffman-writer *fixed-huffman-codes* bitstream)
  84         (length-fun compressor)
  85         (make-huffman-writer *length-codes* bitstream)
  86         (distance-fun compressor)
  87         (make-huffman-writer *distance-codes* bitstream)
  88         (compress-fun compressor)
  89         (make-compress-fun compressor)))
  90
  91
  92 ;;; Class & protocol
  93
  94 (defclass deflate-compressor ()
  95   ((input
  96     :initarg :input
  97     :accessor input)
  98    (chains
  99     :initarg :chains
 100     :accessor chains)
 101    (hashes
 102     :initarg :hashes
 103     :accessor hashes)
 104    (start
 105     :initarg :start
 106     :accessor start)
 107    (end
 108     :initarg :end
 109     :accessor end)
 110    (counter
 111     :initarg :counter
 112     :accessor counter)
 113    (octet-buffer
 114     :initarg :octet-buffer
 115     :accessor octet-buffer)
 116    (bitstream
 117     :initarg :bitstream
 118     :accessor bitstream)
 119    (literal-fun
 120     :initarg :literal-fun
 121     :accessor literal-fun)
 122    (length-fun
 123     :initarg :length-fun
 124     :accessor length-fun)
 125    (distance-fun
 126     :initarg :distance-fun
 127     :accessor distance-fun)
 128    (byte-fun
 129     :initarg :byte-fun
 130     :accessor byte-fun)
 131    (compress-fun
 132     :initarg :compress-fun
 133     :accessor compress-fun))
 134   (:default-initargs
 135    :input (make-input)
 136    :chains (make-chains)
 137    :hashes (make-hashes)
 138    :start 0
 139    :end 0
 140    :counter 0
 141    :bitstream (make-instance 'bitstream)
 142    :octet-buffer (make-octet-vector 1)))
 143
 144 ;;; Public protocol GFs
 145
 146 (defgeneric start-data-format (compressor)
 147   (:documentation "Add any needed prologue data to the output bitstream."))
 148
 149 (defgeneric compress-octet (octet compressor)
 150   (:documentation "Add OCTET to the compressed data of COMPRESSOR."))
 151
 152 (defgeneric compress-octet-vector (vector compressor &key start end)
 153   (:documentation "Add the octets of VECTOR to the compressed
 154   data of COMPRESSOR."))
 155
 156 (defgeneric process-input (compressor input start count)
 157   (:documentation "Map over pending octets in INPUT and perform
 158   any needed processing. Called before the data is compressed. A
 159   subclass might use this to compute a checksum of all input
 160   data."))
 161
 162 (defgeneric finish-data-format (compressor)
 163   (:documentation "Add any needed epilogue data to the output bitstream."))
 164
 165 (defgeneric finish-compression (compressor)
 166   (:documentation "Finish the data format and flush all pending
 167   data in the bitstream."))
 168
 169 ;;; Internal GFs
 170
 171 (defgeneric final-compress (compressor)
 172   (:documentation "Perform the final compression on pending input
 173   data in COMPRESSOR."))
 174
 175 (defgeneric make-compress-fun (compressor)
 176   (:documentation "Create a callback suitable for passing to
 177   MERGE-INPUT for performing incremental compression of the next
 178   32k octets of input."))
 179
 180 ;;; Methods
 181
 182 (defmethod initialize-instance :after ((compressor deflate-compressor)
 183                                        &rest initargs
 184                                        &key
 185                                        literal-fun length-fun distance-fun
 186                                        compress-fun
 187                                        callback)
 188   (declare (ignore initargs))
 189   (let ((bitstream (bitstream compressor)))
 190     (setf (callback bitstream)
 191           (or callback #'error-missing-callback))
 192     (setf (literal-fun compressor)
 193           (or literal-fun (make-huffman-writer *fixed-huffman-codes*
 194                                                bitstream)))
 195     (setf (length-fun compressor)
 196           (or length-fun (make-huffman-writer *length-codes*
 197                                               bitstream)))
 198     (setf (distance-fun compressor)
 199           (or distance-fun (make-huffman-writer *distance-codes*
 200                                                 bitstream)))
 201     (setf (compress-fun compressor)
 202           (or compress-fun (make-compress-fun compressor)))
 203     (start-data-format compressor)))
 204
 205 ;;; A few methods defer to the bitstream
 206
 207 (defmethod (setf callback) (new-fun (compressor deflate-compressor))
 208   (let ((bitstream (bitstream compressor)))
 209     (prog1
 210         (setf (callback bitstream) new-fun)
 211       (reinitialize-bitstream-funs compressor bitstream))))
 212
 213 (defmethod write-bits (code size (compressor deflate-compressor))
 214   (write-bits code size (bitstream compressor)))
 215
 216 (defmethod write-octet (octet (compressor deflate-compressor))
 217   (write-octet octet (bitstream compressor)))
 218
 219 (defmethod write-octet-vector (vector (compressor deflate-compressor)
 220                                &key (start 0) end)
 221   (write-octet-vector vector (bitstream compressor)
 222                       :start start
 223                       :end end))
 224
 225
 226 (defmethod start-data-format ((compressor deflate-compressor))
 227   (let ((bitstream (bitstream compressor)))
 228     (write-bits +final-block+ 1 bitstream)
 229     (write-bits +fixed-tables+ 2 bitstream)))
 230
 231 (defmethod compress-octet (octet compressor)
 232   (let ((vector (octet-buffer compressor)))
 233     (setf (aref vector 0) octet)
 234     (compress-octet-vector vector compressor)))
 235
 236 (defmethod compress-octet-vector (vector compressor &key (start 0) end)
 237   (let* ((closure (compress-fun compressor))
 238          (end (or end (length vector)))
 239          (count (- end start)))
 240     (let ((end
 241            (merge-input vector start count
 242                         (input compressor)
 243                         (end compressor)
 244                         closure)))
 245       (setf (end compressor) end
 246             (start compressor) (logand #x8000 end)
 247             (counter compressor) (logand #x7FFF end)))))
 248
 249 (defmethod process-input ((compressor deflate-compressor) input start count)
 250   (update-chains input (hashes compressor) (chains compressor) start count))
 251
 252 (defmethod finish-data-format ((compressor deflate-compressor))
 253   (funcall (literal-fun compressor) 256))
 254
 255 (defmethod finish-compression ((compressor deflate-compressor))
 256   (final-compress compressor)
 257   (finish-data-format compressor)
 258   (flush (bitstream compressor)))
 259
 260 (defmethod final-compress ((compressor deflate-compressor))
 261   (let ((input (input compressor))
 262         (chains (chains compressor))
 263         (start (start compressor))
 264         (end (end compressor))
 265         (counter (counter compressor))
 266         (literal-fun (literal-fun compressor))
 267         (length-fun (length-fun compressor))
 268         (distance-fun (distance-fun compressor)))
 269     (process-input compressor input start counter)
 270     (compress input chains start end
 271               literal-fun
 272               length-fun
 273               distance-fun)))
 274
 275 (defmethod make-compress-fun ((compressor deflate-compressor))
 276   (let ((literal-fun (literal-fun compressor))
 277         (length-fun (length-fun compressor))
 278         (distance-fun (distance-fun compressor)))
 279     (lambda (input start count)
 280       (process-input compressor input start count)
 281       (let ((end (+ start count)))
 282         (compress input (chains compressor) start (logand #xFFFF end)
 283                   literal-fun
 284                   length-fun
 285                   distance-fun)))))
 286
 287 (defmethod reset ((compressor deflate-compressor))
 288   (fill (chains compressor) 0)
 289   (fill (input compressor) 0)
 290   (fill (hashes compressor) 0)
 291   (setf (start compressor) 0
 292         (end compressor) 0
 293         (counter compressor) 0)
 294   (reset (bitstream compressor))
 295   (start-data-format compressor))
 296
 297
 298 (defmacro with-compressor ((var class
 299                                 &rest initargs
 300                                 &key &allow-other-keys)
 301                            &body body)
 302   `(let ((,var (make-instance ,class ,@initargs)))
 303      (multiple-value-prog1
 304          (progn ,@body)
 305        (finish-compression ,var))))