Find file
Fetching contributors…
Cannot retrieve contributors at this time
91 lines (85 sloc) 3.49 KB
(in-package :storage)
(declaim (inline build-table))
(defun build-table (string reverse-case)
(declare (type simple-string string)
(optimize speed
#+sbcl (sb-c::insert-array-bounds-checks 0)))
(let* ((length (length string))
(table (make-array length :element-type 'fixnum
:initial-element 0)))
(setf (aref table 0) -1)
(loop with pos fixnum = 2 and candidate fixnum = 0
while (< pos length)
do (let ((char (schar string candidate)))
(cond ((or (char= (schar string (1- pos)) char)
(and reverse-case
(char= (schar reverse-case (1- pos)) char)))
(setf (aref table pos) (incf candidate))
(incf pos))
((plusp candidate)
(setf candidate (aref table candidate)))
(setf (aref table pos) 0)
(incf pos)))))
(declaim (inline reverse-case))
(defun reverse-case (string)
(declare (simple-string string)
(optimize speed)
(sb-ext:muffle-conditions sb-ext:compiler-note))
(let ((reversed (make-string (length string))))
(loop for char across string
for i from 0
(setf (char reversed i)
(if (upper-case-p char)
(char-downcase char)
(char-upcase char))))
(declaim (inline do-kmp))
(defun do-kmp (pattern reverse-case string table)
(declare (type simple-string pattern string)
(type (or null simple-string) reverse-case)
(type (simple-array fixnum (*)) table)
(optimize speed))
(let ((pattern-length (length pattern))
(length (length string)))
(unless (> pattern-length length)
(loop with m = 0 and i = 0
for m+i fixnum = (#+sbcl sb-ext:truly-the #-sbcl the fixnum
(+ m i))
while (and (< m+i length)
(< i pattern-length)) ; hint for SBCL
do (let ((char (schar string m+i)))
(cond ((not (or (char= (schar pattern i) char)
(and reverse-case
(char= (schar reverse-case i) char))))
(let ((backtrack (aref table i)))
(setf m (#+sbcl sb-ext:truly-the #-sbcl the fixnum
(- m+i backtrack))
i (max 0 backtrack))))
((= (incf i) pattern-length)
(return m))))))))
(defun kmp (pattern string &key (case-insensitive t))
(declare (type simple-string string pattern))
(let ((sub-length (length pattern))
(length (length string)))
(cond ((= sub-length 0)
((> sub-length length)
(let ((reversed (when case-insensitive
(reverse-case pattern))))
(do-kmp pattern reversed
(build-table pattern reversed)))))))
(defun make-kmp-searcher (pattern &key case-sensitive)
(let ((reversed (if case-sensitive
(reverse-case pattern))))
(compile nil
`(lambda (text)
(do-kmp ,pattern ,reversed
text ,(build-table pattern reversed))))))