(require 'cl)
(require 'flyspell)

(setq my-fuzzer-buffer-name "*temp for fuzzer*")
(switch-to-buffer my-fuzzer-buffer-name)
(unless (= (point-min) (point-max))
  (error "Could not operate on non-empty buffer"))

(flyspell-mode 1)

(random t)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Implementations

;; Orig
(defun my-test-backward-orig (word bound &optional ignore-case)
  (save-excursion
    (let ((r '())
	  (inhibit-point-motion-hooks t)
	  p)
      (while (and (not r) (setq p (search-backward word bound t)))
	(let ((lw (flyspell-get-word)))
	  (if (and (consp lw)
		   (if ignore-case
		       (string-equal (downcase (car lw)) (downcase word))
		     (string-equal (car lw) word)))
	      (setq r p)
	    (goto-char p))))
      r)))
(defun my-test-forward-orig (word bound)
  (save-excursion
    (let ((r '())
	  (inhibit-point-motion-hooks t)
	  p)
      (while (and (not r) (setq p (search-forward word bound t)))
	(let ((lw (flyspell-get-word)))
	  (if (and (consp lw) (string-equal (car lw) word))
	      (setq r p)
	    (goto-char (1+ p)))))
      r)))

;; Agustin Martin
(defun my-test-backward-agustin (word bound &optional ignore-case)
  (save-excursion
    (let* ((r '())
           (inhibit-point-motion-hooks t)
           (flyspell-not-casechars (flyspell-get-not-casechars))
           (word-re (concat
                     flyspell-not-casechars
                     (regexp-quote word)
                     flyspell-not-casechars))
           p)
      (while
          (and (not r)
               (setq p (if (re-search-backward word-re bound t)
                           (progn (forward-char) (point))
                         ;; Check if word is at bob
                         (goto-char (point-min))
                         (search-forward word (length word) t))))
        (let ((lw (flyspell-get-word)))
          (if (and (consp lw)
                   (if ignore-case
                       (string-equal (downcase (car lw)) (downcase word))
                     (string-equal (car lw) word)))
              (setq r p)
            (goto-char p))))
      r)))
(defun my-test-forward-agustin (word bound)
  (save-excursion
    (let* ((r '())
          (inhibit-point-motion-hooks t)
          (word-end (nth 2 (flyspell-get-word)))
          (flyspell-not-casechars (flyspell-get-not-casechars))
          (word-re (concat flyspell-not-casechars
                           (regexp-quote word)
                           flyspell-not-casechars))
          p)
      (while
         (and (not r)
              (setq p (if (= word-end (point-max))
                          nil ;; Current word is at e-o-b. No forward search
                        (if (re-search-forward word-re bound t)
                            ;; word-re match ends one char after word
                            (progn (backward-char) (point))
                          ;; Check above does not match similar word at e-o-b
                          (goto-char (point-max))
                          (search-backward word (- (point-max)
                                                   (length word)) t)))))
	(let ((lw (flyspell-get-word)))
	  (if (and (consp lw) (string-equal (car lw) word))
	      (setq r p)
	    (goto-char (1+ p)))))
      r)))

;; Fixed
(defun my-test-backward-agustin-fixed (word bound &optional ignore-case)
  ;; (my-test-backward-agustin word bound ignore-case))
  (save-excursion
    (let* ((r '())
           (inhibit-point-motion-hooks t)
           (flyspell-not-casechars (flyspell-get-not-casechars))
           (word-re (concat
                     flyspell-not-casechars
                     (regexp-quote word)
                     flyspell-not-casechars))
           p)
      (while
          (and (not r)
               (setq p (if (re-search-backward word-re bound t)
                           (progn (forward-char) (point))
                         ;; Check if word is at bob
                         (goto-char (point-min))
                         (search-forward word (+ (point-min)
                                                 (length word)) t))))
        (let ((lw (flyspell-get-word)))
          (if (and (consp lw)
                   (if ignore-case
                       (string-equal (downcase (car lw)) (downcase word))
                     (string-equal (car lw) word)))
              (setq r p)
            (goto-char p))))
      r)))
(defun my-test-forward-agustin-fixed (word bound)
  (save-excursion
    (let* ((r '())
           (inhibit-point-motion-hooks t)
           (flyspell-not-casechars (flyspell-get-not-casechars))
           (word-re (concat flyspell-not-casechars
                            (regexp-quote word)
                            flyspell-not-casechars))
           p)
      (flyspell-get-word)
      (while
          (and (not r)
               (setq p (if (eobp)
                           nil ;; Current word is at e-o-b. No forward search
                         (if (re-search-forward word-re bound t)
                             ;; word-re match ends one char after word
                             (progn (backward-char) (point))
                           ;; Check above does not match similar word at e-o-b
                           (goto-char (point-max))
                           (and (search-backward word (- (point-max)
                                                         (length word)) t)
                                (goto-char (point-max)))))))
	(let ((lw (flyspell-get-word)))
	  (if (and (consp lw) (string-equal (car lw) word))
	      (setq r p)
            ;; We don't need to move forward due to additional char
            ;; before word in regexp
	    ;; (goto-char (1+ p))
            )))
      r)))

;; With eob in regexp
(defun my-test-forward-eob (word bound)
  (save-excursion
    (let* ((r '())
           (inhibit-point-motion-hooks t)
           (flyspell-not-casechars (flyspell-get-not-casechars))
           (word-re (concat flyspell-not-casechars
                            (regexp-quote word)
                            "\\(?:" flyspell-not-casechars "\\|\\'\\)"))
           p)
      (while
          (and (not r)
               (setq p (and
                        (re-search-forward word-re bound t)
                        (if (eobp)
                            (point)
                          (backward-char)
                          (point)))))
	(let ((lw (flyspell-get-word)))
	  (if (and (consp lw) (string-equal (car lw) word))
	      (setq r p)
            ;; We don't need to move forward due to additional char
            ;; before word in regexp
	    ;; (goto-char (1+ p))
            )))
      r)))

;; End of Implementations
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Fuzzer

(defun my-make-test-macro ()
  (let* ((good "met")
         (sep "SPC")
         (bad "nd")
         (oc "'")
         (bol "C-a")
         ;; not really eol but enough
         (eol "C-e")
         (parts (list good sep bad oc bol eol))
         (len (length parts)))
    (eval `(kbd ,(mapconcat (lambda (a)
                              (nth (random len) parts))
                            (make-list (1+ (random 100)) 0)
                            " ")))))

;; nil if everythings is equal,
;; 'badtext if text is not equal,
;; position is the first position with different properties.
(defun my-compare-strings-with-properties (a b)
  (if (string= (car a) (car b))
      (let ((len (length (car a)))
            (pos 0)
            (badpos nil)
            (faces1 (cadr a))
            (faces2 (cadr b)))
        (while (and (not badpos)
                    (< pos len))
          (unless (equal (nth pos faces1)
                         (nth pos faces2))
              (setq badpos pos))
          ;; (message ">> %d" pos)
          (setq pos (1+ pos)))
        (if my-show-faces
            (if badpos
                (progn
                  (message ":>> faces1 %S" faces1)
                  (message ":>> faces2 %S" faces2))
              (message ":>> No diff")))
        badpos)
    'badtext))

(defun my-make-string-with-faces (a)
  (let ((str (car a))
        (faces (cadr a)))
    (mapcar (lambda (pos)
              (set-text-properties pos
                                   (1+ pos)
                                   `(fontified t font-lock-face ,(nth pos faces))
                                   str))
            (number-sequence 0 (1- (length str))))
    str))
(defun my-make-strings-with-faces (a b)
  (concat "\n:>> orig:"
          (my-make-string-with-faces a)
          "\n:>>  new:"
          (my-make-string-with-faces b)
          "\n"))

(setq my-show-nice-faces nil)

(defun my-try-macro (macro)
  (let ((strings
         ;; (message ">> count = %d, macro = %S" count macro)
         (mapcar
          (lambda (name)
            (delete-region (point-min) (point-max))
            (letf (((symbol-function 'flyspell-word-search-forward)
                    (intern (concat "my-test-forward-" (symbol-name name))))
                   ((symbol-function 'flyspell-word-search-backward)
                    (intern (concat "my-test-backward-" (symbol-name name)))))
              ;; (message ">> pre %S %d" name count)
              (execute-kbd-macro macro)
              ;; (message ">> post %S %d" name count)
              )
            (list (buffer-string)
                  (mapcar (lambda (pos)
                            (get-char-property pos 'face))
                          (number-sequence (point-min) (point-max)))))
          '(orig new))))
    (let ((bad (my-compare-strings-with-properties (car strings) (cadr strings))))
      (if (and bad my-show-nice-faces)
          (with-current-buffer "*Messages*"
            (insert (my-make-strings-with-faces (car strings) (cadr strings)))))
      bad)))

;; It may not reduce to the minimun in one run. It fails at reductions
;; if 2 or more chars should be removed at the same time.
(defun my-reduce (macro)
  (let ((bad (my-try-macro macro))
        (fails 0)
        newmacro)
    (if bad
      (while (< fails 100)
      (let ((pos (random (length macro))))
        (setq newmacro (concat (substring macro 0 pos) (substring macro (1+ pos))))
        ;; (message ">> %S" macro)
        ;; (message ">> %S" newmacro)
        (if (my-try-macro newmacro)
            (progn
              (setq fails 0)
              (setq macro newmacro))
          (setq fails (1+ fails)))))
      (message ":>>   We reduce only faulty macros"))
    macro))

(defun my-try-mixed-pairs (macro)
  (unwind-protect
      (if (my-try-macro macro)
          (progn
            (my-reset-new)
            (defun my-test-backward-new (word bound &optional ignore-case)
              (my-test-backward-orig word bound ignore-case))
            (if (my-try-macro macro)
                (message ":>> Difference is from -forward function"))
            (my-reset-new)
            (defun my-test-forward-new (word bound)
              (my-test-forward-orig word bound))
            (if (my-try-macro macro)
                (message ":>> Difference is from -backward function")))
        (message ":>>   We mix pairs only for faulty macros"))
    (my-reset-new)))

(defun my-fuzz ()
  (interactive)
  (unless (string= (ispell-get-otherchars) "[']")
    (error "Unexpected not-casechars value"))
  (buffer-disable-undo)
  (unwind-protect
      (let ((more t)
            (count 0)
            (update-step 100)
            (time (current-time)))
        (while (and more
                    (< count (if my-macro 1 1000)))
          (let* ((macro (or my-macro (my-make-test-macro)))
                 (bad (let ((my-show-nice-faces t))
                        (my-try-macro macro))))
            (setq more (not bad))
            (unless more
              (if (numberp bad)
                  (message ":>> pos :%s^" (make-string bad ? )))
              (message ":>> Bad at %S running %S" bad macro)
              (my-try-mixed-pairs macro)
              (setq my-macro-last (my-reduce macro))
              (message ":>> Reduced macro: %S" my-macro-last))
            (if (= 0 (% count update-step))
                (message ":>> In progress, count = %d (shows between every %d)" count update-step)))
          (setq count (1+ count)))
        (message ":>> Fuzzing: %d macros are finished in %S"
                 count
                 (subtract-time (current-time) time))
        (message ":>> %s" (if more "Without differences" "There are differences")))
    (buffer-enable-undo))
  nil)
(global-set-key (kbd "C-j") 'my-fuzz)

;; use -orig with prefix arg,
;; use -new without prefix arg
(defun my-choose-flyspell-funcs (arg)
  (interactive "P")
  (if arg
      (progn
        (defun flyspell-word-search-backward (word bound &optional ignore-case)
          (my-test-backward-orig word bound ignore-case))
        (defun flyspell-word-search-forward (word bound)
          (my-test-forward-orig word bound))
        (message ">> Using orig"))
    (defun flyspell-word-search-backward (word bound &optional ignore-case)
      (my-test-backward-new word bound ignore-case))
    (defun flyspell-word-search-forward (word bound)
      (my-test-forward-new word bound))
    (message ">> Using new")))
(global-set-key (kbd "C-o") 'my-choose-flyspell-funcs)

(setq my-macro-last nil)

(setq my-show-faces nil)
(defun my-show-faces-func ()
  (interactive)
  (let ((macro (or my-macro my-macro-last)))
    (if macro
        (let ((my-show-faces t))
          (my-try-macro macro))
      (error "No macro specified"))))
(global-set-key (kbd "M-j") 'my-show-faces-func)

(split-window-right)
(other-window 1)
(view-echo-area-messages)
(other-window 1)

;; For manual debug

;; (defun flyspell-word-search-backward (word bound &optional ignore-case)
;;   (my-test-backward-agustin-fixed word bound ignore-case))
;; (defun flyspell-word-search-forward (word bound)
;;   (my-test-forward-agustin-fixed word bound))


;; Change this to use other functions instead of -agustin-fixed
(defun my-reset-new ()
  (defun my-test-backward-new (word bound &optional ignore-case)
    ;; (my-test-backward-agustin-fixed word bound ignore-case))
    (my-test-backward-orig word bound ignore-case))
  (defun my-test-forward-new (word bound)
    ;; (my-test-forward-agustin-fixed word bound)))
    ;; (my-test-forward-agustin word bound)))
    (my-test-forward-eob word bound)))
(my-reset-new)


;; Define non-nil to run only one test with this macro not randomly
(setq my-macro nil)

;; (setq my-macro (kbd "nd SPC and SPC nd C-a"))
;; (setq my-macro (kbd "nd SPC nd C-a"))

;; (setq my-macro (kbd "nd SPC and C-a"))

;; (setq my-macro (kbd "n SPC n C-a"))

;; (setq my-macro (kbd "nd C-e"))

;; (setq my-macro "'nd end'nd'ndnd")
;; (setq my-macro "'n en'n'nn")

(setq my-macro
      ;; "'nd end'nd'ndnd"
      ;; "'n en'n'nn"
      ;; "n'n en'n'n"
      "a n'n en'n'n"
      ;; "n'n n'n'n"
      ;; "n'n n'n'n"
      ;; "d'ndndmet met ndmet"
      ;; "d'nnd d nd"
      ;; "nd d'nd nd"
      ;; "nd d'nd nd met"
      )