Commit | Line | Data |
---|---|---|
0a4b03cb MW |
1 | (in-package :atoms) |
2 | ||
3 | (defun score-better-p (this that) | |
4 | (or (eq this :win) | |
5 | (eq that :lose) | |
6 | (and (not (eq this :lose)) | |
7 | (not (eq that :win)) | |
8 | (> this that)))) | |
9 | ||
10 | (defun invert-score (this) | |
11 | (case this | |
12 | (:win :lose) | |
13 | (:lose :win) | |
14 | (t (- this)))) | |
15 | ||
16 | (defparameter *plies* 2) | |
17 | ||
18 | (defun make-board-connectivity-map (width height) | |
19 | (let ((map (make-array (* width height) | |
20 | :element-type 'list | |
21 | :initial-element nil))) | |
22 | (flet ((index (i j) (+ (* j width) i))) | |
23 | (dotimes (j height) | |
24 | (dotimes (i width) | |
25 | (setf (aref map (index i j)) | |
26 | (nconc (and (> j 0) (list (index i (1- j)))) | |
27 | (and (> i 0) (list (index (1- i) j))) | |
28 | (and (< i (1- width)) (list (index (1+ i) j))) | |
29 | (and (< j (1- height)) (list (index i (1+ j)))))))) | |
30 | map))) | |
31 | ||
32 | (deftype octet () '(unsigned-byte 8)) | |
33 | ||
34 | (defun make-critical-count-map (conn-map) | |
35 | (make-array (length conn-map) | |
36 | :element-type 'octet | |
37 | :initial-contents (map 'list #'length conn-map))) | |
38 | ||
39 | (defun make-simple-board (size) | |
40 | (make-array size | |
41 | :element-type 'octet | |
42 | :initial-element 0)) | |
43 | ||
44 | (defun copy-vector (vector) | |
45 | (make-array (length vector) | |
46 | :element-type (array-element-type vector) | |
47 | :initial-contents vector)) | |
48 | ||
49 | (defun simple-score (who counts owners) | |
50 | (reduce #'+ (mapcar (lambda (count owner) | |
51 | (if (= owner who) count 0)) | |
52 | counts owners))) | |
53 | ||
54 | (defun make-checklist (size) | |
55 | (make-array size :element-type 'fixnum :fill-pointer 0)) | |
56 | ||
57 | (defclass robot-state () | |
58 | ((n-players :type octet :reader robot-n-players :initarg :n-players) | |
59 | (me :type octet :reader robot-me :initarg :me) | |
60 | (size :type fixnum :reader robot-size :initarg :size) | |
61 | (conn-map :type (vector list *) :reader robot-conn-map :initarg :conn-map) | |
62 | (crit-map :type (vector octet *) | |
63 | :reader robot-crit-map | |
64 | :initarg :crit-map) | |
65 | (checklist-a :type (vector fixnum *) | |
66 | :reader robot-checklist-a | |
67 | :initarg :checklist-a) | |
68 | (checklist-b :type (vector fixnum *) | |
69 | :reader robot-checklist-b | |
70 | :initarg :checklist-b) | |
71 | (scores :type (vector fixnum *) :reader robot-scores :initarg :scores) | |
72 | (seen :type bit-vector :reader robot-seen :initarg :seen))) | |
73 | ||
74 | (defclass robot-position () | |
75 | ((who :type octet :reader robot-who :initarg :who) | |
76 | (counts :type (vector octet *) :reader robot-counts :initarg :counts) | |
77 | (owners :type (vector octet *) :reader robot-owners :initarg :owners))) | |
78 | ||
79 | (defun make-robot-state (game player) | |
80 | (let* ((grid (game-grid game)) | |
81 | (width (array-dimension grid 1)) | |
82 | (height (array-dimension grid 0)) | |
83 | (size (* width height)) | |
84 | (n-players (length (game-players game))) | |
85 | (conn-map (make-board-connectivity-map width height))) | |
86 | (make-instance 'robot-state | |
87 | :me (1+ (position player (game-players game))) | |
88 | :n-players n-players | |
89 | :size size | |
90 | :conn-map conn-map | |
91 | :crit-map (make-critical-count-map conn-map) | |
92 | :scores (make-array (1+ n-players) :element-type 'fixnum) | |
93 | :checklist-a (make-checklist size) | |
94 | :checklist-b (make-checklist size) | |
95 | :seen (make-array size :element-type 'bit)))) | |
96 | ||
97 | (defun make-robot-position (who counts owners) | |
98 | (make-instance 'robot-position | |
99 | :who who | |
100 | :counts counts | |
101 | :owners owners)) | |
102 | ||
103 | (defun make-initial-robot-position (state game) | |
104 | (let* ((size (robot-size state)) | |
105 | (grid (game-grid game)) | |
106 | (counts (make-simple-board size)) | |
107 | (owners (make-simple-board size))) | |
108 | ||
109 | (dotimes (i size) | |
110 | (let ((cell (row-major-aref grid i))) | |
111 | (setf (aref counts i) (cell-count cell) | |
112 | (aref owners i) (let ((owner (cell-owner cell))) | |
113 | (if owner (1+ owner) 0))))) | |
114 | ||
115 | (make-robot-position (robot-me state) counts owners))) | |
116 | ||
117 | (defclass robot-player (player) | |
118 | ((robot-state :type robot-state :reader robot-player-state))) | |
119 | (setf (player-type-name 'robot-player) "Robot") | |
120 | ||
121 | (defun robot-update-scores (state counts owners) | |
122 | (let ((scores (robot-scores state)) | |
123 | (n-players (robot-n-players state)) | |
124 | (size (robot-size state))) | |
125 | (dotimes (i (1+ n-players)) (setf (aref scores i) 0)) | |
126 | (dotimes (i size) (incf (aref scores (aref owners i)) (aref counts i))))) | |
127 | ||
128 | (defun robot-try-move (state position move) | |
129 | (let ((conn-map (robot-conn-map state)) | |
130 | (crit-map (robot-crit-map state)) | |
131 | (n-players (robot-n-players state)) | |
132 | (size (robot-size state)) | |
133 | (seen (robot-seen state)) | |
134 | (checklist (robot-checklist-a state)) | |
135 | (next-checklist (robot-checklist-b state)) | |
136 | (who (robot-who position)) | |
137 | (scores (robot-scores state)) | |
138 | (owners (copy-vector (robot-owners position))) | |
139 | (counts (copy-vector (robot-counts position)))) | |
140 | ||
141 | (let ((occupier (aref owners move))) | |
142 | (unless (or (zerop occupier) (= occupier who)) | |
143 | (return-from robot-try-move nil))) | |
144 | ||
145 | (block update-board | |
146 | (setf (aref owners move) who) | |
147 | (unless (>= (incf (aref counts move)) | |
148 | (aref crit-map move)) | |
149 | (return-from update-board)) | |
150 | ||
151 | (setf (fill-pointer checklist) 0) | |
152 | (vector-push move checklist) | |
153 | (let ((opponents (count-if (lambda (own) | |
154 | (and (plusp own) (/= own who))) | |
155 | owners))) | |
156 | (loop | |
157 | (when (or (zerop (fill-pointer checklist)) | |
158 | (zerop opponents)) | |
159 | (return-from update-board)) | |
160 | (setf (fill-pointer next-checklist) 0) | |
161 | (dotimes (i size) (setf (bit seen i) 0)) | |
162 | (dotimes (i (fill-pointer checklist)) | |
163 | (let* ((pos (aref checklist i)) | |
164 | (crit (aref crit-map pos))) | |
165 | (multiple-value-bind (dist left) (floor (aref counts pos) crit) | |
166 | (setf (aref counts pos) left) | |
167 | (when (zerop left) | |
168 | (setf (aref owners pos) 0)) | |
169 | (dolist (neigh (aref conn-map pos)) | |
170 | (let ((old-owner (aref owners neigh))) | |
171 | (unless (= old-owner who) | |
172 | (unless (zerop old-owner) (decf opponents)) | |
173 | (setf (aref owners neigh) who)) | |
174 | (when (and (>= (incf (aref counts neigh) dist) | |
175 | (aref crit-map neigh)) | |
176 | (zerop (bit seen neigh))) | |
177 | (vector-push neigh next-checklist) | |
178 | (setf (bit seen neigh) 1))))))) | |
179 | (rotatef checklist next-checklist)))) | |
180 | ||
181 | (robot-update-scores state counts owners) | |
182 | (make-robot-position (do ((i (1+ (mod who n-players)) | |
183 | (1+ (mod i n-players)))) | |
184 | ((plusp (aref scores i)) i)) | |
185 | counts owners))) | |
186 | ||
187 | (defun simple-rating (state position) | |
188 | (declare (ignore position)) | |
189 | (let* ((n-players (robot-n-players state)) | |
190 | (scores (robot-scores state)) | |
191 | (me (robot-me state)) | |
192 | (total (reduce #'+ scores)) | |
193 | (mine (aref scores me))) | |
194 | (cond ((and (zerop mine) (>= total me)) :lose) | |
195 | ((and (= mine total) (>= total n-players)) :win) | |
196 | (t (- (* 2 mine) total))))) | |
197 | ||
198 | (defparameter *robot-n-plies* 2) | |
199 | ||
200 | (defun robot-choose-move (state game) | |
201 | (let ((me (robot-me state)) | |
202 | (size (robot-size state))) | |
203 | (labels ((walk (position depth alpha beta) | |
204 | (let ((who (robot-who position))) | |
205 | ||
206 | #+debug | |
207 | (format t ";; walk; who = ~A; depth remaining = ~A~%" | |
208 | who depth) | |
209 | ||
210 | (let ((rating (simple-rating state position))) | |
211 | (case rating | |
212 | ((:win :lose) | |
213 | #+debug | |
214 | (format t ";; final position ~A~%" rating) | |
215 | (return-from walk (values rating nil)))) | |
216 | (when (zerop depth) | |
217 | #+debug | |
218 | (format t ";; bottomed out; rating = ~A~%" rating) | |
219 | (return-from walk (values rating nil)))) | |
220 | ||
221 | (if (= who me) | |
222 | (let ((best-move nil)) | |
223 | (dotimes (move size) | |
224 | #+debug | |
225 | (format t ";; try my move ~A~%" | |
226 | (multiple-value-list | |
227 | (floor move | |
228 | (array-dimension (game-grid game) | |
229 | 1)))) | |
230 | (let ((next-pos (robot-try-move state | |
231 | position | |
232 | move))) | |
233 | (when next-pos | |
234 | (let ((score (walk next-pos | |
235 | (1- depth) | |
236 | alpha beta))) | |
237 | (when (score-better-p score alpha) | |
238 | #+debug | |
239 | (format t ";; best move so far~%") | |
240 | (setf best-move move | |
241 | alpha score)) | |
242 | (when (score-better-p alpha beta) | |
243 | (return)))))) | |
244 | (values alpha best-move)) | |
245 | (let ((best-move nil)) | |
246 | (dotimes (move size) | |
247 | #+debug | |
248 | (format t ";; try opponent #~A move ~A~%" | |
249 | who | |
250 | (multiple-value-list | |
251 | (floor move | |
252 | (array-dimension (game-grid game) | |
253 | 1)))) | |
254 | (let ((next-pos (robot-try-move state | |
255 | position | |
256 | move))) | |
257 | (when next-pos | |
258 | (let ((score (walk next-pos | |
259 | (1- depth) | |
260 | alpha beta))) | |
261 | (when (score-better-p beta score) | |
262 | #+debug | |
263 | (format t ";; best opponent move so far~%") | |
264 | (setf best-move move | |
265 | beta score)) | |
266 | (when (score-better-p alpha beta) | |
267 | (return)))))) | |
268 | (values beta best-move)))))) | |
269 | (let ((position (make-initial-robot-position state game))) | |
270 | (robot-update-scores state | |
271 | (robot-counts position) | |
272 | (robot-owners position)) | |
273 | (multiple-value-bind (rating move) | |
274 | (walk position *robot-n-plies* :lose :win) | |
275 | (declare (ignore rating)) | |
276 | move))))) | |
277 | ||
278 | (defun robot-move (game player) | |
279 | (let* ((state (robot-player-state player)) | |
280 | (move (robot-choose-move state game)) | |
281 | (grid (game-grid game)) | |
282 | (width (array-dimension grid 1))) | |
283 | (multiple-value-bind (j i) (floor move width) | |
284 | (play-cell game player i j)))) | |
285 | ||
286 | (defun stupid-robot-move (game player) | |
287 | (let* ((state (robot-player-state player)) | |
288 | (grid (game-grid game)) | |
289 | (width (array-dimension grid 1)) | |
290 | (height (array-dimension grid 0)) | |
291 | (moves (make-array (array-total-size grid) :fill-pointer 0))) | |
292 | (dotimes (j height) | |
293 | (dotimes (i width) | |
294 | (let ((occupier (cell-owner (aref grid j i)))) | |
295 | (when (or (null occupier) | |
296 | (= occupier (1- (robot-me state)))) | |
297 | (vector-push (cons i j) moves))))) | |
298 | (let ((move (aref moves (random (length moves))))) | |
299 | (play-cell game player (car move) (cdr move))))) | |
300 | ||
301 | (defmethod player-turn-begin (game (player robot-player)) | |
302 | (unless (slot-boundp player 'robot-state) | |
303 | (setf (slot-value player 'robot-state) (make-robot-state game player))) | |
304 | (robot-move game player)) | |
305 | ||
306 | (unless (find 'robot-player *player-types*) | |
307 | (setf *player-types* | |
308 | (append *player-types* '(robot-player)))) | |
309 | ||
310 | #+debug | |
311 | (start-atom-game :width 7 | |
312 | :players '("Alice" | |
313 | ("RoboBob" :type robot-player))) |