spell

(defun read-file (filename)
  (with-open-file (o filename :direction :input)
    (loop for line = (read-line o nil nil)
          while line
          collect line)))

;; (defvar *dict* (make-hash-table :test #'eql))

(defvar *root* nil)

(defstruct node
  state (children nil))

(defun has-childern (state)
  (not (null (node-children state))))

(defmacro last-child (state)
  `(car (node-children ,state)))

;;(defun set-last-child (state newstate)
;;  (setf (cdr (last-child state)) newstate))

(defun null-string-p (string)
  (string= "" string))

(defun theta (state char)
  (cdr (assoc char
              (node-children state)
              :test #'eql)))

(defun theta* (state word)
  (if (null word)
      state
      (let ((st (theta state (car word))))
        (and st (theta* st (cdr word))))))

(defun explode (word)
  (coerce word 'list))

(defun implode (list)
  (coerce list 'string))

(defun common-prefix (word)
  (labels ((aux (state word prefix)
             (if (null word)
                 (nreverse prefix)
                 (let ((st (theta state (car word))))
                   (if st
                       (aux st (cdr word) (cons (car word) prefix))
                       (nreverse prefix))))))
    (aux *root* (explode word) nil)))

(defvar *register-a*)
(defvar *register-b*)

(defun add-word (word)
  (let* ((common-prefix (common-prefix word))
         (last-state (theta* *root* common-prefix))
         (current-suffix (explode (subseq word (length common-prefix)))))
    (when (has-childern last-state)
      (replace-or-register last-state))
    (add-suffix last-state current-suffix)))

(defun node-labels (node)
  (mapcar #'car (node-children node)))

(defun find-in-register (node)
  (gethash (node-children node)
           (if (node-state node) *register-a* *register-b*)
           nil))

(defun regi (node)
  (setf (gethash (node-children node)
                 (if (node-state node) *register-a* *register-b*))
        node))

(defun replace-or-register (state)
  (let ((child (cdr (last-child state))))
    (when (has-childern child)
      (replace-or-register child))
    (let ((q (find-in-register child)))
      (if q
          (setf (cdr (last-child state)) q)
          (regi child)))))

(defun build-suffix (sfx)
  (let* ((sfx (nreverse sfx))
         (fst (cons (car sfx) (make-node :state t))))
    (loop for c in (cdr sfx)
          do (setf fst (cons c (make-node :state nil :children (list fst)))))
    fst))

(defun add-suffix (last suffix)
  (push (build-suffix suffix) (node-children last)))


(defun hash-set (assoc)
  (apply #'logxor (mapcar #'sxhash assoc)))
#|
(defun hash-set (assoc)
  (let ((seed 1009)
        (factor 9176))
    (loop for p in assoc
          do (setf seed (+ (sxhash p) (* seed factor))))
    seed))
|#
#|
(defun set-eq (a b)
  (and (= (list-length a) (list-length b))
       (loop for x in a
             for y in b
             always (and (eql (car x) (car y)) (eq (cdr x) (cdr y))))))
|#
(defun set-eq (a b)
  (do ((x a (cdr x))
       (y b (cdr y)))
      ((or (null x) (null y)) t)
    (let ((p (car x))
          (q (car y)))
      (if (not (and (eq (cdr p) (cdr q)) (eql (car p) (car q))))
          (return nil)))))


(defun main ()
  (setf *root* (make-node)
        *register-a*
        (make-hash-table :test 'set-eq :hash-function 'hash-set :size 30000)
        *register-b*
        (make-hash-table :test 'set-eq :hash-function 'hash-set :size 150000))
  (let ((words (read-file "words.linux"))
        (count 0))
    (loop for w in words
          do (progn
               (incf count)
               (when (> count 1000)
                 (princ "*")
                 (setf count 0))
               (add-word w)))
    (replace-or-register *root*))
  nil)

(defun check (word)
  (let ((a (theta* *root* (explode word))))
    (and a (node-state a))))

(defun test ()
  (let ((words (read-file "words.linux")))
    (time
     (loop for w in words
          always (check w)))))

(defun test2 ()
  (let ((words (read-file "words.linux"))
        (d (make-hash-table :test 'equal)))
    (loop for w in words
          do (setf (gethash w d) t))
    (time
     (loop for w in words
           always (gethash w d)))))