From: Mark Wooding Date: Sun, 24 Mar 2013 01:44:51 +0000 (+0000) Subject: robot.lisp: Beginnings of a simple robot player. X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~mdw/git/atoms/commitdiff_plain robot.lisp: Beginnings of a simple robot player. It can usually beat me, so I'm obviously really bad at this. And I can think of lots of ways of making it better. --- diff --git a/robot.lisp b/robot.lisp new file mode 100644 index 0000000..a4c0b6f --- /dev/null +++ b/robot.lisp @@ -0,0 +1,313 @@ +(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)))