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
|
(in-package :ouat)
(defvar *alphabet*
(loop
for letter from (char-code #\A) to (char-code #\Z)
for index from 0
collect index))
(defvar +alphabet-size+ (length *alphabet*))
(defvar *bits* (make-array '(28)))
(defvar *other-bits* (make-array '(28)))
(defconstant +blank+ 26)
(defconstant +star+ 27)
(defconstant +space+ 28)
(defmacro 1bit (x)
`(aref *bits* ,x))
(defmacro other-bits (x)
`(aref *other-bits* ,x))
(dotimes (x 28) (setf (1bit x) (ash 1 x)))
(dotimes (x 28) (setf (other-bits x) (ilognot (1bit x))))
(defun letter2char (letter)
(if (i= +space+ letter)
#\Space
(code-char (+ letter (char-code #\A)))))
(defun word2list (word)
(mapcar #'(lambda (x) (- (char-code x) (char-code #\A)))
(coerce word 'list)))
(defun format-bits (bits)
(coerce
(loop
for i from 0 to 25
append (unless (zerop (logand bits (1bit i)))
(list (letter2char i))))
'string))
(defun letter-int (letter)
(cond
((eq letter #\?) +blank+)
((eq letter #\.) +blank+)
((eq letter #\*) +star+)
((eq letter #\/) +star+)
((and (>= (char-code letter) (char-code #\A))
(<= (char-code letter) (char-code #\Z)))
(- (char-code letter) (char-code #\A)))
((and (>= (char-code letter) (char-code #\a))
(<= (char-code letter) (char-code #\z)))
(- (char-code letter) (char-code #\a)))))
(defun word-list (word)
(mapcar 'letter-int (coerce word 'list)))
(defun list2word (list)
(coerce (mapcar #'letter2char (reverse list)) 'string))
(defun word-set (word)
(let ((set (make-array '(28) :initial-element 0)))
(dolist (letter (word-list word))
(incf (aref set letter)))
set))
(defun word-alist (word)
(let ((set (word-set word)))
(loop
for letter to +star+
append (let ((number (aref set letter)))
(unless (zerop number)
(list (cons letter (aref set letter))))))))
(defun word-bits (word)
(let ((word-bits 0)
(set (word-set word)))
(dolist (letter *alphabet*)
(unless (zerop (aref set letter))
(setf word-bits (logior word-bits (1bit letter)))))
word-bits))
(defun num-tiles (set)
(loop
for i from 0 to 26
sum (aref set i)))
(defun reverse-length (list)
(sort list '< :key (lambda (x) (length x))))
(defvar *one-bits-per-13* (make-array `(,(ash 1 13))))
(dotimes (x (ash 1 13))
(setf (aref *one-bits-per-13* x)
(loop for i from 0 to 12 counting (not (zerop (logand x (1bit i)))))))
(defvar *mask* (make-array '(28)))
(dotimes (x 28)
(setf (aref *mask* x) (- (ash 1 x) 1)))
(defmacro mask (x) `(aref *mask* ,x))
(defun string-tokens (string)
(labels ((get-token (str pos1 acc)
(let ((pos2 (position #\Space str :start pos1)))
(if (not pos2)
(nreverse acc)
(get-token str
(1+ pos2)
(cons (subseq str pos1 pos2)
acc))))))
(get-token (concatenate 'string string " ") 0 nil)))
(defun string-append (&rest strings)
(coerce (apply 'append (mapcar #'(lambda (string) (coerce string 'list))
strings))
'string))
(defun unique (list)
(remove-duplicates list :test 'equal))
(defmacro do-file-lines ((line filename) &body body)
`(with-open-file (stream ,filename)
(loop
for ,line = (read-line stream nil) while ,line
do ,@body)))
(defun shuffle (seq)
(map-into seq #'car
(sort (map 'vector
(lambda (x)
(cons x (random MOST-POSITIVE-FIXNUM))) seq)
#'< :key #'cdr)))
(defmacro set-bitf (place b)
`(declare ((type fixnum ,place ,b)))
`(setf ,place (ilogior ,place (1bit ,b))))
(defmacro unset-bitf (place b)
`(declare ((type fixnum ,place ,b)))
`(setf ,place (ilogand ,place (other-bits ,b))))
|
