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

Contents of /zip/inflate.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1.1.1 - (hide 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 dlichteblau 1.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