1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
|
(in-package :ouat)
(defmacro node-letter (node) `(caar ,node))
(defmacro node-number (node) `(cadar ,node))
(defmacro node-termination (node) `(cddar ,node))
(defmacro node-children (node) `(cdr ,node))
(defvar *data-directory* nil)
(defvar *test-directory* nil)
(defvar *default-dictionary* nil)
(defvar *twl-dawg-nodes* nil)
;(defvar *twl98-dawg* nil)
;(defvar *sowpods-dawg* nil)
;(defvar *csw-dawg* nil)
(defun node-child-which-has-letter (node letter)
(find-if #'(lambda (child)
(= letter (node-letter child)))
(node-children node)))
(defun node-child-which-has-letter! (node letter)
(or (node-child-which-has-letter node letter)
(first (push (list (list letter nil)) (node-children node)))))
(defun push-suffix (suffix node)
(setf (node-number node) 0)
(let* ((letter (first suffix))
(new-suffix (rest suffix)))
(if suffix
(push-suffix new-suffix (node-child-which-has-letter! node letter))
(setf (node-termination node) t))))
(defun push-word (word trie)
(push-suffix (coerce word 'list) trie))
(defun reverse-children (node)
(setf (node-children node) (nreverse (node-children node)))
(dolist (child (node-children node))
(reverse-children child)))
(defun node-child-bits (node)
(let ((child-bits 0))
(dolist (child (node-children node))
(setf child-bits (logior child-bits (1bit (node-letter child)))))
child-bits))
(defun node-bits (node)
(let ((bits (node-number node)))
(when (node-termination node)
(setf bits (logior bits (1bit 26))))
bits))
(defun number-trie (node)
(let ((index 0))
(labels ((number-subtrie (node)
(if (node-children node)
(progn
(setf (node-number node) index)
(incf index)
(incf index (length (node-children node)))
(dolist (child (node-children node))
(number-subtrie child)))
(setf (node-number node) 0))))
(number-subtrie node))
index))
(defun trie-from-file (filename)
(let ((trie (list (list nil nil))))
(with-open-file (stream filename)
(loop for word = (read-line stream nil) while word
do (let ((word-list (word2list word)))
(push-word word-list trie)))
trie)))
(defun dawg-from-wordlist (wordlist dawg)
(let* ((trie (trie-from-file wordlist))
(size (progn (reverse-children trie) (number-trie trie))))
(with-open-file (stream
dawg
:direction :output
:element-type '(unsigned-byte 32)
:if-does-not-exist :create)
(labels ((write-node (node)
(when (node-children node)
(write-byte (node-child-bits node) stream)
(dolist (child (node-children node))
(write-byte (node-bits child) stream))
(dolist (child (node-children node))
(write-node child)))))
(write-byte size stream)
(write-node trie)))))
(defmacro open-dawg (array dawg-filename)
`(with-open-file (stream
,dawg-filename
:element-type '(unsigned-byte 32))
(let ((size (read-byte stream)))
(setf ,array (make-array `(,size) :element-type 'fixnum))
(dotimes (index size)
(setf (aref ,array index) (read-byte stream))))))
(defun node-letter-offset (node letter)
(declare (type (simple-array fixnum) *one-bits-per-13* *mask*))
(declare (optimize (safety 0) (speed 3) (space 1)))
(let* ((masked (ilogand node (mask letter)))
(first-13 (ilogand masked (mask 13)))
(second-13 (iash masked -13)))
(i+ 1
(aref *one-bits-per-13* first-13)
(aref *one-bits-per-13* second-13))))
(defun node-has-child-letter (node letter)
(not (izerop (ilogand node (1bit letter)))))
(defmacro do-node-child-letters ((letter node bits counts) &body body)
`(loop
for letters-to-search = (if (iplusp (aref ,counts +blank+))
,node
(ilogand ,node ,bits))
for ,letter fixnum below +alphabet-size+
when (iplusp (ilogand letters-to-search (1bit ,letter)))
do ,@body))
(defun child-pointer (child)
(ilogand child (mask 26)))
(defun child-terminates (child)
(not (izerop (ilogand child (1bit 26)))))
(defun anagram (anagram-string &optional (max-words 1)
(dictionary *default-dictionary*)
(return-values '(:WORDS))
(concatenate-p t)
(build-p nil))
(declare (optimize (safety 0) (speed 3) (space 1)))
(declare (type (simple-array fixnum) *bits* *other-bits* dictionary))
(let ((word-results nil)
(blank-results nil)
(word-prefix nil)
(blank-prefix nil)
(bits (word-bits anagram-string))
(counts (word-set anagram-string))
(count (num-tiles (word-set anagram-string)))
(number-of-answers 0))
(declare (type (simple-array fixnum) counts))
(labels ((push-words-starting-at-index (index words-so-far)
(let* ((node (aref dictionary index)))
(do-node-child-letters (letter node bits counts)
(let* ((tile (cond ((iplusp (aref counts letter)) letter)
((iplusp (aref counts +blank+)) +blank+)
(t nil))))
(when tile
(let* ((child-index (i+ index (node-letter-offset node letter)))
(child (aref dictionary child-index))
(pointer (child-pointer child)))
(labels ((recordable-word-here ()
(and (child-terminates child)
(or (i= 1 count) build-p))))
(when (recordable-word-here)
(when (member :WORDS return-values)
(push (list2word (cons letter word-prefix)) word-results))
(when (member :BLANKS return-values)
(push (list2word
(sort
(copy-list (if (i= +blank+ tile)
(cons letter blank-prefix)
(copy-list blank-prefix)))
'>))
blank-results))
(when (member :NUMBER-OF-ANSWERS return-values)
(iincf number-of-answers)))
(when (member :WORDS return-values)
(push letter word-prefix))
(when (and (member :BLANKS return-values)
(i= +blank+ tile))
(push letter blank-prefix))
(idecf (aref counts tile))
(when (izerop (aref counts tile))
(unset-bitf bits letter))
(idecf count)
(when (and (child-terminates child)
(i< (i1+ words-so-far) max-words))
(unless concatenate-p
(push +space+ word-prefix))
(push-words-starting-at-index 0 (i1+ words-so-far))
(unless concatenate-p
(pop word-prefix)))
(unless (izerop pointer)
(push-words-starting-at-index pointer words-so-far))
(iincf count)
(when (izerop (aref counts tile))
(set-bitf bits letter))
(iincf (aref counts tile))
(when (member :WORDS return-values)
(pop word-prefix))
(when (member :BLANKS return-values)
(when (i= +blank+ tile)
(pop blank-prefix)))))))))))
(push-words-starting-at-index 0 0)
(cond
((equal '(:NUMBER-OF-ANSWERS) return-values)
number-of-answers)
((equal '(:WORDS) return-values)
(nreverse word-results))
((equal '(:BLANKS) return-values)
(nreverse blank-results))
((equal '(:WORDS :BLANKS) return-values)
(values
(nreverse word-results)
(nreverse blank-results)))))))
(defun ana (anagram-string)
(anagram anagram-string))
(defun steal-tiles (anagram-string)
(anagram anagram-string
1
*default-dictionary*
'(:BLANKS)))
(defun anagram-stem (anagram-string)
(anagram anagram-string
1
*default-dictionary*
'(:WORDS :BLANKS)))
(defun load-dictionaries ()
(if *data-directory*
(open-dawg *twl-dawg-nodes* (string-append *data-directory*
"twl.dawg"))
(format t "No data directory set in ~~/.ouatrc, ~
couldn't find data.")))
(load (format nil "~a~a" (user-homedir-pathname) ".ouatrc"))
|
