Updated version to 2.1.
[salza2.git] / compress.lisp
blob8352bf695a596160440401c1f9506695130dd4a2
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 ;;;
29 (in-package #:salza2)
31 (defun compress (input chains start end
32 literal-fun length-fun distance-fun)
33 (declare (type input-buffer input)
34 (type chains-buffer chains)
35 (type input-index start end)
36 (type function literal-fun length-fun distance-fun)
37 (optimize speed))
38 (let ((p start))
39 (loop
40 (when (= p end)
41 (return))
42 (multiple-value-bind (length distance)
43 (longest-match p input chains end 4)
44 (declare (type (integer 0 258) length)
45 (type (integer 0 32768) distance))
46 (cond ((zerop length)
47 (funcall literal-fun (aref input p))
48 (setf p (logand (+ p 1) #xFFFF)))
50 (funcall length-fun length)
51 (funcall distance-fun distance)
52 (setf p (logand (+ p length) #xFFFF))))))))