1 ;;;; -*- Mode: Lisp; Syntax: Common-Lisp -*-
2 ;;;; Code from Paradigms of AI Programming
3 ;;;; Copyright (c) 1991 Peter Norvig
5 ;;;; File othello.lisp: An othello monitor, with all strategies
6 ;;;; up to and including section 18.8
8 ;;; One bug fix by Alberto Segre, segre@cs.cornell.edu, March 1993.
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)))
15 (defun random-elt (seq)
16 "Pick a random element out of a sequence."
17 (elt seq (random (length seq))))
19 (defun concat-symbol (&rest args)
20 "Concatenate symbols or strings to form an interned symbol"
21 (intern (format nil "~{~a~}" args)))
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))
30 (defconstant all-directions '(-11 -10 -9 -1 1 9 10 11))
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")
37 (deftype piece () `(integer ,empty ,outer))
39 (defun name-of (piece) (char ".@O?" piece))
41 (defun opponent (player) (if (eql player black) white black))
43 (deftype board () '(simple-array piece (100)))
45 (defun bref (board square) (aref board square))
46 (defsetf bref (board square) (val)
47 `(setf (aref ,board ,square) ,val))
49 (defun copy-board (board)
52 (defconstant all-squares
53 (loop for i from 11 to 88 when (<= 1 (mod i 10) 8) collect i))
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)
68 (defun count-difference (player board)
69 "Count player's pieces minus opponent's pieces."
70 (- (count player board)
71 (count (opponent player) board)))
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)))
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))
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))
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)))
96 (loop for c from (+ move dir) by dir until (eql c bracketer)
97 do (setf (bref board c) player)))))
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))))
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))
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)
122 (format t "~&~c has no moves and must pass."
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))
132 (defun random-strategy (player board)
133 "Make any legal move."
134 (random-elt (legal-moves player board)))
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))
142 (defun maximize-difference (player board)
143 "A strategy that maximizes the difference in pieces."
144 (funcall (maximizer #'count-difference) player board))
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)
157 (make-move move player
158 (copy-board board))))
160 (best (apply #'max scores)))
161 (elt moves (position best scores)))))
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))
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)))))
184 (defconstant winning-value most-positive-fixnum)
185 (defconstant losing-value most-negative-fixnum)
187 (defun final-value (player board)
188 "Is this a win, loss, or draw for player?"
189 (case (signum (count-difference player board))
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."
198 (funcall eval-fn player board)
199 (let ((moves (legal-moves player board)))
201 (if (any-legal-move? (opponent player) board)
202 (- (minimax (opponent player) board
204 (final-value player board))
205 (let ((best-move nil)
208 (let* ((board2 (make-move move player
211 (opponent player) board2
212 (- ply 1) eval-fn))))
213 (when (or (null best-val)
216 (setf best-move move))))
217 (values best-val best-move))))))
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))
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."
232 (funcall eval-fn player board)
233 (let ((moves (legal-moves player board)))
235 (if (any-legal-move? (opponent player) board)
236 (- (alpha-beta (opponent player) board
237 (- cutoff) (- achievable)
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
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))))))
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
260 (declare (ignore value))
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)
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))
282 (aref neighbor-table square)))))
284 (defun neighbors (square)
285 "Return a list of all squares adjacent to a square."
286 (aref neighbor-table square)))
289 (cross-product #'concat-symbol
290 '(? a b c d e f g h ?)
291 '(? 1 2 3 4 5 6 7 8 ?))))
294 "Convert from alphanumeric to numeric square notation."
295 (or (position (string str) square-names :test #'string-equal)
299 "Convert from numeric to alphanumeric square notation."
301 (elt square-names num)
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)))
310 (defvar *move-number* 1 "The number of the move to be played")
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))
320 internal-time-units-per-second))))
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)
328 do (get-move strategy player board print clock))
330 (format t "~&The game is over. Final result:")
331 (print-board board clock))
332 (count-difference black board))))
334 (defvar *clock* (make-array 3) "A copy of the game clock")
335 (defvar *board* (initial-board) "A copy of the game board")
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))
349 ((< (elt clock player) 0)
350 (format t "~&~c has no time left and forfeits."
352 (THROW 'game-over (if (eql player black) -64 64)))
354 (THROW 'game-over (if (eql player black) -64 64)))
355 ((and (valid-p move) (legal-p move player board))
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)))))
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
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)))))
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)))
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."
392 (switch-strategies #'random-strategy n-random strategy1)
393 (switch-strategies #'random-strategy n-random strategy2)
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)
403 (defun othello-series (strategy1 strategy2 n-pairs)
404 "Play a series of 2*n-pairs games, swapping sides."
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))
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)))
431 (loop for j from (+ i 1) to (- N 1) do
432 (let* ((wins (random-othello-series
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))))
443 (format t "~&~a~20T ~4f: " (elt names i) (elt totals i))
445 (format t "~4f " (if (= i j) '---
446 (aref scores i j)))))))
448 (defun mobility (player board)
449 "The number of moves a player has."
450 (length (legal-moves player board)))