blob: cb319cd6248c505b4eb15e78f1ab2b30264e6bc9 (
plain)
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
|
(in-package :ouat)
(defun jqxz+1-stems ()
(let ((racks-that-bingo-through-jqxz
(unique
(loop
for big-tile across "JQXZ"
for ana-pattern = (format nil "~a???????" big-tile)
append (steal-tiles ana-pattern))))
(jqxz+1-stems nil))
(dolist (rack racks-that-bingo-through-jqxz)
(let ((ana-pattern (format nil "~a?" rack)))
(multiple-value-bind (words blanks)
(anagram-stem ana-pattern)
(when (and (= 2 (length words))
(string/= (first blanks)
(second blanks)))
(push rack jqxz+1-stems)))))
jqxz+1-stems))
#+nil
(defun woadwage-bingos (n)
(let ((bag (coerce *english-scrabble-bag* 'list)))
(labels ((draw-random-rack ()
(coerce (subseq (shuffle bag) 0 7) 'string)))
(loop
for i below n
for rack = (draw-random-rack)
count (woadwage rack)))))
(defun chewscore (word1 word2)
(labels ((uniq-pairs (word)
(unique
(sort
(loop
for idx below (1- (length word))
collect (subseq word idx (+ 2 idx)))
'string<))))
(let* ((pairs1 (uniq-pairs word1))
(pairs2 (uniq-pairs word2)))
(- (length (union pairs1 pairs2 :test 'string=))
(max (length pairs1) (length pairs2))))))
(defun wordmath ()
(declare (optimize (debug 3)))
(let ((twl-alphas (make-hash-table :test 'equal))
(csw-alphas (make-hash-table :test 'equal)))
(labels ((alpha (word)
(sort (coerce word 'list) 'char<))
(minus-one (word+already-subtracted)
#+nil
(format t "(minus-one ~a)~%" word+already-subtracted)
(loop
with word = (first word+already-subtracted)
with already-subtracted = (rest word+already-subtracted)
with used-letters = (make-hash-table)
for idx below (length word)
for letter = (elt word idx)
for before = (subseq word 0 idx)
for after = (subseq word (1+ idx))
for alpha = (coerce
(alpha (concatenate 'string before after))
'string)
unless (gethash letter used-letters) do
#+nil
(format t "alpha: ~a~%" alpha)
(setf (gethash letter used-letters) t)
collect (cons alpha (cons letter already-subtracted))))
(best-subword (word num-missing)
#+nil
(format t "word: ~a~%" word)
(loop
with sub-alphas = (list (list word))
repeat num-missing
do
(setf sub-alphas
(unique (apply 'append (mapcar #'minus-one sub-alphas))))
#+nil
(format t "sub-alphas: ~a~%" sub-alphas)
finally
(loop
with best-score = MOST-NEGATIVE-FIXNUM
with best = nil
for (alpha . letters) in sub-alphas
for a = (coerce alpha 'list)
for twl = (gethash a twl-alphas)
for csw = (gethash a csw-alphas)
;;do (format t "twl: ~a csw: ~a~%" twl csw)
when (and twl (= 1 (length csw))) do
(let* ((subword (first csw))
(score (chewscore subword word)))
#+nil
(format t "subword: ~a letters: ~a score: ~a~%" subword letters score)
(when (> score best-score)
(setf best-score score
best (cons subword letters))))
finally
(when best
#+nil
(format t "BEST: ~a~%" best)
(return-from best-subword
(values (first best) (rest best) best-score)))))))
(do-file-lines (word (string-append *data-directory* "twl.txt"))
(when (<= 5 (length word) 7)
(push word (gethash (alpha word) twl-alphas))))
(do-file-lines (word (string-append *data-directory* "csw.txt"))
(when (<= 5 (length word) 7)
(push word (gethash (alpha word) csw-alphas))))
(do-file-lines (word (string-append *data-directory*
"csw-single-sevens.txt"
#+nil
"csw-single-eights.txt"))
(multiple-value-bind (subword letters score)
(best-subword word 1)
#+nil
(format t "subword: ~a~%" subword)
(if (and score (> score 2))
(format t "~a + ~a = ~a~%" subword (first letters) word)
(multiple-value-bind (subword2 letters2 score2)
(best-subword word 2)
#+nil
(format t "subword: ~a~%" subword)
(when (and score2 (> score2 2))
(format t "~a + ~a = ~a~%"
subword2
(concatenate 'string (sort letters2 'char<))
word)))))))))
(defun csw-hook-worksheet (length words-shown hooks-shown columns hidden)
(declare (optimize (debug 3)))
(let ((front (make-hash-table :test 'equal))
(back (make-hash-table :test 'equal))
(words nil)
(csw (make-hash-table :test 'equal))
(twl (make-hash-table :test 'equal))
(hook-cols (floor (- columns length 3) 2)))
(do-file-lines (word (string-append *data-directory* "twl.txt"))
(setf (gethash word twl) t))
(do-file-lines (word (string-append *data-directory* "csw.txt"))
(when (and (= length (length word))
(not (gethash word twl)))
(push word words))
(setf (gethash word csw) t))
(setf words (nreverse words))
(do-file-lines (word (string-append *data-directory* "csw.txt"))
(when (= (1+ length) (length word))
(let ((left-substr (subseq word 0 length))
(left-letter (elt word 0))
(right-substr (subseq word 1))
(right-letter (elt word length)))
(when (gethash right-substr csw)
(push (if (gethash word twl)
(char-downcase left-letter)
left-letter)
(gethash right-substr front)))
(when (gethash left-substr csw)
(push (if (gethash word twl)
(char-downcase right-letter)
right-letter)
(gethash left-substr back))))))
(dolist (word words)
(labels ((maybe-hide (letter)
(case hooks-shown
(:all letter)
(:twl (if (char= letter (char-downcase letter))
letter
#\_))
(nil #\_))))
(let* ((raw-fronts (nreverse (gethash word front)))
(fronts (coerce (mapcar #'maybe-hide raw-fronts) 'string))
(front-rows (ceiling (length fronts) hook-cols))
(raw-backs (nreverse (gethash word back)))
(backs (coerce (mapcar #'maybe-hide raw-backs) 'string))
(back-rows (ceiling (length backs) hook-cols)))
(loop
for row below (max 1 front-rows back-rows)
for start = (* row hook-cols)
for end = (+ start hook-cols)
for front-row = (subseq fronts
(min start (length fronts))
(min end (length fronts)))
for back-row = (subseq backs
(min start (length backs))
(min end (length backs)))
for padding = (- hook-cols (length front-row))
do
(loop repeat padding do (format t " "))
(format t "~a " front-row)
(if (zerop row)
(if words-shown
(format t "~a#" word)
(progn
(format t "~a" (subseq word 0 (- length hidden)))
(loop repeat hidden do (format t "_"))
(format t "#")))
(loop repeat (1+ length) do (format t " ")))
(format t " ~a~%" back-row)))))))
|
