huffman.lisp

   1 ;;;; $Id: huffman.lisp,v 1.1 2007/12/07 17:16:38 xach Exp $
   2
   3 (in-package #:salza2)
   4
   5 (deftype code-vector ()
   6   '(simple-array (unsigned-byte 32) (*)))
   7
   8 (deftype size-vector ()
   9   '(simple-array (unsigned-byte 8) (*)))
  10
  11 (defclass huffman-codes ()
  12   ((codes
  13     :initarg :codes
  14     :accessor codes)
  15    (sizes
  16     :initarg :sizes
  17     :accessor sizes)))
  18
  19 (defun code-vector (length)
  20   (make-array length :element-type '(unsigned-byte 32)))
  21
  22 (defun size-vector (length)
  23   (make-array length :element-type '(unsigned-byte 8)))
  24
  25 ;;;
  26 ;;; Generate the fixed code/size vectors
  27 ;;;
  28
  29 (defun reverse-bits (word n)
  30   (let ((j 0))
  31     (dotimes (i n j)
  32       (setf j (logior (ash j 1) (logand #x1 word)))
  33       (setf word (ash word -1)))))
  34
  35 (defun fixed-huffman-codes ()
  36   "Generate the fixed Huffman codes specified by RFC1951."
  37   (let ((codes (code-vector 288))
  38         (sizes (size-vector 288))
  39         (i 0))
  40     (flet ((fill-range (length start end)
  41              (loop for j from start to end do
  42                    (setf (aref codes i) (reverse-bits j length)
  43                          (aref sizes i) length)
  44                    (incf i))))
  45       (fill-range 8 #b00110000  #b10111111)
  46       (fill-range 9 #b110010000 #b111111111)
  47       (fill-range 7 #b0000000   #b0010111)
  48       (fill-range 8 #b11000000  #b11000111)
  49       (make-instance 'huffman-codes :codes codes :sizes sizes))))
  50
  51 (defun length-codes (huffman-codes)
  52   "Compute a table of the (Huffman + extra bits) values for all
  53 possible lengths for the given HUFFMAN-TABLE."
  54   (let ((codes (code-vector 259))
  55         (sizes (size-vector 259))
  56         (code 257)
  57         (length 3)
  58         (extra-bit-counts '(0 0 0 0 0 0 0 0
  59                             1 1 1 1
  60                             2 2 2 2
  61                             3 3 3 3
  62                             4 4 4 4
  63                             5 5 5 5
  64                             0)))
  65     (labels ((save-pair (i code size)
  66                (setf (aref codes i) code
  67                      (aref sizes i) size))
  68              (save-value (extra-bit-count extra-value)
  69                (let ((huffman-value (aref (codes huffman-codes) code))
  70                      (huffman-count (aref (sizes huffman-codes) code)))
  71                  (save-pair length
  72                             (logior huffman-value
  73                                     (ash extra-value huffman-count))
  74                             (+ huffman-count extra-bit-count)))))
  75       (dolist (count extra-bit-counts)
  76         (dotimes (i (expt 2 count))
  77           (when (< length 258)
  78             (save-value count i)
  79             (incf length)))
  80         (incf code))
  81       (setf code 285)
  82       (save-value 0 0))
  83     (make-instance 'huffman-codes :codes codes :sizes sizes)))
  84
  85 (defun distance-codes ()
  86   "Compute a table of the (code + extra bits) values for all possible
  87 distances as specified by RFC1951."
  88   (let ((codes (code-vector 32769))
  89         (sizes (size-vector 32769))
  90         (code 0)
  91         (distance 1)
  92         (extra-bit-counts '(0 0 0 0
  93                             1 1 2 2 3 3 4 4 5 5 6 6 7 7 8 8 9 9
  94                             10 10 11 11 12 12 13 13)))
  95     (flet ((save-value (extra-bit-count extra-value)
  96              (setf (aref codes distance)
  97                    (logior (ash extra-value 5) (reverse-bits code 5))
  98                    (aref sizes distance)
  99                    (+ 5 extra-bit-count))))
 100       (dolist (count extra-bit-counts)
 101         (dotimes (i (expt 2 count))
 102           (save-value count i)
 103           (incf distance))
 104         (incf code)))
 105     (make-instance 'huffman-codes :codes codes :sizes sizes)))
 106
 107 (defvar *fixed-huffman-codes* (fixed-huffman-codes))
 108 (defvar *length-codes* (length-codes *fixed-huffman-codes*))
 109 (defvar *distance-codes* (distance-codes))