addagram.lisp (5190B)
1 ;;; addagram.lisp -- Program to solve the "Add-A-Gram" problem 2 ;;; 3 ;;; Written by Tomas Hlavaty <kvietaag@seznam.cz> on January 15, 2004 4 ;;; 5 ;;; From http://www.itasoftware.com/careers/programmers-archive.php 6 ;;; 7 ;;; An "add-a-gram" is a sequence of words formed by starting with a 3-letter 8 ;;; word, adding a letter and rearranging to form a 4-letter word, and so on. 9 ;;; For example, here are add-a-grams of the words "CREDENTIALS" 10 ;;; and "ANACHRONISM": 11 ;;; 12 ;;; ail + s = mar + c = 13 ;;; sail + n = cram + h = 14 ;;; nails + e = march + s = 15 ;;; aliens + t = charms + o = 16 ;;; salient + r = chromas + n = 17 ;;; entrails + c = monarchs + i = 18 ;;; clarinets + e = harmonics + a = 19 ;;; interlaces + d = maraschino + n = 20 ;;; CREDENTIALS (length 11) ANACHRONISM (length 11) 21 ;;; 22 ;;; Test your own credentials: given the dictionary found here (WORD.LST 1.66MB), 23 ;;; what is the longest add-a-gram? 24 25 (proclaim '(optimize speed)) 26 27 (defvar *dictionary* nil) 28 29 (defun load-dictionary (&optional (file "WORD.LST")) 30 "Load words from FILE that are longer than 2 characters." 31 (with-open-file (stream file :direction :input) 32 (loop for word = (read-line stream nil nil) 33 while word 34 when (< 2 (length word)) 35 collect word))) 36 37 ;;(time (prog1 t (setq *dictionary* (load-dictionary)))) 38 39 (defun category (word) 40 "Return category of WORD." 41 (sort (copy-seq word) #'char<)) 42 43 ;;(category "hello") 44 45 (defvar *categories* nil) 46 47 (defun create-categories () 48 "Return hash-table containing list of words from *dictionary* for each category." 49 (let ((categories (make-hash-table :test 'equal :size (length *dictionary*)))) 50 (dolist (word *dictionary* categories) 51 (push word (gethash (category word) categories))))) 52 53 ;;(time (prog1 t (setq *categories* (create-categories)))) 54 55 (defun subcategories (category) 56 "Return list of categories with one character less than CATEGORY." 57 (loop for i from 0 to (1- (length category)) 58 collect (concatenate 'string 59 (subseq category 0 i) 60 (subseq category (1+ i))))) 61 62 ;;(subcategories (category "credentials")) 63 64 (defun subwords (category) 65 "Return list of words from subcategories of CATEGORY." 66 (loop for c in (subcategories category) 67 when #1=(gethash c *categories*) 68 append #1#)) 69 70 ;;(subwords (category "credentials")) 71 72 (defstruct state word parent) 73 74 (defun expand (state) 75 "Expand STATE into list of successor states." 76 (loop for word in (subwords (category (state-word state))) 77 collect (make-state :word word :parent state))) 78 79 ;;(expand (make-state :word "credentials" :parent nil)) 80 81 (defun search-solution (word &optional (done (make-hash-table :test 'equal))) 82 "Return a state with the word length 3 leading to WORD." 83 (do ((open (list (make-state :word word :parent nil)))) 84 ((null open)) 85 (let* ((state (pop open)) 86 (existing (gethash (state-word state) done))) 87 (if existing 88 existing 89 (progn 90 (setf (gethash (state-word state) done) state) 91 (when (>= 3 (length (state-word state))) 92 (return state)) 93 (setq open (nconc (expand state) open))))))) 94 ; (dolist (new-state (expand state)) 95 ; (push new-state open))))))) 96 97 (defun print-solution (state) 98 "Print all parent states of STATE." 99 (loop for s = state then (state-parent s) 100 while s 101 do (format t "~A~%" (state-word s)))) 102 103 ;;(print-solution (search-solution "credentials")) 104 ;;(print-solution (search-solution "anachronism")) 105 ;;(print-solution (search-solution "xxxx")) 106 107 (defun search-max () 108 "Return one of the longest add-a-grams." 109 (let ((done (make-hash-table :test 'equal))) 110 (dolist (word *dictionary*) 111 (let ((result (search-solution word done))) 112 (when result 113 (return result)))))) 114 115 ;;(prog1 t (setq *dictionary* (sort *dictionary* #'(lambda (a b) (> (length a) (length b)))))) 116 ;;(time (print-solution (search-max))) => (length "indeterminations") => 16 117 118 (defun run (&optional (file "WORD.LST")) 119 (format t "-- loading dictionary~%") 120 (time (setq *dictionary* (load-dictionary file))) 121 (format t "-- creating categories~%") 122 (time (setq *categories* (create-categories))) 123 (format t "-- sorting dictionary~%") 124 (time (setq *dictionary* (sort *dictionary* #'(lambda (a b) (> (length a) (length b)))))) 125 (format t "-- searching~%") 126 (time (print-solution (search-max)))) 127 128 ;;;; TODO get rid of the state and use hash-table for parent relation 129 ;;;; directly 130 131 #| 132 (defun search-solution (word &optional (done (make-hash-table :test 'equal))) 133 "Return a state with the word length 3 leading to WORD." 134 (loop for queue = (list (make-state :word word :parent nil)) 135 while queue 136 do (let* ((state (pop open)) 137 (existing (gethash (state-word state) done))) 138 (if existing 139 existing 140 (progn 141 (setf (gethash (state-word state) done) state) 142 (when (>= 3 (length (state-word state))) 143 (return state)) 144 (setq open (nconc (expand state) open))))))) 145 |# 146 147 (defun run (&optional (file "WORD.LST")) 148 (setq *dictionary* (load-dictionary file)) 149 (setq *categories* (create-categories)) 150 (setq *dictionary* (sort *dictionary* #'> :key #'length)) 151 (print-solution (search-max))) 152 153 ;(time (run))