| 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))) |