Word ladder

You form a word ladder by changing exactly one letter in the current "rung" to form the next. For example, the following is a ladder from 'paste' to 'carry':

1. paste
2. pasty
3. party
4. parry
5. carry

Given starting and goal words, the Lisp code below performs a breadth-first search in the supplied dictionary. Using BFS has the interesting property of guaranteeing that the path found is the shortest between the two words.

I'm not really pleased with the result: there's not enough abstraction. I guess with Lisp, it's hard to be satisfied unless you write a couple of fly-daddy macros that reduce the meat of the code to about three lines.

(defparameter *default-dictionary*
  #P"/usr/dict/words")

(defvar *dictionary* (make-hash-table :test #'equal))

(defun ladder (start goal)
  (if (/= (length start) (length goal))
      (error "'~S' and '~S' have different lengths" start goal)
      (let* ((dict (read-dictionary))
             (candidates (ladder-candidates dict start))
             (seen (make-hash-table :test #'equal))
             (begat (make-hash-table :test #'equal))
             (todo (list start)))
        (loop while todo do
              (let ((next '()))
                (loop for word in todo do
                      (let ((neighbors (neighbors word candidates seen)))
                        (loop for w in neighbors do
                              (setf (gethash w seen) 1
                                    (gethash w begat) word))
                        (if (find goal neighbors :test #'equal)
                            (return-from ladder (rungs start goal begat))
                            (setf next (nconc next neighbors)))))
                (setf todo next)))
        (error "No path from '~A' to '~A'" start goal))))

(defun read-dictionary (&optional (path *default-dictionary*))
  (let ((cached (gethash path *dictionary*)))
    (if cached
        cached
        (let ((dict '()))
          (with-open-file (s path)
            (loop for word = (read-line s nil)
                  while word do
                  (push word dict)))
          (setf (gethash path *dictionary*) dict)))))

(defun ladder-candidates (dict start)
  (let ((candidates '())
        (len (length start)))
    (loop for w in dict
          when (and (= len (length w)) (string-not-equal w start)) do
          (push (string-downcase w) candidates))
    candidates))

(defun one-hop-p (from to)
  (let ((hops 0))
    (loop for ff across from
          for tt across to
          when (char-not-equal ff tt) do
          (incf hops))
    (= hops 1)))

(defun rungs (start goal begat)
  (let ((path (list goal)))
    (loop for word = (first path)
          for parent = (gethash word begat)
          while (string-not-equal word start) do
          (push parent path))
    path))

(defun neighbors (word pool &optional (seen (make-hash-table)))
  (loop for w in pool
        when (and (one-hop-p word w)
                  (not (gethash w seen)))
        collect w))

(defun one-hop-neighbors (word)
  (neighbors word (ladder-candidates (read-dictionary) word)))