base.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: reversi -*-
   2 ;;;;***************************************************************************
   3 ;;;;
   4 ;;;; FILE IDENTIFICATION
   5 ;;;;
   6 ;;;;  Name:           base.lisp
   7 ;;;;  Purpose:        Basic functions for reversi
   8 ;;;;  Programer:      Kevin Rosenberg based on code by Peter Norvig
   9 ;;;;  Date Started:   1 Nov 2001
  10 ;;;;
  11 ;;;; $Id: base.lisp,v 1.3 2003/05/06 15:51:20 kevin Exp $
  12 ;;;;
  13 ;;;; This file is Copyright (c) 2001-2002 by Kevin M. Rosenberg
  14 ;;;; and Copyright (c) 1998-2002 Peter Norvig
  15 ;;;;
  16 ;;;; Reversi users are granted the rights to distribute and use this software
  17 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
  18 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
  19 ;;;;***************************************************************************
  20
  21 (in-package #:reversi)
  22
  23 (eval-when (:compile-toplevel)
  24   (declaim (optimize (safety 1) (space 0) (speed 3) (compilation-speed 0))))
  25
  26 (defparameter +all-directions+ '(-11 -10 -9 -1 1 9 10 11))
  27 (defconstant +default-max-minutes+ 30)
  28
  29 (defconstant empty 0 "An empty square")
  30 (defconstant black 1 "A black piece")
  31 (defconstant white 2 "A white piece")
  32 (defconstant outer 3 "Marks squares outside the 8x8 board")
  33 ;;(declaim (type (unsigned-byte 8) empty black white outer))
  34 (declaim (type fixnum empty black white outer))
  35
  36 #|
  37 (deftype piece () '(unsigned-byte 8))
  38 (deftype player () '(unsigned-byte 8))
  39 (deftype move () '(unsigned-byte 8))
  40 (deftype square () '(unsigned-byte 8))
  41 |#
  42
  43 (deftype piece () 'fixnum)
  44 (deftype player () 'fixnum)
  45 (deftype move () 'fixnum)
  46 (deftype square () 'fixnum)
  47 (deftype dir () 'fixnum)
  48 (deftype board () '(simple-array fixnum (100)))
  49 ;;(deftype board () '(simple-array (unsigned-byte 8) (100)))
  50 (deftype clock () '(simple-array integer (3)))
  51
  52 (defun make-moves ()
  53   (make-array 60 :element-type 'cons :fill-pointer 0
  54               :adjustable nil))
  55 (deftype moves () '(array cons (60)))
  56
  57
  58 (defclass reversi-game ()
  59   ((bl-strategy :initarg :bl-strategy
  60                 :documentation "Strategy function for black"
  61                 :reader bl-strategy)
  62    (wh-strategy :initarg :wh-strategy
  63                 :documentation "Strategy function for white"
  64                 :reader wh-strategy)
  65    (board :type board :initarg :board
  66           :documentation "The board configuration"
  67           :reader board)
  68    (move-number :type fixnum :initarg :move-number
  69                 :documentation "The number of the move to be played"
  70                 :accessor move-number)
  71    (player :type player :initarg :player
  72                 :documentation "ID of next player to move"
  73                 :accessor player)
  74    (moves :type moves :initarg :moves
  75           :documentation "An array of moves played in the game"
  76           :accessor moves)
  77    (print? :type boolean :initarg :print?
  78            :documentation "Whether to print progress of this game"
  79            :reader print?)
  80    (record-game? :type boolean :initarg :record-game?
  81            :documentation "Whether to record moves and clcck of this game"
  82            :reader record-game?)
  83    (final-result :type fixnum :initarg :final-result
  84                  :documentation "Final count, is NIL while game in play"
  85                  :accessor final-result)
  86    (max-minutes :type fixnum :initarg :max-minutes
  87                 :documentation "Maximum minites for each player"
  88                 :reader max-minutes)
  89    (clock :type clock :initarg :clock :initform nil
  90           :documentation "An array of time-units left"
  91           :accessor clock))
  92   (:default-initargs
  93       :bl-strategy nil
  94     :wh-strategy nil
  95     :board (initial-board)
  96     :move-number 1
  97     :player black
  98     :moves (make-moves)
  99     :print? nil
 100     :record-game? nil
 101     :final-result nil
 102     :max-minutes +default-max-minutes+
 103     :clock (make-clock +default-max-minutes+)))
 104
 105
 106 (defun name-of (piece) (char ".@O?" piece))
 107 (defun title-of (piece) (nth (1- piece) '("Black" "White")) )
 108
 109 (defmacro opponent (player)
 110   `(if (= ,player black) white black))
 111
 112 (defmacro bref (board square)
 113   `(the piece (aref (the board ,board) (the square ,square))))
 114
 115 (defparameter all-squares
 116     (loop for i from 11 to 88 when (<= 1 (mod i 10) 8) collect i)
 117   "A list of all squares")
 118
 119 (defun initial-board ()
 120   "Return a board, empty except for four pieces in the middle."
 121   ;; Boards are 100-element vectors, with elements 11-88 used,
 122   ;; and the others marked with the sentinel OUTER.  Initially
 123   ;; the 4 center squares are taken, the others empty.
 124   (let ((board (make-array 100 :element-type 'fixnum
 125                            :initial-element outer
 126                            :adjustable nil :fill-pointer nil)))
 127     (declare (type board board))
 128     (dolist (square all-squares)
 129       (declare (fixnum square))
 130       (setf (bref board square) empty))
 131     (setf (bref board 44) white   (bref board 45) black
 132           (bref board 54) black   (bref board 55) white)
 133     board))
 134
 135 (defun copy-board (board)
 136   (copy-seq board))
 137
 138 (defgeneric make-clock (clock))
 139 (defmethod make-clock ((clock array))
 140   (make-array (+ 1 (max black white))
 141               :element-type 'integer
 142               :initial-contents clock
 143               :adjustable nil
 144               :fill-pointer nil))
 145
 146 (defmethod make-clock ((minutes integer))
 147   (make-array (+ 1 (max black white))
 148               :element-type 'integer
 149               :initial-element
 150               (* minutes 60
 151                  internal-time-units-per-second)
 152               :adjustable nil
 153               :fill-pointer nil))
 154
 155 (defun count-difference (player board)
 156   "Count player's pieces minus opponent's pieces."
 157   (declare (type board board)
 158            (fixnum player))
 159   (- (count player board)
 160      (count (opponent player) board)))
 161
 162 (defun valid-p (move)
 163   (declare (type move move))
 164   "Valid moves are numbers in the range 11-88 that end in 1-8."
 165   (and (typep move 'move) (<= 11 move 88) (<= 1 (mod move 10) 8)))
 166
 167 #+ignore
 168 (defun legal-p (move player board)
 169   "A Legal move must be into an empty square, and it must
 170   flip at least one opponent piece."
 171   (declare (type board board)
 172            (type move move)
 173            (type player player))
 174   (and (= (the piece (bref board move)) empty)
 175        (some #'(lambda (dir) (declare (type dir dir)) (would-flip? move player board dir))
 176              +all-directions+)))
 177
 178 #+ignore
 179 (defun legal-p (move player board)
 180   "A Legal move must be into an empty square, and it must
 181   flip at least one opponent piece."
 182   (declare (type board board)
 183            (type move move)
 184            (type player player)
 185            (optimize speed (safety 0))
 186 )
 187   (if (= (bref board move) empty)
 188       (block search
 189         (let ((i 0))
 190           (declare (fixnum i))
 191           (tagbody t
 192             (when (>= i 8) (return-from search nil))
 193             (when (would-flip? move player board (aref +all-directions+ i))
 194               (return-from search t))
 195             (incf i)
 196             (go t))))
 197     nil))
 198
 199 (defun legal-p (move player board)
 200   "A Legal move must be into an empty square, and it must
 201   flip at least one opponent piece."
 202   (declare (type board board)
 203            (type move move)
 204            (type player player)
 205            (optimize (speed 3) (safety 0))
 206 )
 207   (if (= (the piece (bref board move)) empty)
 208       (block search
 209         (dolist (dir +all-directions+)
 210           (declare (type dir dir))
 211           (when (would-flip? move player board dir)
 212             (return-from search t)))
 213         (return-from search nil))
 214     nil))
 215
 216 (defstruct (state (:constructor make-state-struct))
 217   move player board clock)
 218
 219 (defun make-state (move player clock board)
 220   (make-state-struct :move move :player player :clock (make-clock clock) :board (copy-board board)))
 221
 222 (defun make-game-move (game move player)
 223   (when (record-game? game)
 224     (vector-push (make-state move player (clock game) (board game))
 225                  (moves game)))
 226   (make-move move player (board game))
 227   (incf (move-number game)))
 228
 229 (defun reset-game (game &optional (move-number 1))
 230   (if (record-game? game)
 231       (when (< move-number (move-number game))
 232         (let ((old-state (aref (moves game) (1- move-number))))
 233           (if old-state
 234               (progn
 235                 (setf (player game) (state-player old-state))
 236                 (replace-board (board game) (state-board old-state))
 237                 (replace (clock game) (state-clock old-state))
 238                 (setf (fill-pointer (moves game)) (1- move-number))
 239                 (setf (move-number game) move-number))
 240             (warn "Couldn't find old state"))))
 241   (warn "Tried to reset game, but game is not being recorded")))
 242
 243 (defun make-move (move player board)
 244   "Update board to reflect move by player"
 245   ;; First make the move, then make any flips
 246   (declare (type board board)
 247            (type move move)
 248            (type player)
 249            (optimize (speed 3) (safety 0))
 250 )
 251   (setf (bref board move) player)
 252   (dolist (dir +all-directions+)
 253     (declare (type dir dir))
 254     (make-flips move player board dir))
 255   board)
 256
 257 (defun make-flips (move player board dir)
 258   "Make any flips in the given direction."
 259   (declare (type board board)
 260            (type move move)
 261            (type player player)
 262            (type dir dir)
 263            (optimize (speed 3) (safety 0))
 264 )
 265   (let ((bracketer (would-flip? move player board dir)))
 266     (when bracketer
 267       (loop for c from (+ move dir) by dir until (= c (the fixnum bracketer))
 268             do (setf (bref board c) player)))))
 269
 270 (defun would-flip? (move player board dir)
 271   "Would this move result in any flips in this direction?
 272   If so, return the square number of the bracketing piece."
 273   ;; A flip occurs if, starting at the adjacent square, c, there
 274   ;; is a string of at least one opponent pieces, bracketed by
 275   ;; one of player's pieces
 276   (declare (type board board)
 277            (type move move)
 278            (type player player)
 279            (type dir dir)
 280            (optimize (speed 3) (safety 0))
 281 )
 282   (let ((c (+ move dir)))
 283     (declare (type square c))
 284     (and (= (the piece (bref board c)) (the player (opponent player)))
 285          (find-bracketing-piece (+ c dir) player board dir))))
 286
 287 (defun find-bracketing-piece (square player board dir)
 288   "Return the square number of the bracketing piece."
 289   (declare (type board board)
 290            (type square square)
 291            (type player player)
 292            (type dir dir)
 293            (optimize (speed 3) (safety 0))
 294 )
 295   (cond ((= (bref board square) player) square)
 296         ((= (bref board square) (the player (opponent player)))
 297          (find-bracketing-piece (the square (+ square dir)) player board dir))
 298         (t nil)))
 299
 300 (defun next-to-play (board previous-player &optional (print nil))
 301   "Compute the player to move next, or NIL if nobody can move."
 302   (declare (type board board)
 303            (type player previous-player)
 304            (type boolean print))
 305   (let ((opp (opponent previous-player)))
 306     (cond ((any-legal-move? opp board) opp)
 307           ((any-legal-move? previous-player board)
 308            (when print
 309              (format t "~&~c has no moves and must pass."
 310                      (name-of opp)))
 311            previous-player)
 312           (t nil))))
 313
 314 (defun any-legal-move? (player board)
 315   "Does player have any legal moves in this position?"
 316   (declare (type player player)
 317            (type board board))
 318   (some #'(lambda (move) (declare (type move move)) (legal-p move player board))
 319         all-squares))
 320
 321
 322 (defun legal-moves (player board)
 323   "Returns a list of legal moves for player"
 324   ;;*** fix, segre, 3/30/93.  Was remove-if, which can share with all-squares.
 325   (declare (type player player)
 326            (type board board))
 327   (loop for move in all-squares
 328       when (legal-p move player board) collect move))
 329
 330 #-allegro
 331 (defun replace-board (to from)
 332   (replace to from))
 333
 334 #+ignore
 335 (defun replace-board (to from)
 336   (declare (type board to from)
 337            (optimize (safety 0) (debug 0) (speed 3))
 338 )
 339   (dotimes (i 100)
 340     (declare (type 'fixnum i))
 341     (setf (aref to i) (aref from i)))
 342   to)
 343
 344 #+allegro
 345 (defun replace-board (to from)
 346   (declare (type board to from))
 347   (ff::fslot-memory-copy to 0 400 from)
 348   to)
 349
 350 (defvar *ply-boards*
 351   (apply #'vector (loop repeat 40 collect (initial-board))))
 352
 353
 354
 355 (defvar *move-number* 1 "The number of the move to be played")
 356 (declaim (type fixnum *move-number*))
 357
 358 (defun make-game (bl-strategy wh-strategy
 359                   &key
 360                   (print t)
 361                   (minutes +default-max-minutes+)
 362                   (record-game nil))
 363   (let ((game
 364          (make-instance 'reversi-game :bl-strategy bl-strategy
 365                         :wh-strategy wh-strategy
 366                         :print? print
 367                         :record-game? record-game
 368                         :max-minutes minutes)))
 369     (setf (clock game) (make-clock minutes))
 370     game))
 371
 372 (defun play-game (game)
 373   (catch 'game-over
 374     (until (null (player game))
 375            (setq *move-number* (move-number game))
 376            (get-move game
 377                      (if (= (player game) black)
 378                          (bl-strategy game)
 379                        (wh-strategy game))
 380                      (player game)
 381                      (board game) (print? game) (clock game))
 382            (setf (player game)
 383              (next-to-play (board game) (player game) (print? game)))
 384            (incf (move-number game))))
 385   (when (print? game)
 386     (format t "~&The game is over.  Final result:")
 387     (print-board (board game) (clock game)))
 388   (count-difference black (board game)))
 389
 390
 391 (defun reversi (bl-strategy wh-strategy
 392                 &optional (print t) (minutes +default-max-minutes+))
 393   (play-game (make-game bl-strategy wh-strategy :print print
 394                         :record-game nil :minutes minutes)))
 395
 396 (defvar *clock* (make-clock +default-max-minutes+) "A copy of the game clock")
 397 (defvar *board* (initial-board) "A copy of the game board")
 398
 399 (defun get-move (game strategy player board print clock)
 400   "Call the player's strategy function to get a move.
 401   Keep calling until a legal move is made."
 402   ;; Note we don't pass the strategy function the REAL board.
 403   ;; If we did, it could cheat by changing the pieces on the board.
 404   (when print (print-board board clock))
 405   (replace *clock* clock)
 406   (let* ((t0 (get-internal-real-time))
 407          (move (funcall strategy player (replace-board *board* board)))
 408          (t1 (get-internal-real-time)))
 409     (decf (elt clock player) (- t1 t0))
 410     (cond
 411       ((< (elt clock player) 0)
 412        (format t "~&~c has no time left and forfeits."
 413                (name-of player))
 414        (throw 'game-over (if (eql player black) -64 64)))
 415       ((eq move 'resign)
 416        (throw 'game-over (if (eql player black) -64 64)))
 417       ((and (valid-p move) (legal-p move player board))
 418        (when print
 419          (format t "~&~c moves to ~a."
 420                  (name-of player) (88->h8 move)))
 421        (make-game-move game move player))
 422       (t (warn "Illegal move: ~a" (88->h8 move))
 423          (get-move game strategy player board print clock)))))
 424
 425
 426 (defun random-reversi-series (strategy1 strategy2
 427                               n-pairs &optional (n-random 10))
 428   "Play a series of 2*n games, starting from a random position."
 429   (reversi-series
 430     (switch-strategies #'random-strategy n-random strategy1)
 431     (switch-strategies #'random-strategy n-random strategy2)
 432     n-pairs))
 433
 434 (defun switch-strategies (strategy1 m strategy2)
 435   "Make a new strategy that plays strategy1 for m moves,
 436   then plays according to strategy2."
 437   #'(lambda (player board)
 438       (funcall (if (<= *move-number* m) strategy1 strategy2)
 439                player board)))
 440
 441 (defun reversi-series (strategy1 strategy2 n-pairs)
 442   "Play a series of 2*n-pairs games, swapping sides."
 443   (let ((scores
 444           (loop repeat n-pairs
 445              for random-state = (make-random-state)
 446              collect (reversi strategy1 strategy2 nil)
 447              do (setf *random-state* random-state)
 448              collect (- (reversi strategy2 strategy1 nil)))))
 449     ;; Return the number of wins (1/2 for a tie),
 450     ;; the total of the point differences, and the
 451     ;; scores themselves, all from strategy1's point of view.
 452     (values (+ (count-if #'plusp scores)
 453                (/ (count-if #'zerop scores) 2))
 454             (apply #'+ scores)
 455             scores)))
 456
 457 (defun round-robin (strategies n-pairs &optional
 458                     (n-random 10) (names strategies))
 459   "Play a tournament among the strategies.
 460   N-PAIRS = games each strategy plays as each color against
 461   each opponent.  So with N strategies, a total of
 462   N*(N-1)*N-PAIRS games are played."
 463   (let* ((N (length strategies))
 464          (totals (make-array N :initial-element 0))
 465          (scores (make-array (list N N)
 466                              :initial-element 0)))
 467     ;; Play the games
 468     (dotimes (i N)
 469       (loop for j from (+ i 1) to (- N 1) do
 470           (let* ((wins (random-reversi-series
 471                          (elt strategies i)
 472                          (elt strategies j)
 473                          n-pairs n-random))
 474                  (losses (- (* 2 n-pairs) wins)))
 475             (incf (aref scores i j) wins)
 476             (incf (aref scores j i) losses)
 477             (incf (aref totals i) wins)
 478             (incf (aref totals j) losses))))
 479     ;; Print the results
 480     (dotimes (i N)
 481       (format t "~&~a~20T ~4f: " (elt names i) (elt totals i))
 482       (dotimes (j N)
 483         (format t "~4f " (if (eql i j) '---
 484                            (aref scores i j)))))))
 485