;;; 
;;; huffman.lisp
;;; 
;;; Created: 2005-03-12 by Zach Beane <xach@xach.com>
;;; 
;;; Copyright (c) 2005 Zachary Beane, All Rights Reserved
;;;
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;;
;;;   * Redistributions of source code must retain the above copyright
;;;     notice, this list of conditions and the following disclaimer.
;;;
;;;   * Redistributions in binary form must reproduce the above
;;;     copyright notice, this list of conditions and the following
;;;     disclaimer in the documentation and/or other materials
;;;     provided with the distribution.
;;;
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;;; 
;;; $Id: huffman.lisp,v 1.5 2005/03/20 21:33:49 xach Exp $

(in-package :salza-deflate)
            
;;;
;;; Huffman codes are written out to the stream backwards, so we save
;;; them backwards too.
;;;

(defun reverse-bits (word n)
  (let ((j 0))
    (dotimes (i n j)
      (setf j (logior (ash j 1) (logand #x1 word)))
      (setf word (ash word -1)))))

(defun fixed-huffman-table ()
  "Generate the fixed Huffman code table specified by RFC1951."
  (let ((table (make-array (* 288 2)))
        (i 0))
    (flet ((fill-range (length start end)
             (loop for j from start to end do
                     (setf (aref table i) (reverse-bits j length)
                           (aref table (incf i)) length)
                     (incf i))))
      (fill-range 8 #b00110000  #b10111111)
      (fill-range 9 #b110010000 #b111111111)
      (fill-range 7 #b0000000   #b0010111)
      (fill-range 8 #b11000000  #b11000111)
      table)))


;;; DEFLATE uses special Huffman codes to indicate that there is extra
;;; literal data after the code. The WRITE-LITERAL, WRITE-LENGTH, and
;;; WRITE-DISTANCE functions close over vectors that contain bit
;;; patterns at the even offsets and bit lengths at the odd offsets.
;;;
;;; Since we only deal with encoding with the fixed Huffman table
;;; described in the RFC right now, everything can be precomputed.

(defun save-pair (array i code length)
  "Store CODE and LENGTH in consecutive positions in ARRAY."
  (let ((index (ash i 1)))
    (setf (aref array index) code
          (aref array (1+ index)) length)))

(defun length-table (huffman-table)
  "Compute a table of the (Huffman + extra bits) values for all
possible lengths for the given HUFFMAN-TABLE."
  (let ((table (make-array (* 259 2)))
        (code 257)
        (length 3)
        (extra-bit-counts '(0 0 0 0 0 0 0 0
                            1 1 1 1
                            2 2 2 2
                            3 3 3 3
                            4 4 4 4
                            5 5 5 5
                            0)))
    (flet ((save-value (extra-bit-count extra-value)
             (let ((huffman-value (aref huffman-table (ash code 1)))
                   (huffman-count (aref huffman-table (1+ (ash code 1)))))
               (save-pair table length 
                          (logior huffman-value (ash extra-value huffman-count))
                          (+ huffman-count extra-bit-count)))))
      (dolist (count extra-bit-counts)
        (dotimes (i (expt 2 count))
          (when (< length 258)
            (save-value count i)
            (incf length)))
        (incf code))
      (setf code 285)
      (save-value 0 0))
    table))

(defun distance-table ()
  "Compute a table of the (code + extra bits) values for all possible
distances as specified by RFC1951."
  (let ((table (make-array (* 32769 2)))
        (code 0)
        (distance 1)
        (extra-bit-counts '(0 0 0 0
                            1 1 2 2 3 3 4 4 5 5 6 6 7 7 8 8 9 9
                            10 10 11 11 12 12 13 13)))
    (flet ((save-value (extra-bit-count extra-value)
             (save-pair table distance 
                        (logior (ash extra-value 5) (reverse-bits code 5))
                        (+ 5 extra-bit-count))))
      (dolist (count extra-bit-counts table)
        (dotimes (i (expt 2 count))
          (save-value count i)
          (incf distance))
        (incf code)))))

(let ((lvtable (fixed-huffman-table)))
  (declare (type simple-vector lvtable))
  (defun write-literal (code bitstream)
    "Write the Huffman code for the literal CODE to BITSTREAM."
    (declare (optimize (speed 3) (safety 0))
             (type (integer 0 258) code))
    (write-bits (svref lvtable (ash code 1))
                (svref lvtable (1+ (ash code 1))) 
                bitstream)))

(let ((lvtable (distance-table)))
  (declare (type simple-vector lvtable))
  (defun write-distance (distance bitstream)
    "Write the Huffman code and extra bits for distance DISTANCE to
bitstream."
    (declare (optimize (speed 3) (safety 0))
             (type (integer 0 32768) distance))
    (write-bits (svref lvtable (ash distance 1))
                (svref lvtable (1+ (ash distance 1)))
                bitstream)))

(let ((lvtable (length-table (fixed-huffman-table))))
  (declare (type simple-vector lvtable))
  (defun write-length (length bitstream)
    "Write the 5 bit code and extra bits for the length LENGTH to
BITSTREAM."
    (declare (optimize (speed 3) (safety 0))
             (type (integer 0 258) length))
    (write-bits (svref lvtable (ash length 1))
                (svref lvtable (1+ (ash length 1)))
                bitstream)))