/[zip]/zip/inflate.lisp
ViewVC logotype

Contents of /zip/inflate.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1.1.1 - (show annotations) (vendor branch)
Sun Apr 3 19:36:28 2005 UTC (9 years ago) by dlichteblau
Branch: dlichteblau
CVS Tags: start
Changes since 1.1: +0 -0 lines
initial import
1 ;; inflate.cl
2 ;;
3 ;; copyright (c) 1986-2000 Franz Inc, Berkeley, CA
4 ;;
5 ;; This code is free software; you can redistribute it and/or
6 ;; modify it under the terms of the version 2.1 of
7 ;; the GNU Lesser General Public License as published by
8 ;; the Free Software Foundation, as clarified by the AllegroServe
9 ;; prequel found in license-allegroserve.txt.
10 ;;
11 ;; This code is distributed in the hope that it will be useful,
12 ;; but without any warranty; without even the implied warranty of
13 ;; merchantability or fitness for a particular purpose. See the GNU
14 ;; Lesser General Public License for more details.
15 ;;
16 ;; Version 2.1 of the GNU Lesser General Public License is in the file
17 ;; license-lgpl.txt that was distributed with this file.
18 ;; If it is not present, you can access it from
19 ;; http://www.gnu.org/copyleft/lesser.txt (until superseded by a newer
20 ;; version) or write to the Free Software Foundation, Inc., 59 Temple Place,
21 ;; Suite 330, Boston, MA 02111-1307 USA
22 ;;
23 ;;
24 ;; $Id: inflate.lisp 10524 2004-10-11 15:25:33Z david $
25
26 ;; Description:
27 ;; inflate a stream of bytes which was compressed with the Deflate
28 ;; algorithm
29 ;;
30 ;; john foderaro, August 2001
31 ;;
32 ;;- This code in this file obeys the Lisp Coding Standard found in
33 ;;- http://www.franz.com/~jkf/coding_standards.html
34 ;;-
35
36
37
38 #|
39 Programming interface:
40
41 (inflate input-stream output-stream)
42 - the compressed information from the input-stream is read and
43 the uncompressed information is written to the output-stream
44 - both streams must support (unsigned-byte 8) element reading and writing
45
46
47 (skip-gzip-header input-stream)
48 - if the input stream is positioned on the header of a gzip'ed file
49 then skip that header.
50 - if the input stream is not positioned on a gzip header then nothing
51 is done.
52
53 |#
54
55
56
57 #|
58 The Deflate Compression Algorithm
59
60 reference: http://www.gzip.org/zlib/rfc-deflate.html
61
62 Basic idea:
63 Deflation is a means of compressing an octet sequence that
64 combines the LZ77 algorithm for marking common substrings and
65 Huffman coding to take advantage of different frequency of occurance
66 for each possible values in the file.
67 This algorithm may not be as easy to understand or as efficient
68 as the LZW compression algorithm but Deflate does have the big
69 advantage in that it is not patented. Thus Deflate is a very
70 widely used. Nowdays it's the most common compression method
71 used in Windows Zip programs (e.g. Winzip) and in the Unix gzip program.
72 Java jar files, being just zip files, also use this compression method.
73
74
75 Lempel-Ziv 1977 (LZ77):
76 An octet sequence often contains repeated subsequences. The LZ algorithm
77 compresses a file by replacing repeated substrings with (Length,Distance)
78 markers which mean during decompression: Go back Distance octets
79 in output stream and copy Length bytes to the output stream.
80
81 Huffman Coding:
82 A Huffman code for a set of values V assigns a unique bitsequence
83 to each value in V. A bitsequence is a sequence of 0's and 1'.
84 An important property of Huffman codes is that if X is a bitsequence
85 for a value in V then no other value in V has a bitsequence
86 with X as a prefix of that sequence. This means that if you see
87 the bitsequence X in the stream you know that this denotes the value
88 v and you don't have to read any more bits.
89
90
91 Blocks:
92 A deflated file is a sequence of blocks. There are three types of
93 blocks:
94 1. uncompressed - The block simply contains the same sequence of
95 octets as were found in the input stream. This type of block
96 is useful when the input stream has already been compressed (e.g.
97 it's a jpg or gif file) as compressing a compressed file often
98 results in the file getting larger.
99
100 2. compressed with fixed Huffman code - The block contains a
101 huffman-coded LZ77 compressed bitsequence. The huffman code
102 used is specified by the deflate algorithm. This type of block
103 is useful when the octet sequence is short since in that case
104 the overhead of creating a custom huffman code is more than is gained
105 by that custom code.
106
107 3. compressed with a custom Huffman code - The block contains
108 a description of a Huffman code to be used in this block only
109 and then a Huffman-code LZ77 compressed bitsequence. The values
110 that describe the custome huffman tree are themselves huffman coded.
111
112
113
114 |#
115
116 (in-package :zip)
117
118 (defun inflate (p op)
119 ;; user callable
120 ;; inflate the stream p into the stream op
121 ;; both streams should be unsigned-byte 8
122 ;;
123 (let ((br (new-bit-reader p))
124 (buffer (make-array (* 32 1024) :element-type '(unsigned-byte 8)))
125 (end 0))
126 (loop
127 (if* (null (setq end (process-deflate-block br op buffer end)))
128 then ; last block, we're all done
129 (return)))))
130
131
132
133
134 ;;; ------------ gzip support
135 ;
136 ; gzip preceeds files with a header and the only support we need
137 ; give to handle gzip files is the ability to skip the header
138 ; and get to the meat of the file
139
140
141 ; gzip constants
142
143 ; compression strategies (only one supported)
144 (defconstant z_deflated 8)
145
146 ; flag bits
147 (defconstant gz_ascii_flags #x01) ; file probably ascii
148 (defconstant gz_head_crc #x02) ; header crc present
149 (defconstant gz_extra_field #x04) ; extra field present
150 (defconstant gz_orig_name #x08) ; original file name present
151 (defconstant gz_comment #x10) ; file comment present
152 (defconstant gz_reserved #xe0) ; no bits allowed on here
153
154 (defun skip-gzip-header (p)
155 ;; If the next thing in the stream p is gzip header then skip
156 ;; past it and return t.
157 ;; If it's not a gzip header than return nil
158 ;; If it's starts to look like a gzip header but turns out to
159 ;; not be valid signal an error. Note that the first byte of
160 ;; a gzip header is an illegal byte to begin a deflated stream so
161 ;; that if the first byte matches a gzip header but the rest do not
162 ;; then the stream was positioned at neither a gzip header nor a
163 ;; deflated stream
164 ;
165 ;; see check_header in gzio.c in rpm zlib-1.1.3 (or variant)
166 ;; for details on what's in the header.
167
168 (let (method flags)
169
170 ; look for magic number
171 (if* (not (eql #x1f (read-byte p)))
172 then ; not a gzip header, may be a deflate block
173 (unread-char (code-char #x1f) p)
174 (return-from skip-gzip-header nil))
175
176
177 ; now check the second magic number
178 (if* (not (eql #x8b (read-byte p)))
179 then (error "non gzip magic number"))
180
181 (setq method (read-byte p)
182 flags (read-byte p))
183
184 (if* (or (not (eql method z_deflated))
185 (not (zerop (logand flags gz_reserved))))
186 then (error "bad method/flags in header"))
187
188 ; discard time, xflags and os code */
189 (dotimes (i 6) (read-byte p))
190
191 ; discard extra field if present
192 (if* (logtest flags gz_extra_field)
193 then (let ((length (+ (read-byte p)
194 (ash (read-byte p) 8))))
195 (dotimes (i length) (read-byte p))))
196
197 (if* (logtest flags gz_orig_name)
198 then ; discard name of file, null terminated
199 (do ((val (read-byte p) (read-byte p)))
200 ((zerop val))))
201
202 (if* (logtest flags gz_comment)
203 then ; discard comment, null terminated
204 (do ((val (read-byte p) (read-byte p)))
205 ((zerop val))))
206
207 (if* (logtest flags gz_head_crc)
208 then ; discard header crc
209 (dotimes (i 2) (read-byte p)))
210
211 ; success!
212 t
213 ))
214
215 ;;;----------- end gzip support
216
217
218
219 ;;;----------- support for reading bitfields from a stream
220
221
222 (defstruct bit-reader
223 stream
224 last-byte ; last byte read, possibly two combined bytes too
225 bits ; bits left of last byte to use
226 )
227
228 (defparameter *maskarray*
229 ;; for a bit length, mask off junk bits
230 (make-array 17
231 :initial-contents
232 '(#x0
233 #x1 #x3 #x7 #xf
234 #x1f #x3f #x7f #xff
235 #x1ff #x3ff #x7ff #xfff
236 #x1fff #x3fff #x7fff #xffff)))
237
238 ;; bit reader
239 (defun new-bit-reader (stream)
240 ; create and initialize bit reader
241 (make-bit-reader :stream stream :last-byte 0 :bits 0))
242
243 (defun reset-bit-reader (br)
244 ; clear out unused bit of the current byte
245 (setf (bit-reader-bits br) 0))
246
247 (defun read-bits (br count)
248 ;; return a value from the current bit reader.
249 ;; the count can be from 1 to 16
250 ;;
251
252 (if* (eql count 0)
253 then (return-from read-bits 0))
254
255
256 (let ((last-byte (bit-reader-last-byte br))
257 (bits (bit-reader-bits br)))
258 (loop
259 (if* (>= bits count)
260 then ;we have enough now
261 (if* (> bits count)
262 then ; we have some left over
263 (setf (bit-reader-last-byte br)
264 (ash last-byte (- count)))
265 (setf (bit-reader-bits br) (- bits count))
266 (return (logand last-byte (svref *maskarray* count)))
267 else ; no bits left
268 (setf (bit-reader-bits br) 0)
269 (setf (bit-reader-last-byte br) 0)
270 (return last-byte)
271 )
272 else ; need a new byte
273 (let ((new-byte (read-byte (bit-reader-stream br))))
274 (setq last-byte (+ last-byte
275 (ash new-byte bits)))
276 (incf bits 8))))))
277
278
279
280 ;;;----------- end bitfield reading
281
282
283
284
285 ;;;----------- build constant tables needed by the algorithm
286
287 ;; The tables needed to decode length and distance values
288 ;; A compressed file contains a sequence of literal character values
289 ;; or (length,distance) pairs. The length is computed by taking
290 ;; the length-value in the file and using these tables to bind
291 ;; a base length value and the number of extra bits to read from the file
292 ;; and then to add to the length value.
293 ;; The same is done for distance.
294
295 (defvar *base-length*) ; array mapping code to length value
296 (defvar *length-extra-bits*) ; array saying how many more bitsworth to read
297
298 (defvar *base-distance*)
299 (defvar *distance-extra-bits*)
300
301
302 ; build those arrays at load time:
303
304 (progn
305 (setq *base-length* (make-array (1+ (- 285 257)))
306 *length-extra-bits* (make-array (1+ (- 285 257))))
307
308 (let ((len 3)
309 (ind 0))
310 (dolist (ent '((8 0) ; count and number of extra bits
311 (4 1) (4 2) (4 3) (4 4) (4 5) (1 0)))
312 (dotimes (i (car ent))
313 (setf (svref *base-length* ind) len)
314 (setf (svref *length-extra-bits* ind) (cadr ent))
315 (incf ind 1)
316 (incf len (ash 1 (cadr ent)))
317 )
318 ; special case, code 285 is length 258.
319 (setf (svref *base-length* (- 285 257)) 258)
320 ))
321
322 (setq *base-distance* (make-array (1+ (- 29 0)))
323 *distance-extra-bits* (make-array (1+ (- 29 0))))
324
325 (let ((dist 1)
326 (ind 0))
327 (dolist (ent '((4 0) ; count and number of extra bits
328 (2 1) (2 2) (2 3) (2 4) (2 5) (2 6) (2 7) (2 8)
329 (2 9) (2 10) (2 11) (2 12) (2 13)))
330 (dotimes (i (car ent))
331 (setf (svref *base-distance* ind) dist)
332 (setf (svref *distance-extra-bits* ind) (cadr ent))
333 (incf ind 1)
334 (incf dist (ash 1 (cadr ent)))))))
335
336
337
338
339 ;;;----------- end table building
340
341
342
343 ;;;----------- Huffman tree support
344
345 (defstruct (bitinfo (:type list))
346 ;; when we describe a range of values and the code width we
347 ;; use a list of three elements. this structure describes it
348 minval
349 maxval
350 bitwidth)
351
352
353 ;test case
354 ; (generate-huffman-tree '((0 4 3) (5 5 2) (6 7 4)))
355 ; will generate sample table from the Deutsch paper
356 ;
357
358 (defun generate-huffman-tree (bitinfo)
359 ;; bitinfo is a list of bitinfo items (minval maxval bitwidth)
360 ;; which means that values from minval through maxval are
361 ;; to be represented by codes of width bitwidth.
362 ;;
363 ;; we return two valuse: the huffman tree and the mininum bit width
364 ;;
365 (let ((maxval 0)
366 (minval most-positive-fixnum)
367 (maxbitwidth 0)
368 (minbitwidth most-positive-fixnum)
369 bitwidthcounts
370 valuecode
371 valuewidth
372 nextcode
373 )
374 ; find out the range of values (well the max) and the max bit width
375 (dolist (bi bitinfo)
376 (setq maxval (max maxval (bitinfo-maxval bi)))
377 (setq minval (min minval (bitinfo-minval bi)))
378 (setq maxbitwidth (max maxbitwidth (bitinfo-bitwidth bi)))
379 (setq minbitwidth (min minbitwidth (bitinfo-bitwidth bi)))
380 )
381
382 ; per bitwidth arrays
383 (setq bitwidthcounts (make-array (1+ maxbitwidth)
384 :initial-element 0))
385 (setq nextcode (make-array (1+ maxbitwidth)
386 :initial-element 0))
387
388 ; per value arrays
389 (setq valuecode (make-array (1+ (- maxval minval)))) ; huffman code chose
390 (setq valuewidth (make-array (1+ (- maxval minval))
391 :initial-element 0)) ; bit width
392
393 (dolist (bi bitinfo)
394 ; set valuewidth array from the given data
395 (do ((v (bitinfo-minval bi) (1+ v)))
396 ((> v (bitinfo-maxval bi)))
397 (setf (svref valuewidth (- v minval)) (bitinfo-bitwidth bi)))
398
399 ; keep track of how many huffman codes will have a certain bit width
400 (incf (svref bitwidthcounts (bitinfo-bitwidth bi))
401 (1+ (- (bitinfo-maxval bi) (bitinfo-minval bi))))
402 )
403
404
405
406 ; compute the starting code for each bit width
407 (let ((code 0))
408 (dotimes (widthm1 maxbitwidth)
409 (setq code
410 (ash (+ code (svref bitwidthcounts widthm1)) 1))
411 (setf (svref nextcode (1+ widthm1)) code)))
412
413 ; compute the huffman code for each value
414 (do ((v minval (1+ v)))
415 ((> v maxval))
416 (let ((width (svref valuewidth (- v minval))))
417 (if* (not (zerop width))
418 then ; must assign a code
419 (setf (svref valuecode (- v minval))
420 (svref nextcode width))
421 (incf (svref nextcode width)))))
422
423 ;; now we know the code for each value in the valuecode array
424 ;;
425 ;; now compute the tree
426 (values (build-huffman-tree
427 minval
428 (mapcar #'(lambda (bi) (cons (car bi) (cadr bi))) bitinfo)
429 valuecode valuewidth 1)
430 ; second value useful for decoding:
431 minbitwidth)))
432
433
434 (defun build-huffman-tree (minval minmaxes valuecode valuewidth pos)
435 ;; compute a huffman cons tree
436 ;; minmaxes is a list of conses. each cons
437 ;; representing a (min . max) range of values.
438 ;;
439
440 (multiple-value-bind (zero one) (split-on-position minval minmaxes
441 valuecode
442 valuewidth
443 pos)
444 (cons (if* (consp zero)
445 then (build-huffman-tree minval
446 zero valuecode valuewidth (1+ pos))
447 else zero)
448 (if* (consp one)
449 then (build-huffman-tree minval one valuecode valuewidth (1+ pos))
450 else one))))
451
452 (defun split-on-position (minval minmaxes valuecode valuewidth pos)
453 ;; compute those values that have a zero in the pos (1 based) position
454 ;; of their code and those that have one in that position.
455 ;; return two values, the zero set and the one set.
456 ;; The position is from the msbit of the huffman code.
457 ;;
458 ;; If the value of the specified pos selects a specific value
459 ;; and no further bits need be read to identify that value then
460 ;; we return that value rather than a list of conses.
461
462 (let (zero one)
463 (dolist (mm minmaxes)
464 (do ((v (car mm) (1+ v)))
465 ((> v (cdr mm)))
466 (let ((width (svref valuewidth (- v minval)))
467 (code (svref valuecode (- v minval))))
468 (if* (logbitp (- width pos) code)
469 then ; one bit set
470 (if* (eql width pos)
471 then ; last bit
472 (setq one v)
473 else ; more bits to check
474 (let ((firstone (car one)))
475 (if* (and firstone
476 (eq (cdr firstone) (1- v)))
477 then ; increase renge
478 (setf (cdr firstone) v)
479 else (push (cons v v) one))))
480 else ; zero bit set
481 (if* (eql width pos)
482 then ; last bit
483 (setq zero v)
484 else ; more bits to check
485 (let ((firstzero (car zero)))
486 (if* (and firstzero
487 (eq (cdr firstzero) (1- v)))
488 then ; increase renge
489 (setf (cdr firstzero) v)
490 else (push (cons v v) zero))))))))
491 (values
492 (if* (consp zero) then (nreverse zero) else zero) ; order numerically
493 (if* (consp one) then (nreverse one) else one))))
494
495
496 (defun generate-huffman-tree-from-vector (vector start end)
497 ;; generate huffman tree from items in the vector from start to end-1
498 ;; assume start corresponds to value 0 in the tree
499 (do ((i start (1+ i))
500 (val 0 (1+ val))
501 (res))
502 ((>= i end)
503 (generate-huffman-tree (nreverse res)))
504 (let ((len (svref vector i)))
505 (if* (> len 0)
506 then (push (list val val len) res)))))
507
508
509
510
511
512 ;; the huffman tree to use for type 1 blocks
513 ;;
514 (defparameter *fixed-huffman-tree*
515 (generate-huffman-tree '((0 143 8) (144 255 9) (256 279 7) (280 287 8))))
516
517 ;; distance are represented by a trivial huffman code
518 (defparameter *fixed-huffman-distance-tree*
519 (generate-huffman-tree '((0 31 5))))
520
521
522 ;;;----------- end Huffman support
523
524
525
526
527 (defun process-deflate-block (br op buffer end)
528 ;; br is a bit stream, op is the output stream
529 ;; process the next block in the stream
530 ;; return false if this is the last block of data else
531 ;; return the next index into the buffer
532 (let ((bfinal (read-bits br 1))
533 (btype (read-bits br 2)))
534
535 (setq end
536 (case btype
537 (0 (process-non-compressed-block br op buffer end))
538 (1 (process-fixed-huffman-block br op buffer end))
539 (2 (process-dynamic-huffman-block br op buffer end))
540 (3 (error "illegal deflate block value"))))
541 (if* (eql bfinal 1)
542 then (flush-buffer op buffer end)
543 nil
544 else end)
545 ))
546
547
548
549 (defun process-non-compressed-block (br op buffer end)
550 ;; process a block of uncompressed data
551 (reset-bit-reader br)
552 (let ((p (bit-reader-stream br)))
553 (let ((len (read-uword p))
554 (onecomplen (read-uword p)))
555 (if* (not (eql len (logxor #xffff onecomplen)))
556 then (error "bad length value in non compressed block"))
557 (dotimes (i len)
558 (setq end (put-byte-in-buffer op (read-byte p) buffer end))))
559 end))
560
561 (defun read-uword (stream)
562 ;; read a little endian value
563 (+ (read-byte stream) (ash (read-byte stream) 8)))
564
565 (defun put-byte-in-buffer (op byte buffer end)
566 ;; store the next output byte in the buffer
567 (if* (>= end (length buffer))
568 then (flush-buffer op buffer end)
569 (setq end 0))
570 (setf (aref buffer end) byte)
571 (1+ end))
572
573 (defun flush-buffer (op buffer end)
574 ;; send bytes to the output stream. If op isn't a stream
575 ;; then it must be a function to funcall to take the bytes.
576 (if* (> end 0)
577 then (if* (streamp op)
578 then (write-sequence buffer op :end end)
579 else (funcall op buffer end))))
580
581
582
583
584
585 (defun process-fixed-huffman-block (br op buffer end)
586 ;; process a huffman block with the standard huffman tree
587 ;;
588 (process-huffman-block br op *fixed-huffman-tree* 7 *fixed-huffman-distance-tree* 5
589 buffer end))
590
591 (defun process-huffman-block (br op
592 lengthlit-tree minwidth
593 distance-tree mindistwidth
594 buffer end)
595 ;; the common code for blocks of type 1 and 2 that does
596 ;; the decompression given a length/literal huffman tree
597 ;; and a distance huffman tree.
598 ;; If the distance tree is nil then we use the trivial huffman
599 ;; code from the algorithm.
600 ;;
601 (let* ((bufflen (length buffer))
602 length
603 distance
604 )
605
606
607 (loop
608 (let ((value (decode-huffman-tree br lengthlit-tree minwidth)))
609 (if* (< value 256)
610 then ; output and add to buffer
611 (setq end (put-byte-in-buffer op value buffer end))
612
613 elseif (eql value 256)
614 then (return) ; end of block
615 else ; we have a length byte
616 ; compute length, distance
617
618 (let ((adj-code (- value 257)))
619 (setq length (+ (svref *base-length* adj-code)
620 (read-bits br (svref *length-extra-bits*
621 adj-code)))))
622
623 (let ((dist-code (if* distance-tree
624 then (decode-huffman-tree br
625 distance-tree
626 mindistwidth)
627 else (read-bits br 5))))
628 (setq distance
629 (+ (svref *base-distance* dist-code)
630 (read-bits br (svref *distance-extra-bits*
631 dist-code)))))
632
633 ; copy in bytes
634 (do ((i (mod (- end distance) bufflen) (1+ i))
635 (count length (1- count)))
636 ((<= count 0))
637 (if* (>= i bufflen) then (setf i 0))
638 (setq end (put-byte-in-buffer op
639 (aref buffer i)
640 buffer
641 end))))))
642 ; return where we left off
643 end))
644
645
646
647 (defparameter *code-index*
648 ;; order of elements in the code index values
649 ;; pretty crazy, eh?
650 (make-array 19
651 :initial-contents
652 '(16 17 18 0 8 7 9 6 10 5 11 4 12 3 13 2 14 1 15)))
653
654
655 (defun process-dynamic-huffman-block (br op buffer end)
656 ;; process a block that includes a personalized huffman tree
657 ;; just for this block
658 (let ((hlit (read-bits br 5))
659 (hdist (read-bits br 5))
660 (hclen (read-bits br 4))
661
662 code-length-huffman-tree
663 (minlen 9999)
664 )
665
666 ; read in the huffman code width of each of the numbers
667 ; from 0 18... this will be then used to create a huffman tree
668 ;
669 (let ((codevec (make-array 19 :initial-element 0))
670 (len))
671
672 (dotimes (i (+ hclen 4))
673 (setf (svref codevec
674 (svref *code-index* i))
675 (setq len (read-bits br 3)))
676 (if* (> len 0) then (setq minlen (min len minlen))))
677
678
679
680 (setq code-length-huffman-tree
681 (generate-huffman-tree-from-vector codevec 0 (length codevec))))
682
683 ; now we're in position to read the code lengths for the
684 ; huffman table that will allow us to read the data.
685 ; (Is this a nutty algorithm or what??)
686 ;
687 (let ((bigvec (make-array (+ hlit 257 hdist 1)
688 :initial-element 0))
689 (index 0))
690 (loop
691 (if* (>= index (length bigvec)) then (return))
692 (let ((val (decode-huffman-tree br code-length-huffman-tree minlen)))
693 (if* (<= val 15)
694 then ; literal value
695 (setf (svref bigvec index) val)
696 (incf index)
697 elseif (eql val 16)
698 then ; repeat prev
699 (let ((prev-val (svref bigvec (1- index))))
700 (dotimes (i (+ 3 (read-bits br 2)))
701 (setf (svref bigvec index) prev-val)
702 (incf index)))
703 elseif (eq val 17)
704 then ; repeat zero
705 (dotimes (i (+ 3 (read-bits br 3)))
706 (setf (svref bigvec index) 0)
707 (incf index))
708 elseif (eq val 18)
709 then ; repeat zero a lot
710 (dotimes (i (+ 11 (read-bits br 7)))
711 (setf (svref bigvec index) 0)
712 (incf index)))))
713
714 (let (literal-length-huffman litlen-width
715 distance-huffman distance-width)
716 (multiple-value-setq (literal-length-huffman litlen-width)
717 (generate-huffman-tree-from-vector bigvec 0 (+ hlit 257)))
718
719 (multiple-value-setq (distance-huffman distance-width)
720 (generate-huffman-tree-from-vector bigvec (+ hlit 257)
721 (length bigvec)))
722
723 (process-huffman-block br op literal-length-huffman litlen-width
724 distance-huffman distance-width
725 buffer end)
726 ))))
727
728
729
730 (defun decode-huffman-tree (br tree minbits)
731 ;; find the next huffman encoded value.
732 ; the minimum length of a huffman code is minbits so
733 ; grab that many bits right away to speed processing and the
734 ; go bit by bit until the answer is found
735 (let ((startval (read-bits br minbits)))
736 (dotimes (i minbits)
737 (if* (logtest 1 startval)
738 then (setq tree (cdr tree))
739 else (setq tree (car tree)))
740 (setq startval (ash startval -1)))
741 (loop
742 (if* (atom tree)
743 then (return tree)
744 else (if* (eql 1 (read-bits br 1))
745 then (setq tree (cdr tree))
746 else (setq tree (car tree)))))))
747
748
749
750
751
752
753 ;;; test case...
754 ;; Read file created with gzip and write the uncompressed version
755 ;; to another file.
756 ;;
757 ;; Porting note: the open below works on ACL since it creates
758 ;; a bivalent simple-stream. If you run this on other lispsj
759 ;; you'll want to specify an :element-type of '(unsigned-byte 8)
760 ;;
761 #+ignore
762 (defun testit (&optional (filename "foo.n.gz") (output-filename "out"))
763 (with-open-file (p filename :direction :input)
764 (skip-gzip-header p)
765 (with-open-file (op output-filename :direction :output
766 :if-exists :supersede)
767 (inflate p op))))

  ViewVC Help
Powered by ViewVC 1.1.5