;;; addagram.lisp -- Program to solve the "Add-A-Gram" problem
;;;
;;; Written by Tomas Hlavaty <kvietaag@seznam.cz> on January 15, 2004
;;;
;;; From http://www.itasoftware.com/careers/programmers-archive.php
;;;
;;; An "add-a-gram" is a sequence of words formed by starting with a 3-letter
;;; word, adding a letter and rearranging to form a 4-letter word, and so on.
;;; For example, here are add-a-grams of the words "CREDENTIALS"
;;; and "ANACHRONISM":
;;;
;;; ail + s =                 mar + c =
;;; sail + n =                cram + h =
;;; nails + e =               march + s =
;;; aliens + t =              charms + o =
;;; salient + r =             chromas + n =
;;; entrails + c =            monarchs + i =
;;; clarinets + e =           harmonics + a =
;;; interlaces + d =          maraschino + n =
;;; CREDENTIALS (length 11)   ANACHRONISM (length 11)
;;;
;;; Test your own credentials: given the dictionary found here (WORD.LST 1.66MB),
;;; what is the longest add-a-gram?

(proclaim '(optimize speed))

(defvar *dictionary* nil)

(defun load-dictionary (&optional (file "WORD.LST"))
  "Load words from FILE that are longer than 2 characters."
  (with-open-file (stream file :direction :input)
		  (loop for word = (read-line stream nil nil)
			while word
			when (< 2 (length word))
			collect word)))

;;(time (prog1 t (setq *dictionary* (load-dictionary))))

(defun category (word)
  "Return category of WORD."
  (sort (copy-seq word) #'char<))

;;(category "hello")

(defvar *categories* nil)

(defun create-categories ()
  "Return hash-table containing list of words from *dictionary* for each category."
  (let ((categories (make-hash-table :test 'equal :size (length *dictionary*))))
    (dolist (word *dictionary* categories)
      (push word (gethash (category word) categories)))))

;;(time (prog1 t (setq *categories* (create-categories))))

(defun subcategories (category)
  "Return list of categories with one character less than CATEGORY."
  (loop for i from 0 to (1- (length category))
	collect (concatenate 'string
			     (subseq category 0 i)
			     (subseq category (1+ i)))))

;;(subcategories (category "credentials"))

(defun subwords (category)
  "Return list of words from subcategories of CATEGORY."
  (loop for c in (subcategories category)
	when #1=(gethash c *categories*)
	append #1#))

;;(subwords (category "credentials"))

(defstruct state word parent)

(defun expand (state)
  "Expand STATE into list of successor states."
  (loop for word in (subwords (category (state-word state)))
	collect (make-state :word word :parent state)))

;;(expand (make-state :word "credentials" :parent nil))

(defun search-solution (word &optional (done (make-hash-table :test 'equal)))
  "Return a state with the word length 3 leading to WORD."
  (do ((open (list (make-state :word word :parent nil))))
      ((null open))
    (let* ((state (pop open))
	   (existing (gethash (state-word state) done)))
      (if existing
	  existing
	(progn
	  (setf (gethash (state-word state) done) state)
	  (when (>= 3 (length (state-word state)))
	    (return state))
	  (setq open (nconc (expand state) open)))))))
;          (dolist (new-state (expand state))
;            (push new-state open)))))))

(defun print-solution (state)
  "Print all parent states of STATE."
  (loop for s = state then (state-parent s)
	while s
	do (format t "~A~%" (state-word s))))

;;(print-solution (search-solution "credentials"))
;;(print-solution (search-solution "anachronism"))
;;(print-solution (search-solution "xxxx"))

(defun search-max ()
  "Return one of the longest add-a-grams."
  (let ((done (make-hash-table :test 'equal)))
    (dolist (word *dictionary*)
      (let ((result (search-solution word done)))
	(when result
	  (return result))))))

;;(prog1 t (setq *dictionary* (sort *dictionary* #'(lambda (a b) (> (length a) (length b))))))
;;(time (print-solution (search-max))) => (length "indeterminations") => 16

(defun run (&optional (file "WORD.LST"))
  (format t "-- loading dictionary~%")
  (time (setq *dictionary* (load-dictionary file)))
  (format t "-- creating categories~%")
  (time (setq *categories* (create-categories)))
  (format t "-- sorting dictionary~%")
  (time (setq *dictionary* (sort *dictionary* #'(lambda (a b) (> (length a) (length b))))))
  (format t "-- searching~%")
  (time (print-solution (search-max))))

;;;; TODO get rid of the state and use hash-table for parent relation
;;;; directly

#|
(defun search-solution (word &optional (done (make-hash-table :test 'equal)))
  "Return a state with the word length 3 leading to WORD."
  (loop for queue = (list (make-state :word word :parent nil))
	while queue
	do (let* ((state (pop open))
		  (existing (gethash (state-word state) done)))
	     (if existing
		 existing
		 (progn
		   (setf (gethash (state-word state) done) state)
		   (when (>= 3 (length (state-word state)))
		     (return state))
		   (setq open (nconc (expand state) open)))))))
|#

(defun run (&optional (file "WORD.LST"))
  (setq *dictionary* (load-dictionary file))
  (setq *categories* (create-categories))
  (setq *dictionary* (sort *dictionary* #'> :key #'length))
  (print-solution (search-max)))

;(time (run))