1 ;;;; -*- Mode: Lisp; Syntax: Common-Lisp -*-
2 ;;;; Code from Paradigms of AI Programming
3 ;;;; Copyright (c) 1991 Peter Norvig
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
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))))
20 (defstruct (node) square board value)
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)
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))
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
37 (values (node-value node) node)
38 (let* ((board (node-board node))
39 (nodes (legal-nodes player board eval-fn)))
41 (if (any-legal-move? (opponent player) board)
42 (values (- (alpha-beta2 (opponent player)
44 (- cutoff) (- achievable)
47 (values (final-value player board) nil))
48 (let ((best-node (first nodes)))
49 (loop for move in nodes
50 for val = (- (alpha-beta2
53 (- cutoff) (- achievable)
55 do (when (> val achievable)
57 (setf best-node move))
58 until (>= achievable cutoff))
59 (values achievable best-node))))))
61 (defun negate-value (node)
62 "Set the value of a node to its negative."
63 (setf (node-value node) (- (node-value node)))
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)))
72 (let ((new-board (make-move move player
75 :square move :board new-board
76 :value (funcall eval-fn player new-board))))
78 #'> :key #'node-value)))
81 (apply #'vector (loop repeat 40 collect (initial-board))))
83 (defun alpha-beta3 (player board achievable cutoff ply eval-fn
85 "A-B search, putting killer move first."
87 (funcall eval-fn player board)
88 (let ((moves (put-first killer (legal-moves player board))))
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))
98 (killer2-val winning-value))
99 (loop for move in moves
100 do (multiple-value-bind (val reply)
103 (make-move move player
104 (replace new-board board))
105 (- cutoff) (- achievable)
106 (- ply 1) eval-fn killer2)
108 (when (> val achievable)
109 (setf achievable val)
110 (setf best-move move))
111 (when (and reply (< val killer2-val))
113 (setf killer2-val val)))
114 until (>= achievable cutoff))
115 (values achievable best-move))))))
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
123 (declare (ignore value))
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))
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)
145 ((some #'(lambda (sq) (eql (bref board sq) opp))
148 (values current (+ current potential))))
150 (defvar *edge-table* (make-array (expt 3 10))
151 "Array of values to player-to-move for edge positions.")
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).")
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."
165 (setq index (+ (* index 3)
166 (cond ((eql (bref board sq) empty) 0)
167 ((eql (bref board sq) player) 1)
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))))
177 (defconstant top-edge (first edge-and-x-lists))
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
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:
190 ;; Do the indexes with most pieces first
191 (loop for n-pieces from 9 downto 1 do
193 #'(lambda (board index)
194 (setf (aref *edge-table* index)
195 (possible-edge-moves-value
197 black (initial-board) n-pieces top-edge 0))))
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
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)
212 (setf (bref board sq) (opponent player))
213 (map-edge-n-pieces fn player board (- n 1) (rest squares)
215 (setf (bref board sq) empty))))))
217 (defun possible-edge-moves-value (player board index)
218 "Consider all possible edge moves.
219 Combine their values into a single number."
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)))
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))))))
237 (defun combine-edge-moves (possibilities player)
238 "Combine the best moves."
241 (fn (if (eql player black) #'> #'<)))
242 (loop for pair in (sort possibilities fn :key #'second)
244 do (incf val (* prob (first pair) (second pair)))
245 (decf prob (* prob (first pair))))
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))))
254 (defun edge-move-probability (player board square)
255 "What's the probability that player can move to this square?"
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)))
262 ((eql (bref board x-sq) empty) .1)
263 ((eql (bref board x-sq) player) 0.001)
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)))))
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))
279 (defparameter *static-edge-table*
293 (defun static-edge-stability (player board)
294 "Compute this edge's static stability"
295 (loop for sq in top-edge
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)))))))
305 (let ((stable 0) (semi-stable 1) (unstable 2))
307 (defun piece-stability (board sq)
309 ((corner-p sq) stable)
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
317 (p2 (find player board :test-not #'eql
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)))
326 ;; Semi-stable pieces might be captured
327 ((and (eql p1 opp) (eql p2 opp)
328 (find empty board :start 11 :end 19))
330 ((and (eql p1 empty) (eql p2 empty))
332 ;; Stable pieces can never be captured
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*))))
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)))))))
355 "Use an approximation of Iago's evaluation function."
356 (alpha-beta-searcher3 depth #'iago-eval))