strategies.lisp

   1 ;;;;***************************************************************************
   2 ;;;;
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;;  Name:           strategies.cl
   6 ;;;;  Purpose:        Strategy routines for reversi
   7 ;;;;  Programer:      Kevin M. Rosenberg, M.D.
   8 ;;;;  Date Started:   1 Nov 2001
   9 ;;;;  CVS Id:         $Id: strategies.lisp,v 1.1 2002/10/25 08:36:42 kevin Exp $
  10 ;;;;
  11 ;;;;***************************************************************************
  12
  13 (in-package :reversi)
  14 (declaim (optimize (safety 1) (debug 3) (speed 3) (compilation-speed 0)))
  15
  16
  17 (defun random-strategy (player board)
  18   "Make any legal move."
  19   (declare (type player player)
  20            (type board board))
  21   (random-elt (legal-moves player board)))
  22
  23
  24 (defun maximize-difference (player board)
  25   "A strategy that maximizes the difference in pieces."
  26   (declare (type player player)
  27            (type board board))
  28   (funcall (maximizer #'count-difference) player board))
  29
  30 (defun maximizer (eval-fn)
  31   "Return a strategy that will consider every legal move,
  32   apply EVAL-FN to each resulting board, and choose
  33   the move for which EVAL-FN returns the best score.
  34   FN takes two arguments: the player-to-move and board"
  35   #'(lambda (player board)
  36       (declare (type player player)
  37                (type board board))
  38       (let* ((moves (legal-moves player board))
  39              (scores (mapcar #'(lambda (move)
  40                                  (funcall
  41                                   eval-fn
  42                                   player
  43                                   (make-move move player
  44                                              (copy-board board))))
  45                              moves))
  46              (best  (apply #'max scores)))
  47         (declare (fixnum moves best))
  48         (elt moves (position best scores)))))
  49
  50 (eval-when (:compile-toplevel :load-toplevel :execute)
  51   (defparameter *weights*
  52       (make-array 100 :element-type 'fixnum
  53                   :fill-pointer nil :adjustable nil
  54                   :initial-contents
  55                   '(0   0   0  0  0  0  0   0  0 0
  56                     0 120 -20 20  5  5 20 -20 120 0
  57                     0 -20 -40 -5 -5 -5 -5 -40 -20 0
  58                     0  20  -5 15  3  3 15  -5  20 0
  59                     0   5  -5  3  3  3  3  -5   5 0
  60                     0   5  -5  3  3  3  3  -5   5 0
  61                     0  20  -5 15  3  3 15  -5  20 0
  62                     0 -20 -40 -5 -5 -5 -5 -40 -20 0
  63                     0 120 -20 20  5  5 20 -20 120 0
  64                     0   0   0  0  0  0  0   0   0 0)))
  65   (declaim (type (simple-array fixnum (100)) *weights*))
  66 )
  67
  68 (eval-when (:compile-toplevel :load-toplevel :execute)
  69   (setq all-squares
  70     (sort (loop for i from 11 to 88
  71               when (<= 1 (mod i 10) 8) collect i)
  72           #'> :key #'(lambda (sq) (elt *weights* sq)))))
  73
  74
  75 (defun weighted-squares (player board)
  76   "Sum of the weights of player's squares minus opponent's."
  77   (declare (type player player)
  78            (type board board))
  79   (let ((opp (opponent player)))
  80     (loop for i in all-squares
  81           when (= (bref board i) player)
  82           sum (aref *weights* i)
  83           when (= (bref board i) opp)
  84           sum (- (aref *weights* i)))))
  85
  86 (defconstant winning-value (- most-positive-fixnum 70))
  87 (defconstant losing-value  (+ most-negative-fixnum 70))
  88
  89 (defun final-value (player board)
  90   "Is this a win, loss, or draw for player?"
  91   (declare (type player player)
  92            (type board board))
  93   (case (signum (count-difference player board))
  94     (-1 losing-value)
  95     ( 0 0)
  96     (+1 winning-value)))
  97
  98 (defun final-value-weighted (player board)
  99   "Is this a win, loss, or draw for player?"
 100   (declare (type player player)
 101            (type board board))
 102   (let ((diff (count-difference player board)))
 103     (case (signum diff)
 104       (-1 (+ losing-value diff))
 105       ( 0 0)
 106       (+1 (+ winning-value diff)))))
 107
 108 (defun minimax (player board ply eval-fn)
 109   "Find the best move, for PLAYER, according to EVAL-FN,
 110   searching PLY levels deep and backing up values."
 111   (declare (type player player)
 112            (type board board)
 113            (fixnum ply))
 114   (if (= ply 0)
 115       (funcall eval-fn player board)
 116       (let ((moves (legal-moves player board)))
 117         (if (null moves)
 118             (if (any-legal-move? (opponent player) board)
 119                 (- (minimax (opponent player) board
 120                             (- ply 1) eval-fn))
 121                 (final-value player board))
 122             (let ((best-move nil)
 123                   (best-val nil))
 124               (dolist (move moves)
 125                 (let* ((board2 (make-move move player
 126                                           (copy-board board)))
 127                        (val (- (minimax
 128                                  (opponent player) board2
 129                                  (- ply 1) eval-fn))))
 130                   (when (or (null best-val)
 131                             (> val best-val))
 132                     (setf best-val val)
 133                     (setf best-move move))))
 134               (values best-val best-move))))))
 135
 136 (defun minimax-searcher (ply eval-fn)
 137   "A strategy that searches PLY levels and then uses EVAL-FN."
 138   #'(lambda (player board)
 139       (declare (type player player)
 140                (type board board))
 141       (multiple-value-bind (value move)
 142           (minimax player board ply eval-fn)
 143         (declare (ignore value))
 144         move)))
 145
 146 (defun alpha-beta (player board achievable cutoff ply eval-fn)
 147   "Find the best move, for PLAYER, according to EVAL-FN,
 148   searching PLY levels deep and backing up values,
 149   using cutoffs whenever possible."
 150   (declare (type player player)
 151            (type board board)
 152            (fixnum achievable cutoff ply))
 153   (if (= ply 0)
 154       (funcall eval-fn player board)
 155       (let ((moves (legal-moves player board)))
 156         (if (null moves)
 157             (if (any-legal-move? (opponent player) board)
 158                 (- (alpha-beta (opponent player) board
 159                                (- cutoff) (- achievable)
 160                                (- ply 1) eval-fn))
 161                 (final-value player board))
 162           (let ((best-move (first moves)))
 163             (declare (type move best-move))
 164             (loop for move in moves do
 165                   (let* ((board2 (make-move move player
 166                                             (copy-board board)))
 167                          (val (- (alpha-beta
 168                                  (opponent player) board2
 169                                  (- cutoff) (- achievable)
 170                                  (- ply 1) eval-fn))))
 171                   (when (> val achievable)
 172                     (setf achievable val)
 173                     (setf best-move move)))
 174                 until (>= achievable cutoff))
 175               (values achievable best-move))))))
 176
 177 (defun alpha-beta-searcher (depth eval-fn)
 178   "A strategy that searches to DEPTH and then uses EVAL-FN."
 179   (declare (fixnum depth))
 180   #'(lambda (player board)
 181       (declare (type board board)
 182                (type player player))
 183       (multiple-value-bind (value move)
 184           (alpha-beta player board losing-value winning-value
 185                       depth eval-fn)
 186         (declare (ignore value))
 187         move)))
 188
 189 (defun modified-weighted-squares (player board)
 190   "Like WEIGHTED-SQUARES, but don't take off for moving
 191   near an occupied corner."
 192   (declare (type player player)
 193            (type board board))
 194   (let ((w (weighted-squares player board)))
 195     (declare (fixnum w))
 196     (dolist (corner '(11 18 81 88))
 197       (declare (type square corner))
 198       (when (not (= (bref board corner) empty))
 199         (dolist (c (neighbors corner))
 200           (declare (type square c))
 201           (when (not (= (bref board c) empty))
 202             (incf w (* (- 5 (aref *weights* c))
 203                        (if (= (bref board c) player)
 204                            +1 -1)))))))
 205     w))
 206
 207 (eval-when (:compile-toplevel :load-toplevel :execute)
 208 (let ((neighbor-table (make-array 100 :initial-element nil)))
 209   ;; Initialize the neighbor table
 210   (dolist (square all-squares)
 211     (declare (type square square))
 212     (dolist (dir +all-directions+)
 213       (declare (type dir dir))
 214       (if (valid-p (+ square dir))
 215           (push (+ square dir)
 216                 (aref neighbor-table square)))))
 217
 218   (defun neighbors (square)
 219     "Return a list of all squares adjacent to a square."
 220     (aref neighbor-table square))))
 221
 222
 223 (defun mobility-simple (player board)
 224   "The number of moves a player has."
 225   (length (legal-moves player board)))
 226
 227
 228
 229 (defstruct (node)
 230   (square nil :type square)
 231   (board nil :type board)
 232   (value nil :type integer))
 233
 234 (defun alpha-beta-searcher2 (depth eval-fn)
 235   "Return a strategy that does A-B search with sorted moves."
 236   #'(lambda (player board)
 237       (declare (type player player)
 238                (type board board))
 239       (multiple-value-bind (value node)
 240           (alpha-beta2
 241             player (make-node :board board
 242                               :value (funcall eval-fn player board))
 243             losing-value winning-value depth eval-fn)
 244         (declare (ignore value))
 245         (node-square node))))
 246
 247 (defun alpha-beta2 (player node achievable cutoff ply eval-fn)
 248   "A-B search, sorting moves by eval-fn"
 249   ;; Returns two values: achievable-value and move-to-make
 250   (if (= ply 0)
 251       (values (node-value node) node)
 252       (let* ((board (node-board node))
 253              (nodes (legal-nodes player board eval-fn)))
 254         (if (null nodes)
 255             (if (any-legal-move? (opponent player) board)
 256                 (values (- (alpha-beta2 (opponent player)
 257                                         (negate-value node)
 258                                         (- cutoff) (- achievable)
 259                                         (- ply 1) eval-fn))
 260                         nil)
 261                 (values (final-value player board) nil))
 262           (let ((best-node (first nodes)))
 263               (loop for move in nodes
 264                     for val = (- (alpha-beta2
 265                                    (opponent player)
 266                                    (negate-value move)
 267                                    (- cutoff) (- achievable)
 268                                    (- ply 1) eval-fn))
 269                     do (when (> val achievable)
 270                          (setf achievable val)
 271                          (setf best-node move))
 272                     until (>= achievable cutoff))
 273               (values achievable best-node))))))
 274
 275 (defun negate-value (node)
 276   "Set the value of a node to its negative."
 277   (setf (node-value node) (- (node-value node)))
 278   node)
 279
 280 (defun legal-nodes (player board eval-fn)
 281   "Return a list of legal moves, each one packed into a node."
 282   (let ((moves (legal-moves player board)))
 283     (sort (map-into
 284             moves
 285             #'(lambda (move)
 286                 (let ((new-board (make-move move player
 287                                             (copy-board board))))
 288                   (make-node
 289                     :square move :board new-board
 290                     :value (funcall eval-fn player new-board))))
 291             moves)
 292           #'> :key #'node-value)))
 293
 294 (defun alpha-beta3 (player board achievable cutoff ply eval-fn
 295                     killer)
 296   (declare (type board board)
 297            (type player player)
 298            (type fixnum achievable cutoff ply))
 299   "A-B search, putting killer move first."
 300   (if (= ply 0)
 301       (funcall eval-fn player board)
 302       (let ((moves (put-first killer (legal-moves player board))))
 303         (if (null moves)
 304             (if (any-legal-move? (opponent player) board)
 305                 (- (alpha-beta3 (opponent player) board
 306                                 (- cutoff) (- achievable)
 307                                 (- ply 1) eval-fn nil))
 308                 (final-value player board))
 309             (let ((best-move (first moves))
 310                   (new-board (svref *ply-boards* ply))
 311                   (killer2 nil)
 312                   (killer2-val winning-value))
 313               (declare (type move best-move)
 314                        (type board new-board)
 315                        (type fixnum killer2-val))
 316               (loop for move in moves
 317                   do (multiple-value-bind (val reply)
 318                        (alpha-beta3
 319                         (opponent player)
 320                         (make-move move player
 321                                    (replace-board new-board board))
 322                         (- cutoff) (- achievable)
 323                         (- ply 1) eval-fn killer2)
 324                        (setf val (- val))
 325                        (when (> val achievable)
 326                          (setq achievable val)
 327                          (setq best-move move))
 328                        (when (and reply (< val killer2-val))
 329                          (setq killer2 reply)
 330                          (setq killer2-val val)))
 331                   until (>= achievable cutoff))
 332               (values achievable best-move))))))
 333
 334 (defun alpha-beta3w (player board achievable cutoff ply eval-fn
 335                     killer)
 336   (declare (type board board)
 337            (type player player)
 338            (type fixnum achievable cutoff ply)
 339            (type move killer))
 340   "A-B search, putting killer move first."
 341   (if (= ply 0)
 342       (funcall eval-fn player board)
 343       (let ((moves (put-first killer (legal-moves player board))))
 344         (if (null moves)
 345             (if (any-legal-move? (opponent player) board)
 346                 (- (alpha-beta3 (opponent player) board
 347                                 (- cutoff) (- achievable)
 348                                 (- ply 1) eval-fn nil))
 349                 (final-value-weighted player board))
 350             (let ((best-move (first moves))
 351                   (new-board (svref *ply-boards* ply))
 352                   (killer2 nil)
 353                   (killer2-val winning-value))
 354               (declare (type move best-move)
 355                        (type board new-board)
 356                        (type fixnum killer2-val))
 357               (loop for move in moves
 358                   do (multiple-value-bind (val reply)
 359                        (alpha-beta3
 360                         (opponent player)
 361                         (make-move move player
 362                                    (replace-board new-board board))
 363                         (- cutoff) (- achievable)
 364                         (- ply 1) eval-fn killer2)
 365                        (setf val (- val))
 366                        (when (> val achievable)
 367                          (setq achievable val)
 368                          (setq best-move move))
 369                        (when (and reply (< val killer2-val))
 370                          (setq killer2 reply)
 371                          (setq killer2-val val)))
 372                   until (>= achievable cutoff))
 373               (values achievable best-move))))))
 374
 375
 376 (defun alpha-beta-searcher3 (depth eval-fn)
 377   "Return a strategy that does A-B search with killer moves."
 378   #'(lambda (player board)
 379       (declare (type board board)
 380                (type player player))
 381       (multiple-value-bind (value move)
 382           (alpha-beta3 player board losing-value winning-value
 383                        depth eval-fn nil)
 384         (declare (ignore value))
 385         move)))
 386
 387 (defun alpha-beta-searcher3w (depth eval-fn)
 388   "Return a strategy that does A-B search with killer moves."
 389   #'(lambda (player board)
 390       (multiple-value-bind (value move)
 391           (alpha-beta3w player board losing-value winning-value
 392                        depth eval-fn nil)
 393         (declare (ignore value))
 394         move)))
 395
 396 (defun put-first (killer moves)
 397   "Move the killer move to the front of moves,
 398   if the killer move is in fact a legal move."
 399   (if (member killer moves)
 400       (cons killer (delete killer moves))
 401       moves))
 402
 403 (defun mobility (player board)
 404   "Current Mobility is the number of legal moves.
 405   Potential mobility is the number of blank squares
 406   adjacent to an opponent that are not legal moves.
 407   Returns current and potential mobility for player."
 408   (declare (type board board)
 409            (type player player)
 410            (optimize (speed 3) (safety 0 )))
 411   (let ((opp (opponent player))
 412         (current 0)    ; player's current mobility
 413         (potential 0))                  ; player's potential mobility
 414     (declare (type player opp)
 415              (type fixnum current potential))
 416     (dolist (square all-squares)
 417       (declare (type square square))
 418       (when (= (bref board square) empty)
 419         (cond ((legal-p square player board)
 420                (incf current))
 421               ((some-neighbors board opp (neighbors square))
 422                (incf potential))
 423               )))
 424     (values current (the fixnum (+ current potential)))))
 425
 426
 427 (defun some-neighbors (board opp neighbors)
 428   (declare (type board board)
 429            (type player opp)
 430            (type cons neighbors)
 431            (optimize (speed 3) (safety 0)))
 432   (block search
 433     (dolist (sq neighbors)
 434       (declare (type square sq))
 435       (when (= (bref board sq) opp)
 436         (return-from search t)))
 437     (return-from search nil)))
 438
 439 (defun edge-stability (player board)
 440   "Total edge evaluation for player to move on board."
 441   (declare (type board board)
 442            (type player player))
 443   (loop for edge-list in *edge-and-x-lists*
 444         sum (aref *edge-table*
 445                   (edge-index player board edge-list))))
 446
 447 (defun iago-eval (player board)
 448   "Combine edge-stability, current mobility and
 449   potential mobility to arrive at an evaluation."
 450   ;; The three factors are multiplied by coefficients
 451   ;; that vary by move number:
 452   (declare (type board board)
 453            (type player player))
 454   (let ((c-edg  (+ 312000 (* 6240 *move-number*)))
 455         (c-cur (if (< *move-number* 25)
 456                    (+ 50000 (* 2000 *move-number*))
 457                  (+ 75000 (* 1000 *move-number*))))
 458         (c-pot 20000))
 459     (declare (fixnum c-edg c-cur c-pot))
 460     (multiple-value-bind (p-cur p-pot)
 461         (mobility player board)
 462       (multiple-value-bind (o-cur o-pot)
 463           (mobility (opponent player) board)
 464         ;; Combine the three factors into one sum:
 465         (+ (round (* c-edg (edge-stability player board))
 466                   32000)
 467            (round (* c-cur (- p-cur o-cur))
 468                   (+ p-cur o-cur 2))
 469            (round (* c-pot (- p-pot o-pot))
 470                   (+ p-pot o-pot 2)))))))
 471
 472
 473 ;; Strategy Functions
 474
 475 (defun iago (depth)
 476   "Use an approximation of Iago's evaluation function."
 477   (alpha-beta-searcher3 depth #'iago-eval))
 478
 479 ;; Maximizer (1-ply)
 480 (defun mx-df ()
 481   (maximizer #'count-difference))
 482
 483 (defun mx-wt ()
 484   (maximizer #'weighted-squares))
 485
 486 (defun mx-md-wt ()
 487   (maximizer #'modified-weighted-squares))
 488
 489 ;; Minimax-searcher
 490
 491 (defun mm-df (ply)
 492   (minimax-searcher ply #'count-difference))
 493
 494 (defun mm-wt (ply)
 495   (minimax-searcher ply #'weighted-squares))
 496
 497 (defun mm-md-wt (ply)
 498   (minimax-searcher ply #'modified-weighted-squares))
 499
 500 ;; Alpha-beta3 searcher
 501 (defun ab3-df (ply)
 502   (alpha-beta-searcher3 ply #'count-difference))
 503
 504 (defun ab3-wt (ply)
 505   (alpha-beta-searcher3 ply #'weighted-squares))
 506
 507 (defun ab3-md-wt (ply)
 508   (alpha-beta-searcher3 ply #'modified-weighted-squares))
 509
 510
 511 (defun ab3w-df (ply)
 512   (alpha-beta-searcher3w ply #'count-difference))
 513
 514 (defun ab3w-wt (ply)
 515   (alpha-beta-searcher3w ply #'weighted-squares))
 516
 517 (defun ab3w-md-wt (ply)
 518   (alpha-beta-searcher3w ply #'modified-weighted-squares))
 519
 520
 521 (defun rr (ply n-pairs)
 522   (round-robin
 523    (list #'random-strategy (ab3-df ply) (ab3-wt ply) (ab3-md-wt ply) (iago 3))
 524    n-pairs
 525    10
 526    '(random ab3-df ab3-wt ab3-md-wt iago)))
 527
 528
 529
 530
 531