chiark - git - mdw - atoms/blob - robot.lisp

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