;#!/usr/bin/clisp

(declaim (optimize (speed 3) (safety 0)))

(defun bm-search (haystack hlen needle nlen)
  (let ((skip (make-array nlen :element-type 'integer :initial-element nlen))
	(occ (make-array 256 :element-type 'integer :initial-element nlen))
	(l (make-array 256 :element-type 'integer)))
    (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))) (- nlen i 1)))

    (setf (elt l 0) -1)
    (loop for i from 1 to (1- nlen) do
	  (let ((j 0))
	    (do ()
	      ((or (= j (- nlen i 1)) (char/= (elt needle (- nlen j 1)) (elt needle (- nlen i j 1)))))
	      (incf j))
	    (setf (elt l i) j)))
    (setf (elt skip 0) 1)

    (loop for i from (1- nlen) downto 1 do
	  (setf (elt skip (elt l i)) i))

    (loop for i from 0 to (1- nlen) with ended = 0 do
	  (progn
	    (when (= (elt l i) (- nlen 1 i))
	      (setf ended i))
	    (when (> ended 0)
	      (setf (elt skip i) ended))))
    (do* ((shift nlen))
      ((>= shift hlen))
      (let ((i 0)
	    (bs 0)
	    (consumed 0))
	(do ()
	  ((or (= i nlen) (char/= (elt haystack (- shift i)) (elt needle (- nlen i 1)))))
	  (incf i))
	(when (= i nlen)
	  (return-from bm-search (+ consumed (- shift (- nlen 1)))))

	(setf bs (elt occ (char-code (elt haystack (- shift i)))))
	(setf shift (+ shift (max (- bs i) (elt skip i)))))))
  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))
	(bf (bm-search text tlen pattern plen))
	(ret t))
     (when (/= kf nf bf)
	(format t "BUG: kf: ~D, bf: ~D, nf: ~D, text: ~A, pattern: ~A~%" kf bf 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 1000)))

(defun run-tests (max-plen)
  (let ((kmp-time 0)
	(ntime 0)
	(bm-time 0)
	(stime 0))
    (dotimes (i 1000)
      (let* ((slen 3000)
	     ;(plen (1+ (random max-plen)))
	     (plen max-plen)
	     (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))))
    (setf kmp-time (round (/ kmp-time 1000)))
    (setf bm-time (round (/ bm-time 1000)))
    (setf stime (round (/ stime 1000)))
    (setf ntime (round (/ ntime 1000)))
	;update-time ntime (run-test string-find :text text :tlen slen :pattern pattern :plen plen))))
    (format t "plen: ~A, kmp: ~A, bm: ~A, dafault-search: ~A, naive: ~A~%" max-plen kmp-time bm-time stime ntime)))