(defun suffix-match (needle nlen offset suffix-len)
  (if (> offset suffix-len)
    (and (char/= (elt needle (- offset suffix-len 1))
	        (elt needle (- nlen suffix-len 1)))
	 (string= needle needle :start1 (- nlen suffix-len) :end1 nlen
		  :start2 (- offset suffix-len) :end2 offset))
    (string= needle needle :start1 (- nlen offset) :end1 nlen
	     :start2 0 :end2 offset)))

(defun bm-search (haystack hlen needle nlen)
  (let ((skip (make-array nlen :element-type 'integer))
	(occ (make-array 257 :element-type 'integer :initial-element -1)))
    (if (or (> nlen hlen) (<= nlen 0) (string= haystack nil) (string= needle nil))
      (return-from bm-search nil))
    (loop for i from 0 to (1- nlen) do
	    (setf (elt occ (char-code (elt needle i))) i))
    (loop for i from 0 to (1- nlen) do
	    (do* ((offs nlen)
		  (smatch (suffix-match needle nlen offs i)))
	      ((or (= offs 0) (not (null smatch)))
	       (setf (elt skip (- nlen i 1)) (- nlen offs)))
	      ;(format t "i: ~A, nlen: ~A, offs: ~A, smatch: ~A~%" i nlen offs smatch)
	      (decf offs)
	      (setf smatch (suffix-match needle nlen offs i))))
    ;(format t "~A~%" skip)
    (do ((hpos 0))
      ((> hpos (- hlen nlen)))
      (let ((npos (1- nlen)))
	(do ()
	  ((char/= (elt needle npos) (elt haystack (+ npos hpos))))
	  (when (= npos 0)
	    (return-from bm-search hpos))
	  (decf npos))
	(setf hpos (+ hpos (max (elt skip npos) (- npos (elt occ (char-code (elt haystack (+ npos hpos)))))))))))
  nil)

#|
(when (= (length *args* ) 2)
  (let* ((haystack (elt *args* 0))
	 (needle (elt *args* 1))
	 (pos (bm-search haystack (length haystack) needle (length needle))))
    (format t "haystack: ~A, needle: ~A, found at: ~D~%" haystack needle pos)))
|#