spellcheck

(defun soundex-mangle-tail-1
  (x)
  (declare (xargs :guard (character-listp x)))
  (b* (((when (atom x)) nil) (x1 (downcase-char (car x)))
      ((when (and (eql x1 #\s) (atom (cdr x)))) nil)
      (rest (soundex-mangle-tail-1 (cdr x))))
    (cond ((position x1 "aeiouyhw$") (cons #\  rest))
      ((position x1 "bfpv") (cons #\b rest))
      ((position x1 "cgjkqsxz") (cons #\c rest))
      ((position x1 "dt") (cons #\d rest))
      ((eql x1 #\l) (cons #\l rest))
      ((position x1 "mn") (cons #\m rest))
      ((eql x1 #\r) (cons #\r rest))
      ((position x1 "-_/>? ") (cons #\  rest))
      (t (cons x1 rest)))))

(defun soundex-mangle-tail-2
  (x)
  (declare (xargs :guard (character-listp x)))
  (b* (((when (atom x)) nil) ((when (atom (cdr x))) (cons (car x)
          (soundex-mangle-tail-2 (cdr x))))
      (x1 (first x))
      (x2 (second x))
      ((when (and (eql x1 x2) (not (eql x1 #\ )))) (cons x1 (soundex-mangle-tail-2 (cddr x)))))
    (cons x1 (soundex-mangle-tail-2 (cdr x)))))

(defun soundex-mangle-tail
  (x)
  (declare (xargs :guard (character-listp x)))
  (b* ((x (soundex-mangle-tail-1 x)) (x (soundex-mangle-tail-2 x))
      (x (remove #\  x)))
    (cond ((atom x) '(#\  #\  #\ ))
      ((atom (cdr x)) (cons (first x) '(#\  #\ )))
      ((atom (cddr x)) (list* (first x) (second x) '(#\ )))
      (t (list (first x) (second x) (third x))))))

(defun soundex
  (x)
  "Returns our soundex-like code as a string."
  (declare (xargs :guard (stringp x)))
  (b* ((chars (explode x)))
    (if (atom chars)
      "    "
      (implode (cons (downcase-char (car chars))
          (soundex-mangle-tail (cdr chars)))))))

(defun soundex-list
  (x)
  (declare (xargs :guard (string-listp x)))
  (if (atom x)
    nil
    (cons (soundex (car x))
      (soundex-list (cdr x)))))

(defun find-diffs
  (x y)
  (declare (xargs :guard (equal (len x) (len y))))
  (cond ((atom x) nil)
    ((equal (car x) (car y)) (find-diffs (cdr x) (cdr y)))
    (t (cons (cons (car x) (car y))
        (find-diffs (cdr x) (cdr y))))))

(defun nearly-equal-aux
  (x y)
  (declare (xargs :guard (and (string-listp x)
        (string-listp y))))
  (let ((xl (len x)) (yl (len y)))
    (and (eql xl (+ 1 yl))
      (<= 1 xl)
      (<= 1 yl)
      (or (and (equal (cdr x) y)
          (<= (length (car x)) 3))
        (and (equal (butlast x 1) y)
          (<= (length (car (last y))) 3))))))

(defun nearly-equal
  (x y)
  (declare (xargs :guard (and (string-listp x)
        (string-listp y))))
  (or (nearly-equal-aux x y)
    (nearly-equal-aux y x)))

(defun merge-final-ps
  (x)
  (declare (xargs :guard (string-listp x)))
  (cond ((atom x) nil)
    ((atom (cdr x)) (list (first x)))
    ((and (atom (cddr x)) (equal (second x) "p")) (list (cat (first x) "p")))
    (t (cons (car x) (merge-final-ps (cdr x))))))

(defun collect-plausible-misspellings-aux
  (goal goal-tokens
    desperation
    topic-names)
  (declare (xargs :guard (and (symbolp goal)
        (string-listp goal-tokens)
        (natp desperation)
        (symbol-listp topic-names))))
  (b* (((when (atom topic-names)) nil) (name1 (car topic-names))
      (name1-tokens (strtok (downcase-string (symbol-name name1))
          '(#\- #\_ #\/ #\> #\? #\ )))
      (rest (collect-plausible-misspellings-aux goal
          goal-tokens
          desperation
          (cdr topic-names)))
      ((when (equal goal-tokens name1-tokens)) (cons name1 rest))
      ((unless (>= desperation 1)) rest)
      ((when (equal (mergesort name1-tokens)
           (mergesort goal-tokens))) (cons name1 rest))
      ((unless (>= desperation 2)) rest)
      (name1-tokens (merge-final-ps name1-tokens))
      (goal-tokens (merge-final-ps goal-tokens))
      ((when (equal goal-tokens name1-tokens)) (cons name1 rest))
      ((unless (>= desperation 3)) rest)
      ((when (and (equal (len name1-tokens)
             (len goal-tokens))
           (let ((diffs (find-diffs name1-tokens goal-tokens)))
             (and (equal (len diffs) 1)
               (equal (soundex (caar diffs))
                 (soundex (cdar diffs))))))) (cons name1 rest))
      ((unless (>= desperation 4)) rest)
      ((when (equal (soundex (symbol-name goal))
           (soundex (symbol-name name1)))) (cons name1 rest))
      ((unless (>= desperation 5)) rest)
      ((when (nearly-equal name1-tokens goal-tokens)) (cons name1 rest)))
    rest))

(defun collect-plausible-misspellings
  (goal topic-names)
  (declare (xargs :guard (and (symbolp goal)
        (symbol-listp topic-names))))
  (let ((goal-tokens (strtok (downcase-string (symbol-name goal))
         '(#\- #\_ #\/ #\> #\? #\ ))))
    (or (collect-plausible-misspellings-aux goal
        goal-tokens
        0
        topic-names)
      (collect-plausible-misspellings-aux goal
        goal-tokens
        1
        topic-names)
      (collect-plausible-misspellings-aux goal
        goal-tokens
        2
        topic-names)
      (collect-plausible-misspellings-aux goal
        goal-tokens
        3
        topic-names)
      (collect-plausible-misspellings-aux goal
        goal-tokens
        4
        topic-names)
      (collect-plausible-misspellings-aux goal
        goal-tokens
        5
        topic-names))))

(defun candidate-score-aux
  (domain goal-chars candidate-chars)
  (declare (xargs :guard (and (character-listp domain)
        (character-listp goal-chars)
        (character-listp candidate-chars))))
  (b* (((when (atom domain)) 0) (n1 (duplicity (car domain) goal-chars))
      (n2 (duplicity (car domain) candidate-chars))
      (diff (abs (- n1 n2))))
    (+ diff
      (candidate-score-aux (cdr domain)
        goal-chars
        candidate-chars))))

(defun candidate-score
  (goal candidate)
  (declare (xargs :guard (and (stringp goal) (stringp candidate))))
  (b* ((goal-chars (explode (downcase-string goal))) (candidate-chars (explode (downcase-string candidate)))
      (domain (remove #\-
          (mergesort (append goal-chars candidate-chars)))))
    (candidate-score-aux domain
      goal-chars
      candidate-chars)))

(defun rank-candidates
  (goal candidates)
  (declare (xargs :guard (and (symbolp goal)
        (symbol-listp candidates))))
  (if (atom candidates)
    nil
    (cons (cons (candidate-score (symbol-name goal)
          (symbol-name (car candidates)))
        (car candidates))
      (rank-candidates goal (cdr candidates)))))

(defun sort-candidates
  (goal candidates)
  (declare (xargs :guard (and (symbolp goal)
        (symbol-listp candidates))))
  (strip-cdrs (mergesort (rank-candidates goal candidates))))

(defun xdoc-autocorrect
  (goal topic-names)
  (declare (xargs :guard (and (symbolp goal)
        (symbol-listp topic-names))))
  (b* ((candidates (collect-plausible-misspellings goal
         topic-names)) (candidates (sort-candidates goal candidates)))
    (take (min (len candidates) 5)
      candidates)))