original/othello-orig.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: Common-Lisp -*-
   2 ;;;; Code from Paradigms of AI Programming
   3 ;;;; Copyright (c) 1991 Peter Norvig
   4
   5 ;;;; File othello.lisp: An othello monitor, with all strategies
   6 ;;;; up to and including section 18.8
   7
   8 ;;; One bug fix by Alberto Segre, segre@cs.cornell.edu, March 1993.
   9
  10 (defun mappend (fn list)
  11   "Append the results of calling fn on each element of list.
  12   Like mapcon, but uses append instead of nconc."
  13   (apply #'append (mapcar fn list)))
  14
  15 (defun random-elt (seq)
  16   "Pick a random element out of a sequence."
  17   (elt seq (random (length seq))))
  18
  19 (defun concat-symbol (&rest args)
  20   "Concatenate symbols or strings to form an interned symbol"
  21   (intern (format nil "~{~a~}" args)))
  22
  23 (defun cross-product (fn xlist ylist)
  24   "Return a list of all (fn x y) values."
  25   (mappend #'(lambda (y)
  26                (mapcar #'(lambda (x) (funcall fn x y))
  27                        xlist))
  28            ylist))
  29
  30 (defconstant all-directions '(-11 -10 -9 -1 1 9 10 11))
  31
  32 (defconstant empty 0 "An empty square")
  33 (defconstant black 1 "A black piece")
  34 (defconstant white 2 "A white piece")
  35 (defconstant outer 3 "Marks squares outside the 8x8 board")
  36
  37 (deftype piece () `(integer ,empty ,outer))
  38
  39 (defun name-of (piece) (char ".@O?" piece))
  40
  41 (defun opponent (player) (if (eql player black) white black))
  42
  43 (deftype board () '(simple-array piece (100)))
  44
  45 (defun bref (board square) (aref board square))
  46 (defsetf bref (board square) (val)
  47   `(setf (aref ,board ,square) ,val))
  48
  49 (defun copy-board (board)
  50   (copy-seq board))
  51
  52 (defconstant all-squares
  53   (loop for i from 11 to 88 when (<= 1 (mod i 10) 8) collect i))
  54
  55 (defun initial-board ()
  56   "Return a board, empty except for four pieces in the middle."
  57   ;; Boards are 100-element vectors, with elements 11-88 used,
  58   ;; and the others marked with the sentinel OUTER.  Initially
  59   ;; the 4 center squares are taken, the others empty.
  60   (let ((board (make-array 100 :element-type 'piece
  61                            :initial-element outer)))
  62     (dolist (square all-squares)
  63       (setf (bref board square) empty))
  64     (setf (bref board 44) white   (bref board 45) black
  65           (bref board 54) black   (bref board 55) white)
  66     board))
  67
  68 (defun count-difference (player board)
  69   "Count player's pieces minus opponent's pieces."
  70   (- (count player board)
  71      (count (opponent player) board)))
  72
  73 (defun valid-p (move)
  74   "Valid moves are numbers in the range 11-88 that end in 1-8."
  75   (and (integerp move) (<= 11 move 88) (<= 1 (mod move 10) 8)))
  76
  77 (defun legal-p (move player board)
  78   "A Legal move must be into an empty square, and it must
  79   flip at least one opponent piece."
  80   (and (eql (bref board move) empty)
  81        (some #'(lambda (dir) (would-flip? move player board dir))
  82              all-directions)))
  83
  84 (defun make-move (move player board)
  85   "Update board to reflect move by player"
  86   ;; First make the move, then make any flips
  87   (setf (bref board move) player)
  88   (dolist (dir all-directions)
  89     (make-flips move player board dir))
  90   board)
  91
  92 (defun make-flips (move player board dir)
  93   "Make any flips in the given direction."
  94   (let ((bracketer (would-flip? move player board dir)))
  95     (when bracketer
  96       (loop for c from (+ move dir) by dir until (eql c bracketer)
  97             do (setf (bref board c) player)))))
  98
  99 (defun would-flip? (move player board dir)
 100   "Would this move result in any flips in this direction?
 101   If so, return the square number of the bracketing piece."
 102   ;; A flip occurs if, starting at the adjacent square, c, there
 103   ;; is a string of at least one opponent pieces, bracketed by
 104   ;; one of player's pieces
 105   (let ((c (+ move dir)))
 106     (and (eql (bref board c) (opponent player))
 107          (find-bracketing-piece (+ c dir) player board dir))))
 108
 109 (defun find-bracketing-piece (square player board dir)
 110   "Return the square number of the bracketing piece."
 111   (cond ((eql (bref board square) player) square)
 112         ((eql (bref board square) (opponent player))
 113          (find-bracketing-piece (+ square dir) player board dir))
 114         (t nil)))
 115
 116 (defun next-to-play (board previous-player print)
 117   "Compute the player to move next, or NIL if nobody can move."
 118   (let ((opp (opponent previous-player)))
 119     (cond ((any-legal-move? opp board) opp)
 120           ((any-legal-move? previous-player board)
 121            (when print
 122              (format t "~&~c has no moves and must pass."
 123                      (name-of opp)))
 124            previous-player)
 125           (t nil))))
 126
 127 (defun any-legal-move? (player board)
 128   "Does player have any legal moves in this position?"
 129   (some #'(lambda (move) (legal-p move player board))
 130         all-squares))
 131
 132 (defun random-strategy (player board)
 133   "Make any legal move."
 134   (random-elt (legal-moves player board)))
 135
 136 (defun legal-moves (player board)
 137   "Returns a list of legal moves for player"
 138   ;;*** fix, segre, 3/30/93.  Was remove-if, which can share with all-squares.
 139   (loop for move in all-squares
 140         when (legal-p move player board) collect move))
 141
 142 (defun maximize-difference (player board)
 143   "A strategy that maximizes the difference in pieces."
 144   (funcall (maximizer #'count-difference) player board))
 145
 146 (defun maximizer (eval-fn)
 147   "Return a strategy that will consider every legal move,
 148   apply EVAL-FN to each resulting board, and choose
 149   the move for which EVAL-FN returns the best score.
 150   FN takes two arguments: the player-to-move and board"
 151   #'(lambda (player board)
 152       (let* ((moves (legal-moves player board))
 153              (scores (mapcar #'(lambda (move)
 154                                  (funcall
 155                                   eval-fn
 156                                   player
 157                                   (make-move move player
 158                                              (copy-board board))))
 159                              moves))
 160              (best  (apply #'max scores)))
 161         (elt moves (position best scores)))))
 162
 163 (defparameter *weights*
 164   '#(0   0   0  0  0  0  0   0   0 0
 165      0 120 -20 20  5  5 20 -20 120 0
 166      0 -20 -40 -5 -5 -5 -5 -40 -20 0
 167      0  20  -5 15  3  3 15  -5  20 0
 168      0   5  -5  3  3  3  3  -5   5 0
 169      0   5  -5  3  3  3  3  -5   5 0
 170      0  20  -5 15  3  3 15  -5  20 0
 171      0 -20 -40 -5 -5 -5 -5 -40 -20 0
 172      0 120 -20 20  5  5 20 -20 120 0
 173      0   0   0  0  0  0  0   0   0 0))
 174
 175 (defun weighted-squares (player board)
 176   "Sum of the weights of player's squares minus opponent's."
 177   (let ((opp (opponent player)))
 178     (loop for i in all-squares
 179           when (eql (bref board i) player)
 180           sum (aref *weights* i)
 181           when (eql (bref board i) opp)
 182           sum (- (aref *weights* i)))))
 183
 184 (defconstant winning-value most-positive-fixnum)
 185 (defconstant losing-value  most-negative-fixnum)
 186
 187 (defun final-value (player board)
 188   "Is this a win, loss, or draw for player?"
 189   (case (signum (count-difference player board))
 190     (-1 losing-value)
 191     ( 0 0)
 192     (+1 winning-value)))
 193
 194 (defun minimax (player board ply eval-fn)
 195   "Find the best move, for PLAYER, according to EVAL-FN,
 196   searching PLY levels deep and backing up values."
 197   (if (= ply 0)
 198       (funcall eval-fn player board)
 199       (let ((moves (legal-moves player board)))
 200         (if (null moves)
 201             (if (any-legal-move? (opponent player) board)
 202                 (- (minimax (opponent player) board
 203                             (- ply 1) eval-fn))
 204                 (final-value player board))
 205             (let ((best-move nil)
 206                   (best-val nil))
 207               (dolist (move moves)
 208                 (let* ((board2 (make-move move player
 209                                           (copy-board board)))
 210                        (val (- (minimax
 211                                  (opponent player) board2
 212                                  (- ply 1) eval-fn))))
 213                   (when (or (null best-val)
 214                             (> val best-val))
 215                     (setf best-val val)
 216                     (setf best-move move))))
 217               (values best-val best-move))))))
 218
 219 (defun minimax-searcher (ply eval-fn)
 220   "A strategy that searches PLY levels and then uses EVAL-FN."
 221   #'(lambda (player board)
 222       (multiple-value-bind (value move)
 223           (minimax player board ply eval-fn)
 224         (declare (ignore value))
 225         move)))
 226
 227 (defun alpha-beta (player board achievable cutoff ply eval-fn)
 228   "Find the best move, for PLAYER, according to EVAL-FN,
 229   searching PLY levels deep and backing up values,
 230   using cutoffs whenever possible."
 231   (if (= ply 0)
 232       (funcall eval-fn player board)
 233       (let ((moves (legal-moves player board)))
 234         (if (null moves)
 235             (if (any-legal-move? (opponent player) board)
 236                 (- (alpha-beta (opponent player) board
 237                                (- cutoff) (- achievable)
 238                                (- ply 1) eval-fn))
 239                 (final-value player board))
 240             (let ((best-move (first moves)))
 241               (loop for move in moves do
 242                 (let* ((board2 (make-move move player
 243                                           (copy-board board)))
 244                        (val (- (alpha-beta
 245                                  (opponent player) board2
 246                                  (- cutoff) (- achievable)
 247                                  (- ply 1) eval-fn))))
 248                   (when (> val achievable)
 249                     (setf achievable val)
 250                     (setf best-move move)))
 251                 until (>= achievable cutoff))
 252               (values achievable best-move))))))
 253
 254 (defun alpha-beta-searcher (depth eval-fn)
 255   "A strategy that searches to DEPTH and then uses EVAL-FN."
 256   #'(lambda (player board)
 257       (multiple-value-bind (value move)
 258           (alpha-beta player board losing-value winning-value
 259                       depth eval-fn)
 260         (declare (ignore value))
 261         move)))
 262
 263 (defun modified-weighted-squares (player board)
 264   "Like WEIGHTED-SQUARES, but don't take off for moving
 265   near an occupied corner."
 266   (let ((w (weighted-squares player board)))
 267     (dolist (corner '(11 18 81 88))
 268       (when (not (eql (bref board corner) empty))
 269         (dolist (c (neighbors corner))
 270           (when (not (eql (bref board c) empty))
 271             (incf w (* (- 5 (aref *weights* c))
 272                        (if (eql (bref board c) player)
 273                            +1 -1)))))))
 274     w))
 275
 276 (let ((neighbor-table (make-array 100 :initial-element nil)))
 277   ;; Initialize the neighbor table
 278   (dolist (square all-squares)
 279     (dolist (dir all-directions)
 280       (if (valid-p (+ square dir))
 281           (push (+ square dir)
 282                 (aref neighbor-table square)))))
 283
 284   (defun neighbors (square)
 285     "Return a list of all squares adjacent to a square."
 286     (aref neighbor-table square)))
 287
 288 (let ((square-names
 289         (cross-product #'concat-symbol
 290                        '(? a b c d e f g h ?)
 291                        '(? 1 2 3 4 5 6 7 8 ?))))
 292
 293   (defun h8->88 (str)
 294     "Convert from alphanumeric to numeric square notation."
 295     (or (position (string str) square-names :test #'string-equal)
 296         str))
 297
 298   (defun 88->h8 (num)
 299     "Convert from numeric to alphanumeric square notation."
 300     (if (valid-p num)
 301         (elt square-names num)
 302         num)))
 303
 304 (defun human (player board)
 305   "A human player for the game of Othello"
 306   (format t "~&~c to move ~a: " (name-of player)
 307           (mapcar #'88->h8 (legal-moves player board)))
 308   (h8->88 (read)))
 309
 310 (defvar *move-number* 1 "The number of the move to be played")
 311
 312 (defun othello (bl-strategy wh-strategy
 313                 &optional (print t) (minutes 30))
 314   "Play a game of othello.  Return the score, where a positive
 315   difference means black, the first player, wins."
 316   (let ((board (initial-board))
 317         (clock (make-array (+ 1 (max black white))
 318                            :initial-element
 319                            (* minutes 60
 320                               internal-time-units-per-second))))
 321     (catch 'game-over
 322       (loop for *move-number* from 1
 323             for player = black then (next-to-play board player print)
 324             for strategy = (if (eql player black)
 325                                bl-strategy
 326                                wh-strategy)
 327             until (null player)
 328             do (get-move strategy player board print clock))
 329       (when print
 330         (format t "~&The game is over.  Final result:")
 331         (print-board board clock))
 332       (count-difference black board))))
 333
 334 (defvar *clock* (make-array 3) "A copy of the game clock")
 335 (defvar *board* (initial-board) "A copy of the game board")
 336
 337 (defun get-move (strategy player board print clock)
 338   "Call the player's strategy function to get a move.
 339   Keep calling until a legal move is made."
 340   ;; Note we don't pass the strategy function the REAL board.
 341   ;; If we did, it could cheat by changing the pieces on the board.
 342   (when print (print-board board clock))
 343   (replace *clock* clock)
 344   (let* ((t0 (get-internal-real-time))
 345          (move (funcall strategy player (replace *board* board)))
 346          (t1 (get-internal-real-time)))
 347     (decf (elt clock player) (- t1 t0))
 348     (cond
 349       ((< (elt clock player) 0)
 350        (format t "~&~c has no time left and forfeits."
 351                (name-of player))
 352        (THROW 'game-over (if (eql player black) -64 64)))
 353       ((eq move 'resign)
 354        (THROW 'game-over (if (eql player black) -64 64)))
 355       ((and (valid-p move) (legal-p move player board))
 356        (when print
 357          (format t "~&~c moves to ~a."
 358                  (name-of player) (88->h8 move)))
 359        (make-move move player board))
 360       (t (warn "Illegal move: ~a" (88->h8 move))
 361          (get-move strategy player board print clock)))))
 362
 363 (defun print-board (&optional (board *board*) clock)
 364   "Print a board, along with some statistics."
 365   ;; First print the header and the current score
 366   (format t "~2&    a b c d e f g h   [~c=~2a ~c=~2a (~@d)]"
 367           (name-of black) (count black board)
 368           (name-of white) (count white board)
 369           (count-difference black board))
 370   ;; Print the board itself
 371   (loop for row from 1 to 8 do
 372         (format t "~&  ~d " row)
 373         (loop for col from 1 to 8
 374               for piece = (bref board (+ col (* 10 row)))
 375               do (format t "~c " (name-of piece))))
 376   ;; Finally print the time remaining for each player
 377   (when clock
 378     (format t "  [~c=~a ~c=~a]~2&"
 379             (name-of black) (time-string (elt clock black))
 380             (name-of white) (time-string (elt clock white)))))
 381
 382 (defun time-string (time)
 383   "Return a string representing this internal time in min:secs."
 384   (multiple-value-bind (min sec)
 385       (floor (round time internal-time-units-per-second) 60)
 386     (format nil "~2d:~2,'0d" min sec)))
 387
 388 (defun random-othello-series (strategy1 strategy2
 389                               n-pairs &optional (n-random 10))
 390   "Play a series of 2*n games, starting from a random position."
 391   (othello-series
 392     (switch-strategies #'random-strategy n-random strategy1)
 393     (switch-strategies #'random-strategy n-random strategy2)
 394     n-pairs))
 395
 396 (defun switch-strategies (strategy1 m strategy2)
 397   "Make a new strategy that plays strategy1 for m moves,
 398   then plays according to strategy2."
 399   #'(lambda (player board)
 400       (funcall (if (<= *move-number* m) strategy1 strategy2)
 401                player board)))
 402
 403 (defun othello-series (strategy1 strategy2 n-pairs)
 404   "Play a series of 2*n-pairs games, swapping sides."
 405   (let ((scores
 406           (loop repeat n-pairs
 407              for random-state = (make-random-state)
 408              collect (othello strategy1 strategy2 nil)
 409              do (setf *random-state* random-state)
 410              collect (- (othello strategy2 strategy1 nil)))))
 411     ;; Return the number of wins (1/2 for a tie),
 412     ;; the total of the point differences, and the
 413     ;; scores themselves, all from strategy1's point of view.
 414     (values (+ (count-if #'plusp scores)
 415                (/ (count-if #'zerop scores) 2))
 416             (apply #'+ scores)
 417             scores)))
 418
 419 (defun round-robin (strategies n-pairs &optional
 420                     (n-random 10) (names strategies))
 421   "Play a tournament among the strategies.
 422   N-PAIRS = games each strategy plays as each color against
 423   each opponent.  So with N strategies, a total of
 424   N*(N-1)*N-PAIRS games are played."
 425   (let* ((N (length strategies))
 426          (totals (make-array N :initial-element 0))
 427          (scores (make-array (list N N)
 428                              :initial-element 0)))
 429     ;; Play the games
 430     (dotimes (i N)
 431       (loop for j from (+ i 1) to (- N 1) do
 432           (let* ((wins (random-othello-series
 433                          (elt strategies i)
 434                          (elt strategies j)
 435                          n-pairs n-random))
 436                  (losses (- (* 2 n-pairs) wins)))
 437             (incf (aref scores i j) wins)
 438             (incf (aref scores j i) losses)
 439             (incf (aref totals i) wins)
 440             (incf (aref totals j) losses))))
 441     ;; Print the results
 442     (dotimes (i N)
 443       (format t "~&~a~20T ~4f: " (elt names i) (elt totals i))
 444       (dotimes (j N)
 445         (format t "~4f " (if (= i j) '---
 446                              (aref scores i j)))))))
 447
 448 (defun mobility (player board)
 449   "The number of moves a player has."
 450   (length (legal-moves player board)))
 451