Updated version to 2.1.
[salza2.git] / compressor.lisp
blob942f0d3d56dfbd56053c213fac31e3229921d19f
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 ;;;
29 (in-package #:salza2)
31 (defun make-input ()
32 (make-array 65536 :element-type 'octet))
34 (defun make-chains ()
35 (make-array 65536
36 :element-type '(unsigned-byte 16)
37 :initial-element 0))
39 (defun make-hashes ()
40 (make-array +hashes-size+
41 :element-type '(unsigned-byte 16)
42 :initial-element 0))
44 (defun error-missing-callback (&rest args)
45 (declare (ignore args))
46 (error "No callback given for compression"))
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.
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))
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)))
92 ;;; Class & protocol
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)))
144 ;;; Public protocol GFs
146 (defgeneric start-data-format (compressor)
147 (:documentation "Add any needed prologue data to the output bitstream."))
149 (defgeneric compress-octet (octet compressor)
150 (:documentation "Add OCTET to the compressed data of COMPRESSOR."))
152 (defgeneric compress-octet-vector (vector compressor &key start end)
153 (:documentation "Add the octets of VECTOR to the compressed
154 data of COMPRESSOR."))
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."))
162 (defgeneric finish-data-format (compressor)
163 (:documentation "Add any needed epilogue data to the output bitstream."))
165 (defgeneric finish-compression (compressor)
166 (:documentation "Finish the data format and flush all pending
167 data in the bitstream."))
169 ;;; Internal GFs
171 (defgeneric final-compress (compressor)
172 (:documentation "Perform the final compression on pending input
173 data in COMPRESSOR."))
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."))
180 ;;; Methods
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)))
205 ;;; A few methods defer to the bitstream
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))))
213 (defmethod write-bits (code size (compressor deflate-compressor))
214 (write-bits code size (bitstream compressor)))
216 (defmethod write-octet (octet (compressor deflate-compressor))
217 (write-octet octet (bitstream compressor)))
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))
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)))
231 (defmethod compress-octet (octet compressor)
232 (let ((vector (octet-buffer compressor)))
233 (setf (aref vector 0) octet)
234 (compress-octet-vector vector compressor)))
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)))))
249 (defmethod process-input ((compressor deflate-compressor) input start count)
250 (update-chains input (hashes compressor) (chains compressor) start count))
252 (defmethod finish-data-format ((compressor deflate-compressor))
253 (funcall (literal-fun compressor) 256))
255 (defmethod finish-compression ((compressor deflate-compressor))
256 (final-compress compressor)
257 (finish-data-format compressor)
258 (flush (bitstream compressor)))
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)))
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)))))
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))
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))))