compressor.lisp

   1 ;;;; $Id: compressor.lisp,v 1.13 2007/12/20 16:25:00 xach Exp $
   2
   3 (in-package #:salza2)
   4
   5 (defun make-input ()
   6   (make-array 65536 :element-type 'octet))
   7
   8 (defun make-chains ()
   9   (make-array 65536 :element-type '(unsigned-byte 16)))
  10
  11 (defun make-hashes ()
  12   (make-array +hashes-size+ :element-type '(unsigned-byte 16)))
  13
  14 (defun error-missing-callback (&rest args)
  15   (declare (ignore args))
  16   (error "No callback given for compression"))
  17
  18 ;;; FIXME: MERGE-INPUT is pretty ugly. It's the product of incremental
  19 ;;; evolution and experimentation. It should be cleaned up.
  20 ;;;
  21 ;;; Its basic purpose is to use octets from INPUT to fill up 32k-octet
  22 ;;; halves of the 64k-octet OUTPUT buffer. Whenever a half fills up,
  23 ;;; the COMPRESS-FUN is invoked to compress that half. At the end, a
  24 ;;; partial half may remain uncompressed to be either filled by a
  25 ;;; future call to MERGE-INPUT or to get flushed out by a call to
  26 ;;; FINAL-COMPRESS.
  27
  28 (defun merge-input (input start count output offset compress-fun)
  29   "Merge COUNT octets from START of INPUT into OUTPUT at OFFSET;
  30 on reaching 32k boundaries within OUTPUT, call the COMPRESS-FUN
  31 with OUTPUT, a starting offset, and the count of pending data."
  32   (declare (type octet-vector input output))
  33   (let ((i start)
  34         (j (+ start (min count (- +input-limit+ (mod offset +input-limit+)))))
  35         (result (logand +buffer-size-mask+ (+ offset count))))
  36     (dotimes (k (ceiling (+ (logand offset +input-limit-mask+) count)
  37                          +input-limit+))
  38       (when (plusp k)
  39         (funcall compress-fun
  40                  output
  41                  (logxor offset #x8000)
  42                  +input-limit+))
  43       (dtrace offset i j)
  44       (replace output input :start1 offset :start2 i :end2 j)
  45       (setf offset (logand +input-limit+ (+ offset +input-limit+)))
  46       (setf i j
  47             j (min (+ start count) (+ j +input-limit+))))
  48     (when (zerop (logand result +input-limit-mask+))
  49       (funcall compress-fun output (logxor offset #x8000) +input-limit+))
  50     result))
  51
  52
  53 ;;; Class & protocol
  54
  55 (defclass deflate-compressor ()
  56   ((input
  57     :initarg :input
  58     :accessor input)
  59    (chains
  60     :initarg :chains
  61     :accessor chains)
  62    (hashes
  63     :initarg :hashes
  64     :accessor hashes)
  65    (start
  66     :initarg :start
  67     :accessor start)
  68    (end
  69     :initarg :end
  70     :accessor end)
  71    (counter
  72     :initarg :counter
  73     :accessor counter)
  74    (octet-buffer
  75     :initarg :octet-buffer
  76     :accessor octet-buffer)
  77    (bitstream
  78     :initarg :bitstream
  79     :accessor bitstream)
  80    (literal-fun
  81     :initarg :literal-fun
  82     :accessor literal-fun)
  83    (length-fun
  84     :initarg :length-fun
  85     :accessor length-fun)
  86    (distance-fun
  87     :initarg :distance-fun
  88     :accessor distance-fun)
  89    (byte-fun
  90     :initarg :byte-fun
  91     :accessor byte-fun)
  92    (compress-fun
  93     :initarg :compress-fun
  94     :accessor compress-fun))
  95   (:default-initargs
  96    :input (make-input)
  97    :chains (make-chains)
  98    :hashes (make-hashes)
  99    :start 0
 100    :end 0
 101    :counter 0
 102    :bitstream (make-instance 'bitstream)
 103    :octet-buffer (make-octet-vector 1)))
 104
 105 ;;; Public protocol GFs
 106
 107 (defgeneric start-data-format (compressor)
 108   (:documentation "Add any needed prologue data to the output bitstream."))
 109
 110 (defgeneric compress-octet (octet compressor)
 111   (:documentation "Add OCTET to the compressed data of COMPRESSOR."))
 112
 113 (defgeneric compress-octet-vector (vector compressor &key start end)
 114   (:documentation "Add the octets of VECTOR to the compressed
 115   data of COMPRESSOR."))
 116
 117 (defgeneric process-input (compressor input start count)
 118   (:documentation "Map over pending octets in INPUT and perform
 119   any needed processing. Called before the data is compressed. A
 120   subclass might use this to compute a checksum of all input
 121   data."))
 122
 123 (defgeneric finish-data-format (compressor)
 124   (:documentation "Add any needed epilogue data to the output bitstream."))
 125
 126 (defgeneric finish-compression (compressor)
 127   (:documentation "Finish the data format and flush all pending
 128   data in the bitstream."))
 129
 130 ;;; Internal GFs
 131
 132 (defgeneric final-compress (compressor)
 133   (:documentation "Perform the final compression on pending input
 134   data in COMPRESSOR."))
 135
 136 (defgeneric make-compress-fun (compressor)
 137   (:documentation "Create a callback suitable for passing to
 138   MERGE-INPUT for performing incremental compression of the next
 139   32k octets of input."))
 140
 141 ;;; Methods
 142
 143 (defmethod initialize-instance :after ((compressor deflate-compressor)
 144                                        &rest initargs
 145                                        &key
 146                                        literal-fun length-fun distance-fun
 147                                        byte-fun compress-fun
 148                                        callback)
 149   (declare (ignore initargs))
 150   (let ((bitstream (bitstream compressor)))
 151     (setf (callback bitstream)
 152           (or callback #'error-missing-callback))
 153     (setf (literal-fun compressor)
 154           (or literal-fun (make-huffman-writer *fixed-huffman-codes*
 155                                                bitstream)))
 156     (setf (length-fun compressor)
 157           (or length-fun (make-huffman-writer *length-codes*
 158                                               bitstream)))
 159     (setf (distance-fun compressor)
 160           (or distance-fun (make-huffman-writer *distance-codes*
 161                                                 bitstream)))
 162     (setf (byte-fun compressor)
 163           (or byte-fun (make-byte-writer bitstream)))
 164     (setf (compress-fun compressor)
 165           (or compress-fun (make-compress-fun compressor)))
 166     (start-data-format compressor)))
 167
 168 (defmethod (setf callback) (new-fun compressor)
 169   (setf (callback (bitstream compressor)) new-fun))
 170
 171 (defmethod start-data-format ((compressor deflate-compressor))
 172   (let ((bitstream (bitstream compressor)))
 173     (write-bits +final-block+ 1 bitstream)
 174     (write-bits +fixed-tables+ 2 bitstream)))
 175
 176 (defmethod compress-octet (octet compressor)
 177   (let ((vector (octet-buffer compressor)))
 178     (setf (aref vector 0) octet)
 179     (compress-octet-vector vector compressor)))
 180
 181 (defmethod compress-octet-vector (vector compressor &key (start 0) end)
 182   (let* ((closure (compress-fun compressor))
 183          (end (or end (length vector)))
 184          (count (- end start)))
 185     (let ((end
 186            (merge-input vector start count
 187                         (input compressor)
 188                         (end compressor)
 189                         closure)))
 190       (setf (end compressor) end
 191             (start compressor) (logand #x8000 end)
 192             (counter compressor) (logand #x7FFF end)))))
 193
 194 (defmethod process-input ((compressor deflate-compressor) input start count)
 195   (update-chains input (hashes compressor) (chains compressor) start count))
 196
 197 (defmethod finish-data-format ((compressor deflate-compressor))
 198   (funcall (literal-fun compressor) 256))
 199
 200 (defmethod finish-compression ((compressor deflate-compressor))
 201   (final-compress compressor)
 202   (finish-data-format compressor)
 203   (flush (bitstream compressor)))
 204
 205 (defmethod final-compress ((compressor deflate-compressor))
 206   (let ((input (input compressor))
 207         (chains (chains compressor))
 208         (start (start compressor))
 209         (end (end compressor))
 210         (counter (counter compressor))
 211         (literal-fun (literal-fun compressor))
 212         (length-fun (length-fun compressor))
 213         (distance-fun (distance-fun compressor)))
 214     (process-input compressor input start counter)
 215     (compress input chains start end
 216               literal-fun
 217               length-fun
 218               distance-fun)))
 219
 220 (defmethod make-compress-fun ((compressor deflate-compressor))
 221   (let ((literal-fun (literal-fun compressor))
 222         (length-fun (length-fun compressor))
 223         (distance-fun (distance-fun compressor)))
 224     (lambda (input start count)
 225       (process-input compressor input start count)
 226       (let ((end (+ start count)))
 227         (compress input (chains compressor) start (logand #xFFFF end)
 228                   literal-fun
 229                   length-fun
 230                   distance-fun)))))