;#!/usr/bin/clisp

(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)))
	      (decf offs)
	      (setf smatch (suffix-match needle nlen offs i))))
    (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)

(defun kmp-table (pattern plen)
  (let* ((table (make-array plen))
	 (pos 2)
	 (cnd 0))
    (setf (elt table 0) -1)
    (when (> plen 1)
      (setf (elt table 1) 0))
    (do ()
      ((>= pos plen))
      (cond
	((char= (elt pattern (1- pos)) (elt pattern cnd))
	 (setf (elt table pos) (1+ cnd))
	 (incf pos)
	 (incf cnd))
	((> cnd 0)
	 (setf cnd (elt table cnd)))
	(t
	  (setf (elt table pos) 0)
	  (incf pos))))
    table))

(defun kmp-search (&key text tlen pattern plen)
  (let* ((m 0)
	(i 0)
	(table (kmp-table pattern plen)))
    (do ((w (elt pattern i) (elt pattern i))
	 (s (elt text (+ m i))))
      ((>= (+ m i) tlen))
      (cond
	((char= w s)
	 (incf i)
	 (when (= i plen)
	   (return-from kmp-search m)))
	(t
	  (let ((ti (elt table i)))
	    (setf m (- (+ m i) ti))
	    (when (> i 0)
	      (setf i ti)))))
      (let ((mi (+ m i)))
        (when (< mi tlen)
          (setf s (elt text mi))))))
  -1)

(defun string-check-first-p (s1 s2 len)
  (string= s1 s2 :end1 len :end2 len))

(defun string-find (&key text tlen pattern plen)
  (let ((ret -1))
    (when (> plen 0)
      (do* ((pos 0))
	   ((or (< tlen plen) (/= ret -1)))
	(when (and (>= tlen plen)
		   (string-check-first-p text pattern plen))
	  (setf ret pos))
	(incf pos)
	(setf text (subseq text 1))
	(decf tlen)))
    ret))

(defconstant *alphabet* "abcdefghijklmnopqrstuvwzyz")
(defconstant *alphabet-size* (length *alphabet*))
(defun get-random-char ()
  (character (elt *alphabet* (random *alphabet-size*))))

(setf *random-state* (make-random-state t))

(defun generate-string (len)
  (let ((str (make-string len)))
    (dotimes (i len)
      (setf (elt str i) (get-random-char)))
    str))

(defun search-and-compare-p (&key text tlen pattern plen)
  (let ((kf (kmp-search :text text :tlen tlen :pattern pattern :plen plen))
	(nf (string-find :text text :tlen tlen :pattern pattern :plen plen))
	(ret t))
     (when (/= kf nf)
	(format t "BUG: kf: ~D, nf: ~D, text: ~A, pattern: ~A~%" kf nf text pattern)
	(setf ret nil))
     ret))

#|
(let* ((str (string "jrcmjhnorvpqfmdwrpaghzjkohgjwwpbeejzyyicfdntabqzyytzuwtoenadgzmiq"))
       (slen (length str))
       (pattern (string "yytzuwt"))
       (plen (length pattern)))
  (format t "str: ~A, pattern: ~A, kmp: ~A, bm: ~A~%" str pattern
	  (kmp-search :text str :tlen slen :pattern pattern :plen plen)
	  (bm-search str slen pattern plen)))
(quit)
|#

(defmacro run-test (func &rest args)
  `(let ((stime (get-internal-real-time)))
     (,func ,@args)
     (- (get-internal-real-time) stime)))

(defmacro update-time (time diff)
  `(setf ,time (+ ,time ,diff)))

(let ((kmp-time 0)
      (ntime 0)
      (bm-time 0)
      (stime 0))
  (dotimes (i 1000)
    (let* ((slen 1000)
	   (plen (1+ (random 50)))
	   (pos (random (- slen plen)))
	   (text (generate-string slen))
	   (pattern (subseq text pos (+ pos plen))))
      (update-time stime (run-test search pattern text))
      (update-time bm-time (run-test bm-search text slen pattern plen))
      (update-time kmp-time (run-test kmp-search :text text :tlen slen :pattern pattern :plen plen))
      (update-time ntime (run-test string-find :text text :tlen slen :pattern pattern :plen plen))))
  (format t "kmp: ~A, bm: ~A, dafault-search: ~A, naive: ~A~%" kmp-time bm-time stime ntime))