--- /dev/null
+(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)))
~mdw / atoms / commitdiff