2 ;;; Copyright (c) 2007 Zachary Beane, All Rights Reserved
4 ;;; Redistribution and use in source and binary forms, with or without
5 ;;; modification, are permitted provided that the following conditions
8 ;;; * Redistributions of source code must retain the above copyright
9 ;;; notice, this list of conditions and the following disclaimer.
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.
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.
31 (deftype code-vector
()
32 '(simple-array (unsigned-byte 32) (*)))
34 (deftype size-vector
()
35 '(simple-array (unsigned-byte 8) (*)))
37 (defclass huffman-codes
()
45 (defun code-vector (length)
46 (make-array length
:element-type
'(unsigned-byte 32)))
48 (defun size-vector (length)
49 (make-array length
:element-type
'(unsigned-byte 8)))
52 ;;; Generate the fixed code/size vectors
55 (defun reverse-bits (word n
)
58 (setf j
(logior (ash j
1) (logand #x1 word
)))
59 (setf word
(ash word -
1)))))
61 (defun fixed-huffman-codes ()
62 "Generate the fixed Huffman codes specified by RFC1951."
63 (let ((codes (code-vector 288))
64 (sizes (size-vector 288))
66 (flet ((fill-range (length start end
)
67 (loop for j from start to end do
68 (setf (aref codes i
) (reverse-bits j length
)
69 (aref sizes i
) length
)
71 (fill-range 8 #b00110000
#b10111111
)
72 (fill-range 9 #b110010000
#b111111111
)
73 (fill-range 7 #b0000000
#b0010111
)
74 (fill-range 8 #b11000000
#b11000111
)
75 (make-instance 'huffman-codes
:codes codes
:sizes sizes
))))
77 (defun length-codes (huffman-codes)
78 "Compute a table of the (Huffman + extra bits) values for all
79 possible lengths for the given HUFFMAN-TABLE."
80 (let ((codes (code-vector 259))
81 (sizes (size-vector 259))
84 (extra-bit-counts '(0 0 0 0 0 0 0 0
91 (labels ((save-pair (i code size
)
92 (setf (aref codes i
) code
94 (save-value (extra-bit-count extra-value
)
95 (let ((huffman-value (aref (codes huffman-codes
) code
))
96 (huffman-count (aref (sizes huffman-codes
) code
)))
99 (ash extra-value huffman-count
))
100 (+ huffman-count extra-bit-count
)))))
101 (dolist (count extra-bit-counts
)
102 (dotimes (i (expt 2 count
))
109 (make-instance 'huffman-codes
:codes codes
:sizes sizes
)))
111 (defun distance-codes ()
112 "Compute a table of the (code + extra bits) values for all possible
113 distances as specified by RFC1951."
114 (let ((codes (code-vector 32769))
115 (sizes (size-vector 32769))
118 (extra-bit-counts '(0 0 0 0
119 1 1 2 2 3 3 4 4 5 5 6 6 7 7 8 8 9 9
120 10 10 11 11 12 12 13 13)))
121 (flet ((save-value (extra-bit-count extra-value
)
122 (setf (aref codes distance
)
123 (logior (ash extra-value
5) (reverse-bits code
5))
124 (aref sizes distance
)
125 (+ 5 extra-bit-count
))))
126 (dolist (count extra-bit-counts
)
127 (dotimes (i (expt 2 count
))
131 (make-instance 'huffman-codes
:codes codes
:sizes sizes
)))
133 (defvar *fixed-huffman-codes
* (fixed-huffman-codes))
134 (defvar *length-codes
* (length-codes *fixed-huffman-codes
*))
135 (defvar *distance-codes
* (distance-codes))