robot.lisp: Beginnings of a simple robot player.

[atoms] / robot.lisp

(in-package :atoms)

(defun score-better-p (this that)
  (or (eq this :win)
      (eq that :lose)
      (and (not (eq this :lose))
           (not (eq that :win))
           (> this that))))

(defun invert-score (this)
  (case this
    (:win :lose)
    (:lose :win)
    (t (- this))))

(defparameter *plies* 2)

(defun make-board-connectivity-map (width height)
  (let ((map (make-array (* width height)
                         :element-type 'list
                         :initial-element nil)))
    (flet ((index (i j) (+ (* j width) i)))
      (dotimes (j height)
        (dotimes (i width)
          (setf (aref map (index i j))
                (nconc (and (> j 0) (list (index i (1- j))))
                       (and (> i 0) (list (index (1- i) j)))
                       (and (< i (1- width)) (list (index (1+ i) j)))
                       (and (< j (1- height)) (list (index i (1+ j))))))))
      map)))

(deftype octet () '(unsigned-byte 8))

(defun make-critical-count-map (conn-map)
  (make-array (length conn-map)
              :element-type 'octet
              :initial-contents (map 'list #'length conn-map)))

(defun make-simple-board (size)
  (make-array size
              :element-type 'octet
              :initial-element 0))

(defun copy-vector (vector)
  (make-array (length vector)
              :element-type (array-element-type vector)
              :initial-contents vector))

(defun simple-score (who counts owners)
  (reduce #'+ (mapcar (lambda (count owner)
                        (if (= owner who) count 0))
                      counts owners)))

(defun make-checklist (size)
  (make-array size :element-type 'fixnum :fill-pointer 0))

(defclass robot-state ()
  ((n-players :type octet :reader robot-n-players :initarg :n-players)
   (me :type octet :reader robot-me :initarg :me)
   (size :type fixnum :reader robot-size :initarg :size)
   (conn-map :type (vector list *) :reader robot-conn-map :initarg :conn-map)
   (crit-map :type (vector octet *)
             :reader robot-crit-map
             :initarg :crit-map)
   (checklist-a :type (vector fixnum *)
                :reader robot-checklist-a
                :initarg :checklist-a)
   (checklist-b :type (vector fixnum *)
                :reader robot-checklist-b
                :initarg :checklist-b)
   (scores :type (vector fixnum *) :reader robot-scores :initarg :scores)
   (seen :type bit-vector :reader robot-seen :initarg :seen)))

(defclass robot-position ()
  ((who :type octet :reader robot-who :initarg :who)
   (counts :type (vector octet *) :reader robot-counts :initarg :counts)
   (owners :type (vector octet *) :reader robot-owners :initarg :owners)))

(defun make-robot-state (game player)
  (let* ((grid (game-grid game))
         (width (array-dimension grid 1))
         (height (array-dimension grid 0))
         (size (* width height))
         (n-players (length (game-players game)))
         (conn-map (make-board-connectivity-map width height)))
    (make-instance 'robot-state
                   :me (1+ (position player (game-players game)))
                   :n-players n-players
                   :size size
                   :conn-map conn-map
                   :crit-map (make-critical-count-map conn-map)
                   :scores (make-array (1+ n-players) :element-type 'fixnum)
                   :checklist-a (make-checklist size)
                   :checklist-b (make-checklist size)
                   :seen (make-array size :element-type 'bit))))

(defun make-robot-position (who counts owners)
  (make-instance 'robot-position
                 :who who
                 :counts counts
                 :owners owners))

(defun make-initial-robot-position (state game)
  (let* ((size (robot-size state))
         (grid (game-grid game))
         (counts (make-simple-board size))
         (owners (make-simple-board size)))

    (dotimes (i size)
      (let ((cell (row-major-aref grid i)))
        (setf (aref counts i) (cell-count cell)
              (aref owners i) (let ((owner (cell-owner cell)))
                                (if owner (1+ owner) 0)))))

    (make-robot-position (robot-me state) counts owners)))

(defclass robot-player (player)
  ((robot-state :type robot-state :reader robot-player-state)))
(setf (player-type-name 'robot-player) "Robot")

(defun robot-update-scores (state counts owners)
  (let ((scores (robot-scores state))
        (n-players (robot-n-players state))
        (size (robot-size state)))
    (dotimes (i (1+ n-players)) (setf (aref scores i) 0))
    (dotimes (i size) (incf (aref scores (aref owners i)) (aref counts i)))))

(defun robot-try-move (state position move)
  (let ((conn-map (robot-conn-map state))
        (crit-map (robot-crit-map state))
        (n-players (robot-n-players state))
        (size (robot-size state))
        (seen (robot-seen state))
        (checklist (robot-checklist-a state))
        (next-checklist (robot-checklist-b state))
        (who (robot-who position))
        (scores (robot-scores state))
        (owners (copy-vector (robot-owners position)))
        (counts (copy-vector (robot-counts position))))

    (let ((occupier (aref owners move)))
      (unless (or (zerop occupier) (= occupier who))
        (return-from robot-try-move nil)))

    (block update-board
      (setf (aref owners move) who)
      (unless (>= (incf (aref counts move))
                  (aref crit-map move))
        (return-from update-board))

      (setf (fill-pointer checklist) 0)
      (vector-push move checklist)
      (let ((opponents (count-if (lambda (own)
                                   (and (plusp own) (/= own who)))
                                 owners)))
        (loop
          (when (or (zerop (fill-pointer checklist))
                    (zerop opponents))
            (return-from update-board))
          (setf (fill-pointer next-checklist) 0)
          (dotimes (i size) (setf (bit seen i) 0))
          (dotimes (i (fill-pointer checklist))
            (let* ((pos (aref checklist i))
                   (crit (aref crit-map pos)))
              (multiple-value-bind (dist left) (floor (aref counts pos) crit)
                (setf (aref counts pos) left)
                (when (zerop left)
                  (setf (aref owners pos) 0))
                (dolist (neigh (aref conn-map pos))
                  (let ((old-owner (aref owners neigh)))
                    (unless (= old-owner who)
                      (unless (zerop old-owner) (decf opponents))
                      (setf (aref owners neigh) who))
                    (when (and (>= (incf (aref counts neigh) dist)
                                   (aref crit-map neigh))
                               (zerop (bit seen neigh)))
                      (vector-push neigh next-checklist)
                      (setf (bit seen neigh) 1)))))))
          (rotatef checklist next-checklist))))

    (robot-update-scores state counts owners)
    (make-robot-position (do ((i (1+ (mod who n-players))
                                 (1+ (mod i n-players))))
                             ((plusp (aref scores i)) i))
                         counts owners)))

(defun simple-rating (state position)
  (declare (ignore position))
  (let* ((n-players (robot-n-players state))
         (scores (robot-scores state))
         (me (robot-me state))
         (total (reduce #'+ scores))
         (mine (aref scores me)))
    (cond ((and (zerop mine) (>= total me)) :lose)
          ((and (= mine total) (>= total n-players)) :win)
          (t (- (* 2 mine) total)))))

(defparameter *robot-n-plies* 2)

(defun robot-choose-move (state game)
  (let ((me (robot-me state))
        (size (robot-size state)))
    (labels ((walk (position depth alpha beta)
               (let ((who (robot-who position)))

                 #+debug
                 (format t ";; walk; who = ~A; depth remaining = ~A~%"
                         who depth)

                 (let ((rating (simple-rating state position)))
                   (case rating
                     ((:win :lose)
                      #+debug
                      (format t ";;   final position ~A~%" rating)
                      (return-from walk (values rating nil))))
                   (when (zerop depth)
                     #+debug
                     (format t ";;   bottomed out; rating = ~A~%" rating)
                     (return-from walk (values rating nil))))

                 (if (= who me)
                     (let ((best-move nil))
                       (dotimes (move size)
                         #+debug
                         (format t ";;   try my move ~A~%"
                                 (multiple-value-list
                                  (floor move
                                         (array-dimension (game-grid game)
                                                          1))))
                         (let ((next-pos (robot-try-move state
                                                         position
                                                         move)))
                           (when next-pos
                             (let ((score (walk next-pos
                                                (1- depth)
                                                alpha beta)))
                               (when (score-better-p score alpha)
                                 #+debug
                                 (format t ";;   best move so far~%")
                                 (setf best-move move
                                       alpha score))
                               (when (score-better-p alpha beta)
                                 (return))))))
                       (values alpha best-move))
                     (let ((best-move nil))
                       (dotimes (move size)
                         #+debug
                         (format t ";;   try opponent #~A move ~A~%"
                                 who
                                 (multiple-value-list
                                  (floor move
                                         (array-dimension (game-grid game)
                                                          1))))
                         (let ((next-pos (robot-try-move state
                                                         position
                                                         move)))
                           (when next-pos
                             (let ((score (walk next-pos
                                                (1- depth)
                                                alpha beta)))
                               (when (score-better-p beta score)
                                 #+debug
                                 (format t ";;   best opponent move so far~%")
                                 (setf best-move move
                                       beta score))
                               (when (score-better-p alpha beta)
                                 (return))))))
                       (values beta best-move))))))
      (let ((position (make-initial-robot-position state game)))
        (robot-update-scores state
                             (robot-counts position)
                             (robot-owners position))
        (multiple-value-bind (rating move)
            (walk position *robot-n-plies* :lose :win)
          (declare (ignore rating))
          move)))))

(defun robot-move (game player)
  (let* ((state (robot-player-state player))
         (move (robot-choose-move state game))
         (grid (game-grid game))
         (width (array-dimension grid 1)))
    (multiple-value-bind (j i) (floor move width)
      (play-cell game player i j))))

(defun stupid-robot-move (game player)
  (let* ((state (robot-player-state player))
         (grid (game-grid game))
         (width (array-dimension grid 1))
         (height (array-dimension grid 0))
         (moves (make-array (array-total-size grid) :fill-pointer 0)))
    (dotimes (j height)
      (dotimes (i width)
        (let ((occupier (cell-owner (aref grid j i))))
          (when (or (null occupier)
                    (= occupier (1- (robot-me state))))
            (vector-push (cons i j) moves)))))
    (let ((move (aref moves (random (length moves)))))
      (play-cell game player (car move) (cdr move)))))

(defmethod player-turn-begin (game (player robot-player))
  (unless (slot-boundp player 'robot-state)
    (setf (slot-value player 'robot-state) (make-robot-state game player)))
  (robot-move game player))

(unless (find 'robot-player *player-types*)
  (setf *player-types*
        (append *player-types* '(robot-player))))

#+debug
(start-atom-game :width 7
                 :players '("Alice"
                            ("RoboBob" :type robot-player)))