matches.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 (defconstant +maximum-match-length+ 258
  32   "The maximum match length allowed.")
  33
  34 (defconstant +maximum-match-distance+ 32768
  35   "The maximum distance for a match.")
  36
  37 (declaim (inline match-length))
  38 (defun match-length (p1 p2 input end)
  39   "Returns the length of the match between positions p1 and p2 in
  40 INPUT; END is a sentinel position that ends the match length
  41 check if reached."
  42   (declare (type input-index p1 p2 end)
  43            (type input-buffer input)
  44            (optimize speed))
  45   (let ((length 0))
  46     (loop
  47      (when (or (/= (aref input p1) (aref input p2))
  48                (= length +maximum-match-length+)
  49                (= p1 end))
  50        (return length))
  51      (setf p1 (logand (1+ p1) #xFFFF)
  52            p2 (logand (1+ p2) #xFFFF)
  53            length (logand #xFFF (1+ length))))))
  54
  55 (defun longest-match (p1 input chains end max-tests)
  56   (declare (type input-index p1 end)
  57            (type input-buffer input)
  58            (type chains-buffer chains)
  59            (type (integer 0 32) max-tests)
  60            (optimize speed))
  61   (let ((match-length 0)
  62         (p2 (aref chains p1))
  63         (test-count 0)
  64         (distance 0))
  65     (declare (type (integer 0 258) match-length)
  66              (type (integer 0 32) test-count))
  67     (loop
  68      (when (or (= match-length +maximum-match-length+)
  69                (= test-count max-tests)
  70                (= p2 p1)
  71                (= p2 (aref chains p2)))
  72        (return (values match-length distance)))
  73      (let ((step (logand (- p1 p2) #xFFFF)))
  74        (when (< +maximum-match-distance+ step)
  75          (return (values match-length distance)))
  76        (let ((possible-length (match-length p1 p2 input end)))
  77          (when (and (< 2 possible-length)
  78                     (< match-length possible-length))
  79            (setf distance step
  80                  match-length possible-length))
  81          (setf p2 (aref chains p2)))
  82        (incf test-count)))))
  83