huffman.lisp

   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 ;;;
  28
  29 (in-package #:salza2)
  30
  31 (deftype code-vector ()
  32   '(simple-array (unsigned-byte 32) (*)))
  33
  34 (deftype size-vector ()
  35   '(simple-array (unsigned-byte 8) (*)))
  36
  37 (defclass huffman-codes ()
  38   ((codes
  39     :initarg :codes
  40     :accessor codes)
  41    (sizes
  42     :initarg :sizes
  43     :accessor sizes)))
  44
  45 (defun code-vector (length)
  46   (make-array length :element-type '(unsigned-byte 32)))
  47
  48 (defun size-vector (length)
  49   (make-array length :element-type '(unsigned-byte 8)))
  50
  51 ;;;
  52 ;;; Generate the fixed code/size vectors
  53 ;;;
  54
  55 (defun reverse-bits (word n)
  56   (let ((j 0))
  57     (dotimes (i n j)
  58       (setf j (logior (ash j 1) (logand #x1 word)))
  59       (setf word (ash word -1)))))
  60
  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))
  65         (i 0))
  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)
  70                    (incf i))))
  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))))
  76
  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))
  82         (code 257)
  83         (length 3)
  84         (extra-bit-counts '(0 0 0 0 0 0 0 0
  85                             1 1 1 1
  86                             2 2 2 2
  87                             3 3 3 3
  88                             4 4 4 4
  89                             5 5 5 5
  90                             0)))
  91     (labels ((save-pair (i code size)
  92                (setf (aref codes i) code
  93                      (aref sizes i) size))
  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)))
  97                  (save-pair length
  98                             (logior huffman-value
  99                                     (ash extra-value huffman-count))
 100                             (+ huffman-count extra-bit-count)))))
 101       (dolist (count extra-bit-counts)
 102         (dotimes (i (expt 2 count))
 103           (when (< length 258)
 104             (save-value count i)
 105             (incf length)))
 106         (incf code))
 107       (setf code 285)
 108       (save-value 0 0))
 109     (make-instance 'huffman-codes :codes codes :sizes sizes)))
 110
 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))
 116         (code 0)
 117         (distance 1)
 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))
 128           (save-value count i)
 129           (incf distance))
 130         (incf code)))
 131     (make-instance 'huffman-codes :codes codes :sizes sizes)))
 132
 133 (defvar *fixed-huffman-codes* (fixed-huffman-codes))
 134 (defvar *length-codes* (length-codes *fixed-huffman-codes*))
 135 (defvar *distance-codes* (distance-codes))