;;;; Code for the game hexapawn (first described by Martin Gardener in ;;;; his columns in the magazine Scientific American and in his book ;;;; The Unespected Hanging and Other Mathematical Diversions (1991 [reprint], ;;;; University of Chicago Press). ;;;; ;;;; For a description of the game see ;;;; http://www.cs.toronto.edu/~mitchell/ai-course/gp.html ;;;; Board states and moves ;;; a board is a 3x3 matrix of characters. The first subscript is ;;; the row with 0 being the bottom (from player Max's perspective) ;;; and the second subscript is the column with 0 being the leftmost. ;;; Contents of an array element are either ;;; space - empty square ;;; i - one of Min's pawns ;;; a - one of Max's pawns ;;; return a blank board (one with no pawns on it)." (defun make-board () (make-array '(3 3) :initial-element " ")) ;;; print board nicely. (defun print-board (board) (format t "~% |---+---+---+") (dotimes (row 3) (progn (format t "~% | | | |~% |") (dotimes (column 3) (progn (format t " ~a |" (aref board (- 2 row) column)))) (format t "~% | | | |") (format t "~% |---+---+---+")))) ;;; returns a board representing the starting position for the game." (defun initial-board () (let ((board (make-board))) (dotimes (i 3) (setf (aref board 0 i) "a")) (dotimes (i 3) (setf (aref board 2 i) "i")) board)) ;;; returns a copy of board. WARNING: the strings for i, a, and space ;;; in the copy may be eq to those in the original, so don't do destructive ;;; operations on them. E.g. (setf (elt i (aref board r c)) x) is BAD. ;;;Use (setf (aref (board r c) x))instead" (defun copy-board (board) (let ((new-board (make-board))) (dotimes (row 3) (dotimes (column 3) (setf (aref new-board row column) (aref board row column)))) new-board)) ;;; player is the string "a" or "i". Returns one of these ;;; two strings - whichever of these strings player is, return the other one. (defun other-player (player) (if (string-equal player "a") "i" "a")) ;;; the row forward (from the perspective of the given player) ;;; from the given row. (defun forward-row (player row) (if (string-equal player "a") (+ row 1) (- row 1))) ;;; returns row that palyer is trying to reach (defun player-goal-row (player) (if (string-equal player "a") 2 0)) ;;; returns a list of boards representing each possible move for the pawn ;;; at the postion of board specified by row and column. Calls error if ;;; unless that element of board is an i or an a. (defun moves-from (board row column) (let ((pawn (aref board row column)) (moves nil)) (if (not (or (string-equal pawn "a") (string-equal pawn "i"))) (error "board element (~a, ~a) is ~a, and should be \"a\" or \"i\"." row column (aref row column)) ;; check for a capture towards column 2 (if (check-capture pawn board row column 1) (setq moves (cons (do-capture pawn board row column 1) moves)))) ;; check for a capture towards column 0 (if (check-capture pawn board row column -1) (setq moves (cons (do-capture pawn board row column -1) moves))) ;; check for move forward (if (check-forward pawn board row column) (setq moves (cons (do-forward pawn board row column) moves))) moves)) ;;; returns t if a capture move is possible, else nil ;;; pawn is "a" or "i" indicating player to move. ;;; board is board state before move ;;; row and column specify position of pawn to move ;;; c-delta is 1 or -1. column + c-delta is column of ;;; pawn to capture (defun check-capture (player board row column c-delta) (let ((c-column (+ column c-delta)) ; column of pawn to capture (c-row (forward-row player row))) ; row of pawn to capture (and (<= 0 c-column 2) (<= 0 c-row 2) (string-equal player (aref board row column)) (string-equal (other-player player) (aref board c-row (+ column c-delta)))))) ;;; returns a board that is result of doing capture indicated by args ;;; (see check-capture for meaning of args) (defun do-capture (player board row column c-delta) (let* ((c-column (+ column c-delta)) ; column of pawn to capture (c-row (forward-row player row)) ; row of pawn to capture (new (copy-board board))) (setf (aref new row column) " ") (setf (aref new c-row c-column) player) new)) ;;; returns t if a forward move is possible, else nil ;;; pawn is "a" or "i" indicating player to move. ;;; board is board state before move ;;; row and column specify position of pawn to move (defun check-forward (player board row column) (let ((f-row (forward-row player row))) ; row to move to (and (<= 0 f-row 2) (string-equal " " (aref board f-row column))))) ;;; returns a board that is result of doing forward move indicated by args ;;; (see check-forward for meaning of args) (defun do-forward (player board row column) (let ((f-row (forward-row player row)) ; row to move to (new (copy-board board))) (setf (aref new row column) " ") (setf (aref new f-row column) player) new)) ;;; returns a list of all moves (next board states) for player from ;;; board (defun player-moves (player board) (let ((moves nil)) (dotimes (row 3) (dotimes (column 3) (if (string-equal player (aref board row column)) (setf moves (append (moves-from board row column) moves))))) moves)) ;;; It is player's turn to move. Has player lost? (defun game-lost (player board) (let ((other (other-player player))) (or (some #'(lambda (c) (string-equal (aref board (player-goal-row other) c) other)) '(0 1 2)) (null (player-moves player board))))) (defun game-value (player board) (if (game-lost player board) (if (string-equal player "a") -10 10) 0)) (defun player-function (player) (if (string-equal player "a") #'max #'min)) (defun minimax-full (player board) (if (game-lost player board) (game-value player board) (let* ((moves (player-moves player board)) (function (player-function player)) (best (minimax-full (other-player player) (car moves)))) (dolist (move (cdr moves)) (setf best (funcall function best (minimax-full (other-player player) move)))) best))) (defun choose-move (player board) (if (game-lost player board) nil (let* ((moves (player-moves player board)) (function (player-function player)) (best-move (car moves)) (best (minimax-full (other-player player) (car moves)))) (dolist (move (cdr moves)) (let ((value (minimax-full (other-player player) move))) (setf best (funcall function best value)) (if (= value best)(setf best-move move)))) best-move)))