original/othello2-orig.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: Common-Lisp -*-
   2 ;;;; Code from Paradigms of AI Programming
   3 ;;;; Copyright (c) 1991 Peter Norvig
   4
   5 ;;;; File othello2.lisp:  More strategies for othello.lisp,
   6 ;;;; from section 18.9 onward (alpha-beta2, alpha-beta3, iago).
   7 ;;;; If a compiled version of edge-table.lisp exists, then merely
   8 ;;;; load it after you load this file.  Otherwise, load this file,
   9 ;;;; evaluate (init-edge-table) (this will take a really long time),
  10 ;;;; then compile edge-table.lisp.  This will save the edge-table for
  11 ;;;; future use.
  12
  13 ;(requires "othello")
  14
  15 (defconstant all-squares
  16   (sort (loop for i from 11 to 88
  17               when (<= 1 (mod i 10) 8) collect i)
  18         #'> :key #'(lambda (sq) (elt *weights* sq))))
  19
  20 (defstruct (node) square board value)
  21
  22 (defun alpha-beta-searcher2 (depth eval-fn)
  23   "Return a strategy that does A-B search with sorted moves."
  24   #'(lambda (player board)
  25       (multiple-value-bind (value node)
  26           (alpha-beta2
  27             player (make-node :board board
  28                               :value (funcall eval-fn player board))
  29             losing-value winning-value depth eval-fn)
  30         (declare (ignore value))
  31         (node-square node))))
  32
  33 (defun alpha-beta2 (player node achievable cutoff ply eval-fn)
  34   "A-B search, sorting moves by eval-fn"
  35   ;; Returns two values: achievable-value and move-to-make
  36   (if (= ply 0)
  37       (values (node-value node) node)
  38       (let* ((board (node-board node))
  39              (nodes (legal-nodes player board eval-fn)))
  40         (if (null nodes)
  41             (if (any-legal-move? (opponent player) board)
  42                 (values (- (alpha-beta2 (opponent player)
  43                                         (negate-value node)
  44                                         (- cutoff) (- achievable)
  45                                         (- ply 1) eval-fn))
  46                         nil)
  47                 (values (final-value player board) nil))
  48             (let ((best-node (first nodes)))
  49               (loop for move in nodes
  50                     for val = (- (alpha-beta2
  51                                    (opponent player)
  52                                    (negate-value move)
  53                                    (- cutoff) (- achievable)
  54                                    (- ply 1) eval-fn))
  55                     do (when (> val achievable)
  56                          (setf achievable val)
  57                          (setf best-node move))
  58                     until (>= achievable cutoff))
  59               (values achievable best-node))))))
  60
  61 (defun negate-value (node)
  62   "Set the value of a node to its negative."
  63   (setf (node-value node) (- (node-value node)))
  64   node)
  65
  66 (defun legal-nodes (player board eval-fn)
  67   "Return a list of legal moves, each one packed into a node."
  68   (let ((moves (legal-moves player board)))
  69     (sort (map-into
  70             moves
  71             #'(lambda (move)
  72                 (let ((new-board (make-move move player
  73                                             (copy-board board))))
  74                   (make-node
  75                     :square move :board new-board
  76                     :value (funcall eval-fn player new-board))))
  77             moves)
  78           #'> :key #'node-value)))
  79
  80 (defvar *ply-boards*
  81   (apply #'vector (loop repeat 40 collect (initial-board))))
  82
  83 (defun alpha-beta3 (player board achievable cutoff ply eval-fn
  84                     killer)
  85   "A-B search, putting killer move first."
  86   (if (= ply 0)
  87       (funcall eval-fn player board)
  88       (let ((moves (put-first killer (legal-moves player board))))
  89         (if (null moves)
  90             (if (any-legal-move? (opponent player) board)
  91                 (- (alpha-beta3 (opponent player) board
  92                                 (- cutoff) (- achievable)
  93                                 (- ply 1) eval-fn nil))
  94                 (final-value player board))
  95             (let ((best-move (first moves))
  96                   (new-board (aref *ply-boards* ply))
  97                   (killer2 nil)
  98                   (killer2-val winning-value))
  99               (loop for move in moves
 100                     do (multiple-value-bind (val reply)
 101                            (alpha-beta3
 102                              (opponent player)
 103                              (make-move move player
 104                                         (replace new-board board))
 105                              (- cutoff) (- achievable)
 106                              (- ply 1) eval-fn killer2)
 107                          (setf val (- val))
 108                          (when (> val achievable)
 109                            (setf achievable val)
 110                            (setf best-move move))
 111                          (when (and reply (< val killer2-val))
 112                            (setf killer2 reply)
 113                            (setf killer2-val val)))
 114                     until (>= achievable cutoff))
 115               (values achievable best-move))))))
 116
 117 (defun alpha-beta-searcher3 (depth eval-fn)
 118   "Return a strategy that does A-B search with killer moves."
 119   #'(lambda (player board)
 120       (multiple-value-bind (value move)
 121           (alpha-beta3 player board losing-value winning-value
 122                        depth eval-fn nil)
 123         (declare (ignore value))
 124         move)))
 125
 126 (defun put-first (killer moves)
 127   "Move the killer move to the front of moves,
 128   if the killer move is in fact a legal move."
 129   (if (member killer moves)
 130       (cons killer (delete killer moves))
 131       moves))
 132
 133 (defun mobility (player board)
 134   "Current Mobility is the number of legal moves.
 135   Potential mobility is the number of blank squares
 136   adjacent to an opponent that are not legal moves.
 137   Returns current and potential mobility for player."
 138   (let ((opp (opponent player))
 139         (current 0)    ; player's current mobility
 140         (potential 0)) ; player's potential mobility
 141     (dolist (square all-squares)
 142       (when (eql (bref board square) empty)
 143         (cond ((legal-p square player board)
 144                (incf current))
 145               ((some #'(lambda (sq) (eql (bref board sq) opp))
 146                      (neighbors square))
 147                (incf potential)))))
 148     (values current (+ current potential))))
 149
 150 (defvar *edge-table* (make-array (expt 3 10))
 151   "Array of values to player-to-move for edge positions.")
 152
 153 (defconstant edge-and-x-lists
 154   '((22 11 12 13 14 15 16 17 18 27)
 155     (72 81 82 83 84 85 86 87 88 77)
 156     (22 11 21 31 41 51 61 71 81 72)
 157     (27 18 28 38 48 58 68 78 88 77))
 158   "The four edges (with their X-squares).")
 159
 160 (defun edge-index (player board squares)
 161   "The index counts 1 for player; 2 for opponent,
 162   on each square---summed as a base 3 number."
 163   (let ((index 0))
 164     (dolist (sq squares)
 165       (setq index (+ (* index 3)
 166                      (cond ((eql (bref board sq) empty) 0)
 167                            ((eql (bref board sq) player) 1)
 168                            (t 2)))))
 169     index))
 170
 171 (defun edge-stability (player board)
 172   "Total edge evaluation for player to move on board."
 173   (loop for edge-list in edge-and-x-lists
 174         sum (aref *edge-table*
 175                   (edge-index player board edge-list))))
 176
 177 (defconstant top-edge (first edge-and-x-lists))
 178
 179 (defun init-edge-table ()
 180   "Initialize *edge-table*, starting from the empty board."
 181   ;; Initialize the static values
 182   (loop for n-pieces from 0 to 10 do
 183         (map-edge-n-pieces
 184           #'(lambda (board index)
 185               (setf (aref *edge-table* index)
 186                     (static-edge-stability black board)))
 187           black (initial-board) n-pieces top-edge 0))
 188   ;; Now iterate five times trying to improve:
 189   (dotimes (i 5)
 190     ;; Do the indexes with most pieces first
 191     (loop for n-pieces from 9 downto 1 do
 192           (map-edge-n-pieces
 193             #'(lambda (board index)
 194                 (setf (aref *edge-table* index)
 195                       (possible-edge-moves-value
 196                         black board index)))
 197             black (initial-board) n-pieces top-edge 0))))
 198
 199 (defun map-edge-n-pieces (fn player board n squares index)
 200   "Call fn on all edges with n pieces."
 201   ;; Index counts 1 for player; 2 for opponent
 202   (cond
 203     ((< (length squares) n) nil)
 204     ((null squares) (funcall fn board index))
 205     (t (let ((index3 (* 3 index))
 206              (sq (first squares)))
 207          (map-edge-n-pieces fn player board n (rest squares) index3)
 208          (when (and (> n 0) (eql (bref board sq) empty))
 209            (setf (bref board sq) player)
 210            (map-edge-n-pieces fn player board (- n 1) (rest squares)
 211                               (+ 1 index3))
 212            (setf (bref board sq) (opponent player))
 213            (map-edge-n-pieces fn player board (- n 1) (rest squares)
 214                               (+ 2 index3))
 215            (setf (bref board sq) empty))))))
 216
 217 (defun possible-edge-moves-value (player board index)
 218   "Consider all possible edge moves.
 219   Combine their values into a single number."
 220   (combine-edge-moves
 221     (cons
 222       (list 1.0 (aref *edge-table* index)) ;; no move
 223       (loop for sq in top-edge             ;; possible moves
 224             when (eql (bref board sq) empty)
 225             collect (possible-edge-move player board sq)))
 226     player))
 227
 228 (defun possible-edge-move (player board sq)
 229   "Return a (prob val) pair for a possible edge move."
 230   (let ((new-board (replace (aref *ply-boards* player) board)))
 231     (make-move sq player new-board)
 232     (list (edge-move-probability player board sq)
 233           (- (aref *edge-table*
 234                    (edge-index (opponent player)
 235                                new-board top-edge))))))
 236
 237 (defun combine-edge-moves (possibilities player)
 238   "Combine the best moves."
 239   (let ((prob 1.0)
 240         (val 0.0)
 241         (fn (if (eql player black) #'> #'<)))
 242     (loop for pair in (sort possibilities fn :key #'second)
 243           while (>= prob 0.0)
 244           do (incf val (* prob (first pair) (second pair)))
 245              (decf prob (* prob (first pair))))
 246     (round val)))
 247
 248 (let ((corner/xsqs '((11 . 22) (18 . 27) (81. 72) (88 . 77))))
 249   (defun corner-p (sq) (assoc sq corner/xsqs))
 250   (defun x-square-p (sq) (rassoc sq corner/xsqs))
 251   (defun x-square-for (corner) (cdr (assoc corner corner/xsqs)))
 252   (defun corner-for (xsq) (car (rassoc xsq corner/xsqs))))
 253
 254 (defun edge-move-probability (player board square)
 255   "What's the probability that player can move to this square?"
 256   (cond
 257     ((x-square-p square) .5) ;; X-squares
 258     ((legal-p square player board) 1.0) ;; immediate capture
 259     ((corner-p square) ;; move to corner depends on X-square
 260      (let ((x-sq (x-square-for square)))
 261        (cond
 262          ((eql (bref board x-sq) empty) .1)
 263          ((eql (bref board x-sq) player) 0.001)
 264          (t .9))))
 265     (t (/ (aref
 266             '#2A((.1  .4 .7)
 267                  (.05 .3  *)
 268                  (.01  *  *))
 269             (count-edge-neighbors player board square)
 270             (count-edge-neighbors (opponent player) board square))
 271           (if (legal-p square (opponent player) board) 2 1)))))
 272
 273 (defun count-edge-neighbors (player board square)
 274   "Count the neighbors of this square occupied by player."
 275   (count-if #'(lambda (inc)
 276                 (eql (bref board (+ square inc)) player))
 277             '(+1 -1)))
 278
 279 (defparameter *static-edge-table*
 280   '#2A(;stab  semi    un
 281        (   *    0 -2000) ; X
 282        ( 700    *     *) ; corner
 283        (1200  200   -25) ; C
 284        (1000  200    75) ; A
 285        (1000  200    50) ; B
 286        (1000  200    50) ; B
 287        (1000  200    75) ; A
 288        (1200  200   -25) ; C
 289        ( 700    *     *) ; corner
 290        (   *    0 -2000) ; X
 291        ))
 292
 293 (defun static-edge-stability (player board)
 294   "Compute this edge's static stability"
 295   (loop for sq in top-edge
 296         for i from 0
 297         sum (cond
 298               ((eql (bref board sq) empty) 0)
 299               ((eql (bref board sq) player)
 300                (aref *static-edge-table* i
 301                      (piece-stability board sq)))
 302               (t (- (aref *static-edge-table* i
 303                           (piece-stability board sq)))))))
 304
 305 (let ((stable 0) (semi-stable 1) (unstable 2))
 306
 307   (defun piece-stability (board sq)
 308     (cond
 309       ((corner-p sq) stable)
 310       ((x-square-p sq)
 311        (if (eql (bref board (corner-for sq)) empty)
 312            unstable semi-stable))
 313       (t (let* ((player (bref board sq))
 314                 (opp (opponent player))
 315                 (p1 (find player board :test-not #'eql
 316                           :start sq :end 19))
 317                 (p2 (find player board :test-not #'eql
 318                           :start 11 :end sq
 319                           :from-end t)))
 320            (cond
 321              ;; unstable pieces can be captured immediately
 322              ;; by playing in the empty square
 323              ((or (and (eql p1 empty) (eql p2 opp))
 324                   (and (eql p2 empty) (eql p1 opp)))
 325               unstable)
 326              ;; Semi-stable pieces might be captured
 327              ((and (eql p1 opp) (eql p2 opp)
 328                    (find empty board :start 11 :end 19))
 329               semi-stable)
 330              ((and (eql p1 empty) (eql p2 empty))
 331               semi-stable)
 332              ;; Stable pieces can never be captured
 333              (t stable)))))))
 334
 335 (defun Iago-eval (player board)
 336   "Combine edge-stability, current mobility and
 337   potential mobility to arrive at an evaluation."
 338   ;; The three factors are multiplied by coefficients
 339   ;; that vary by move number:
 340   (let ((c-edg (+ 312000 (* 6240 *move-number*)))
 341         (c-cur (if (< *move-number* 25)
 342                    (+ 50000 (* 2000 *move-number*))
 343                    (+ 75000 (* 1000 *move-number*))))
 344         (c-pot 20000))
 345     (multiple-value-bind (p-cur p-pot)
 346         (mobility player board)
 347       (multiple-value-bind (o-cur o-pot)
 348           (mobility (opponent player) board)
 349         ;; Combine the three factors into one sum:
 350         (+ (round (* c-edg (edge-stability player board)) 32000)
 351            (round (* c-cur (- p-cur o-cur)) (+ p-cur o-cur 2))
 352            (round (* c-pot  (- p-pot o-pot)) (+ p-pot o-pot 2)))))))
 353
 354 (defun Iago (depth)
 355   "Use an approximation of Iago's evaluation function."
 356   (alpha-beta-searcher3 depth #'iago-eval))
 357