edge-table.lisp

   1 ;;;;***************************************************************************
   2 ;;;;
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;;  Name:           edge-table.cl
   6 ;;;;  Purpose:        Edge table routines for reversi
   7 ;;;;  Programer:      Kevin M. Rosenberg, M.D.
   8 ;;;;  Date Started:   1 Nov 2001
   9 ;;;;  CVS Id:         $Id: edge-table.lisp,v 1.1 2002/10/25 08:36:42 kevin Exp $
  10 ;;;;
  11 ;;;;***************************************************************************
  12
  13
  14 (in-package :reversi)
  15 (declaim (optimize (safety 1) (debug 3) (speed 3) (compilation-speed 0)))
  16
  17 (eval-when (:compile-toplevel :load-toplevel :execute)
  18   (defparameter *edge-and-x-lists*
  19     '((22 11 12 13 14 15 16 17 18 27)
  20       (72 81 82 83 84 85 86 87 88 77)
  21       (22 11 21 31 41 51 61 71 81 72)
  22       (27 18 28 38 48 58 68 78 88 77))
  23     "The four edges (with their X-squares)."))
  24
  25 (defparameter *top-edge* (first *edge-and-x-lists*))
  26
  27 (defvar *edge-table* nil
  28   "Array of values to player-to-move for edge positions.")
  29
  30 ;;(declaim (type (simple-array fixnum #.(expt 3 10)) *edge-table*))
  31
  32 (defun make-edge-table ()
  33   (setq *edge-table* (make-array (expt 3 10) :element-type 'fixnum
  34                                  :adjustable nil :fill-pointer nil))
  35   (init-edge-table)
  36   *edge-table*)
  37
  38
  39 (defun map-edge-n-pieces (fn player board n squares index)
  40   "Call fn on all edges with n pieces."
  41   ;; Index counts 1 for player; 2 for opponent
  42   (declare (fixnum index)
  43            (type player player)
  44            (type square index)
  45            (type (simple-array fixnum (100)) board)
  46            (list squares))
  47   (cond
  48     ((< (length squares) n) nil)
  49     ((null squares) (funcall fn board index))
  50     (t (let ((index3 (* 3 index))
  51              (sq (first squares)))
  52          (declare (fixnum index3 sq))
  53          (map-edge-n-pieces fn player board n (rest squares) index3)
  54          (when (and (> n 0) (eql (bref board sq) empty))
  55            (setf (bref board sq) player)
  56            (map-edge-n-pieces fn player board (- n 1) (rest squares)
  57                               (+ 1 index3))
  58            (setf (bref board sq) (opponent player))
  59            (map-edge-n-pieces fn player board (- n 1) (rest squares)
  60                               (+ 2 index3))
  61            (setf (bref board sq) empty))))))
  62
  63
  64
  65 (defun possible-edge-moves-value (player board index)
  66   "Consider all possible edge moves.
  67   Combine their values into a single number."
  68   (declare (type board board)
  69            (type player player)
  70            (type square index))
  71   (combine-edge-moves
  72    (cons
  73       (list 1.0 (aref *edge-table* index)) ;; no move
  74       (loop for sq in *top-edge*             ;; possible moves
  75             when (= (bref board sq) empty)
  76             collect (possible-edge-move player board sq)))
  77     player))
  78
  79
  80 (defun edge-index (player board squares)
  81   "The index counts 1 for player; 2 for opponent,
  82   on each square---summed as a base 3 number."
  83   (declare (type board board)
  84            (type player player)
  85            (type cons squares)
  86            (optimize (speed 3) (safety 1)))
  87   (let ((index 0))
  88     (declare (fixnum index))
  89     (dolist (sq squares)
  90       (declare (type square sq))
  91       (setq index
  92         (the fixnum
  93           (+
  94            (the fixnum (* index 3))
  95            (the fixnum (cond ((= (bref board sq) empty) 0)
  96                              ((= (bref board sq) player) 1)
  97                              (t 2)))))))
  98     index))
  99
 100 (defun possible-edge-move (player board sq)
 101   "Return a (prob val) pair for a possible edge move."
 102   (declare (type board board)
 103            (type player player)
 104            (type square sq))
 105   (let ((new-board (replace-board (svref *ply-boards* player) board)))
 106     (make-move sq player new-board)
 107     (list (edge-move-probability player board sq)
 108           (- (aref *edge-table*
 109                     (edge-index (opponent player)
 110                                new-board *top-edge*))))))
 111
 112 (defun combine-edge-moves (possibilities player)
 113   "Combine the best moves."
 114   (let ((prob 1.0)
 115         (val 0.0)
 116         (fn (if (= player black) #'> #'<)))
 117     (declare (short-float prob val))
 118     (loop for pair in (sort possibilities fn :key #'second)
 119           while (>= prob 0.0)
 120         do (incf val (* prob (first pair) (second pair)))
 121            (decf prob (* prob (first pair))))
 122     (round val)))
 123
 124
 125 (eval-when (:compile-toplevel :load-toplevel :execute)
 126   (let ((corner/xsqs '((11 . 22) (18 . 27) (81. 72) (88 . 77))))
 127     (defun corner-p (sq) (assoc sq corner/xsqs))
 128     (defun x-square-p (sq) (rassoc sq corner/xsqs))
 129     (defun x-square-for (corner) (cdr (assoc corner corner/xsqs)))
 130     (defun corner-for (xsq) (car (rassoc xsq corner/xsqs)))))
 131
 132 (defun edge-move-probability (player board square)
 133   "What's the probability that player can move to this square?"
 134   (declare (type board board)
 135            (type player player)
 136            (type square square))
 137   (cond
 138     ((x-square-p square) .5) ;; X-squares
 139     ((legal-p square player board) 1.0) ;; immediate capture
 140     ((corner-p square) ;; move to corner depends on X-square
 141      (let ((x-sq (x-square-for square)))
 142        (declare (type square x-sq))
 143        (cond
 144          ((= (bref board x-sq) empty) .1)
 145          ((= (bref board x-sq) player) 0.001)
 146          (t .9))))
 147     (t (/ (aref
 148             '#2A((.1  .4 .7)
 149                  (.05 .3  *)
 150                  (.01  *  *))
 151             (count-edge-neighbors player board square)
 152             (count-edge-neighbors (opponent player) board square))
 153           (if (legal-p square (opponent player) board) 2 1)))))
 154
 155 (defun count-edge-neighbors (player board square)
 156   "Count the neighbors of this square occupied by player."
 157   (declare (type board board)
 158            (type player player)
 159            (type square square))
 160   (count-if #'(lambda (inc)
 161                 (declare (type square inc))
 162                 (= (bref board (+ square inc)) player))
 163             '(+1 -1)))
 164
 165 (defparameter *static-edge-table*
 166   '#2A(;stab  semi    un
 167        (   *    0 -2000) ; X
 168        ( 700    *     *) ; corner
 169        (1200  200   -25) ; C
 170        (1000  200    75) ; A
 171        (1000  200    50) ; B
 172        (1000  200    50) ; B
 173        (1000  200    75) ; A
 174        (1200  200   -25) ; C
 175        ( 700    *     *) ; corner
 176        (   *    0 -2000) ; X
 177        ))
 178 (declaim (type (simple-array t (* *)) *static-edge-table*))
 179
 180 (defun static-edge-stability (player board)
 181   "Compute this edge's static stability"
 182   (declare (type board board)
 183            (type player player))
 184   (loop for sq in *top-edge*
 185       for i from 0
 186       sum (the fixnum
 187             (cond
 188              ((= (bref board sq) empty) 0)
 189              ((= (bref board sq) player)
 190               (aref *static-edge-table* i
 191                     (piece-stability board sq)))
 192              (t (- (aref *static-edge-table* i
 193                          (piece-stability board sq))))))))
 194
 195 (eval-when (:compile-toplevel :load-toplevel :execute)
 196   (let ((stable 0) (semi-stable 1) (unstable 2))
 197     (declaim (type fixnum stable semi-stable unstable))
 198
 199     (defun piece-stability (board sq)
 200       (declare (type board board)
 201                (fixnum sq))
 202     (cond
 203       ((corner-p sq) stable)
 204       ((x-square-p sq)
 205        (if (eql (bref board (corner-for sq)) empty)
 206            unstable semi-stable))
 207       (t (let* ((player (bref board sq))
 208                 (opp (opponent player))
 209                 (p1 (find player board :test-not #'eql
 210                           :start sq :end 19))
 211                 (p2 (find player board :test-not #'eql
 212                           :start 11 :end sq
 213                           :from-end t)))
 214            (declare (fixnum player opp))
 215            (cond
 216              ;; unstable pieces can be captured immediately
 217              ;; by playing in the empty square
 218              ((or (and (eql p1 empty) (eql p2 opp))
 219                   (and (eql p2 empty) (eql p1 opp)))
 220               unstable)
 221              ;; Semi-stable pieces might be captured
 222              ((and (eql p1 opp) (eql p2 opp)
 223                    (find empty board :start 11 :end 19))
 224               semi-stable)
 225              ((and (eql p1 empty) (eql p2 empty))
 226               semi-stable)
 227              ;; Stable pieces can never be captured
 228              (t stable))))))))
 229
 230
 231 (defun init-edge-table ()
 232   "Initialize *edge-table*, starting from the empty board."
 233   ;; Initialize the static values
 234   (loop for n-pieces from 0 to 10 do
 235         (map-edge-n-pieces
 236          #'(lambda (board index)
 237              (declare (type board board)
 238                       (fixnum index))
 239               (setf (aref *edge-table* index)
 240                     (the fixnum (static-edge-stability black board))))
 241          black (initial-board) n-pieces *top-edge* 0))
 242   ;; Now iterate five times trying to improve:
 243   (dotimes (i 5)
 244     (declare (fixnum i))
 245     ;; Do the indexes with most pieces first
 246     (loop for n-pieces from 9 downto 1 do
 247           (map-edge-n-pieces
 248             #'(lambda (board index)
 249              (declare (type board board)
 250                       (fixnum index))
 251                 (setf (aref *edge-table* index)
 252                       (the fixnum (possible-edge-moves-value black board index))))
 253             black (initial-board) n-pieces *top-edge* 0))))
 254