1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: reversi -*-
2 ;;;;***************************************************************************
4 ;;;; FILE IDENTIFICATION
7 ;;;; Purpose: Basic functions for reversi
8 ;;;; Programer: Kevin Rosenberg based on code by Peter Norvig
9 ;;;; Date Started: 1 Nov 2001
11 ;;;; $Id: base.lisp,v 1.3 2003/05/06 15:51:20 kevin Exp $
13 ;;;; This file is Copyright (c) 2001-2002 by Kevin M. Rosenberg
14 ;;;; and Copyright (c) 1998-2002 Peter Norvig
16 ;;;; Reversi users are granted the rights to distribute and use this software
17 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
18 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
19 ;;;;***************************************************************************
21 (in-package #:reversi)
23 (eval-when (:compile-toplevel)
24 (declaim (optimize (safety 1) (space 0) (speed 3) (compilation-speed 0))))
26 (defparameter +all-directions+ '(-11 -10 -9 -1 1 9 10 11))
27 (defconstant +default-max-minutes+ 30)
29 (defconstant empty 0 "An empty square")
30 (defconstant black 1 "A black piece")
31 (defconstant white 2 "A white piece")
32 (defconstant outer 3 "Marks squares outside the 8x8 board")
33 ;;(declaim (type (unsigned-byte 8) empty black white outer))
34 (declaim (type fixnum empty black white outer))
37 (deftype piece () '(unsigned-byte 8))
38 (deftype player () '(unsigned-byte 8))
39 (deftype move () '(unsigned-byte 8))
40 (deftype square () '(unsigned-byte 8))
43 (deftype piece () 'fixnum)
44 (deftype player () 'fixnum)
45 (deftype move () 'fixnum)
46 (deftype square () 'fixnum)
47 (deftype dir () 'fixnum)
48 (deftype board () '(simple-array fixnum (100)))
49 ;;(deftype board () '(simple-array (unsigned-byte 8) (100)))
50 (deftype clock () '(simple-array integer (3)))
53 (make-array 60 :element-type 'cons :fill-pointer 0
55 (deftype moves () '(array cons (60)))
58 (defclass reversi-game ()
59 ((bl-strategy :initarg :bl-strategy
60 :documentation "Strategy function for black"
62 (wh-strategy :initarg :wh-strategy
63 :documentation "Strategy function for white"
65 (board :type board :initarg :board
66 :documentation "The board configuration"
68 (move-number :type fixnum :initarg :move-number
69 :documentation "The number of the move to be played"
70 :accessor move-number)
71 (player :type player :initarg :player
72 :documentation "ID of next player to move"
74 (moves :type moves :initarg :moves
75 :documentation "An array of moves played in the game"
77 (print? :type boolean :initarg :print?
78 :documentation "Whether to print progress of this game"
80 (record-game? :type boolean :initarg :record-game?
81 :documentation "Whether to record moves and clcck of this game"
83 (final-result :type fixnum :initarg :final-result
84 :documentation "Final count, is NIL while game in play"
85 :accessor final-result)
86 (max-minutes :type fixnum :initarg :max-minutes
87 :documentation "Maximum minites for each player"
89 (clock :type clock :initarg :clock :initform nil
90 :documentation "An array of time-units left"
95 :board (initial-board)
102 :max-minutes +default-max-minutes+
103 :clock (make-clock +default-max-minutes+)))
106 (defun name-of (piece) (char ".@O?" piece))
107 (defun title-of (piece) (nth (1- piece) '("Black" "White")) )
109 (defmacro opponent (player)
110 `(if (= ,player black) white black))
112 (defmacro bref (board square)
113 `(the piece (aref (the board ,board) (the square ,square))))
115 (defparameter all-squares
116 (loop for i from 11 to 88 when (<= 1 (mod i 10) 8) collect i)
117 "A list of all squares")
119 (defun initial-board ()
120 "Return a board, empty except for four pieces in the middle."
121 ;; Boards are 100-element vectors, with elements 11-88 used,
122 ;; and the others marked with the sentinel OUTER. Initially
123 ;; the 4 center squares are taken, the others empty.
124 (let ((board (make-array 100 :element-type 'fixnum
125 :initial-element outer
126 :adjustable nil :fill-pointer nil)))
127 (declare (type board board))
128 (dolist (square all-squares)
129 (declare (fixnum square))
130 (setf (bref board square) empty))
131 (setf (bref board 44) white (bref board 45) black
132 (bref board 54) black (bref board 55) white)
135 (defun copy-board (board)
138 (defgeneric make-clock (clock))
139 (defmethod make-clock ((clock array))
140 (make-array (+ 1 (max black white))
141 :element-type 'integer
142 :initial-contents clock
146 (defmethod make-clock ((minutes integer))
147 (make-array (+ 1 (max black white))
148 :element-type 'integer
151 internal-time-units-per-second)
155 (defun count-difference (player board)
156 "Count player's pieces minus opponent's pieces."
157 (declare (type board board)
159 (- (count player board)
160 (count (opponent player) board)))
162 (defun valid-p (move)
163 (declare (type move move))
164 "Valid moves are numbers in the range 11-88 that end in 1-8."
165 (and (typep move 'move) (<= 11 move 88) (<= 1 (mod move 10) 8)))
168 (defun legal-p (move player board)
169 "A Legal move must be into an empty square, and it must
170 flip at least one opponent piece."
171 (declare (type board board)
173 (type player player))
174 (and (= (the piece (bref board move)) empty)
175 (some #'(lambda (dir) (declare (type dir dir)) (would-flip? move player board dir))
179 (defun legal-p (move player board)
180 "A Legal move must be into an empty square, and it must
181 flip at least one opponent piece."
182 (declare (type board board)
185 (optimize speed (safety 0))
187 (if (= (bref board move) empty)
192 (when (>= i 8) (return-from search nil))
193 (when (would-flip? move player board (aref +all-directions+ i))
194 (return-from search t))
199 (defun legal-p (move player board)
200 "A Legal move must be into an empty square, and it must
201 flip at least one opponent piece."
202 (declare (type board board)
205 (optimize (speed 3) (safety 0))
207 (if (= (the piece (bref board move)) empty)
209 (dolist (dir +all-directions+)
210 (declare (type dir dir))
211 (when (would-flip? move player board dir)
212 (return-from search t)))
213 (return-from search nil))
216 (defstruct (state (:constructor make-state-struct))
217 move player board clock)
219 (defun make-state (move player clock board)
220 (make-state-struct :move move :player player :clock (make-clock clock) :board (copy-board board)))
222 (defun make-game-move (game move player)
223 (when (record-game? game)
224 (vector-push (make-state move player (clock game) (board game))
226 (make-move move player (board game))
227 (incf (move-number game)))
229 (defun reset-game (game &optional (move-number 1))
230 (if (record-game? game)
231 (when (< move-number (move-number game))
232 (let ((old-state (aref (moves game) (1- move-number))))
235 (setf (player game) (state-player old-state))
236 (replace-board (board game) (state-board old-state))
237 (replace (clock game) (state-clock old-state))
238 (setf (fill-pointer (moves game)) (1- move-number))
239 (setf (move-number game) move-number))
240 (warn "Couldn't find old state"))))
241 (warn "Tried to reset game, but game is not being recorded")))
243 (defun make-move (move player board)
244 "Update board to reflect move by player"
245 ;; First make the move, then make any flips
246 (declare (type board board)
249 (optimize (speed 3) (safety 0))
251 (setf (bref board move) player)
252 (dolist (dir +all-directions+)
253 (declare (type dir dir))
254 (make-flips move player board dir))
257 (defun make-flips (move player board dir)
258 "Make any flips in the given direction."
259 (declare (type board board)
263 (optimize (speed 3) (safety 0))
265 (let ((bracketer (would-flip? move player board dir)))
267 (loop for c from (+ move dir) by dir until (= c (the fixnum bracketer))
268 do (setf (bref board c) player)))))
270 (defun would-flip? (move player board dir)
271 "Would this move result in any flips in this direction?
272 If so, return the square number of the bracketing piece."
273 ;; A flip occurs if, starting at the adjacent square, c, there
274 ;; is a string of at least one opponent pieces, bracketed by
275 ;; one of player's pieces
276 (declare (type board board)
280 (optimize (speed 3) (safety 0))
282 (let ((c (+ move dir)))
283 (declare (type square c))
284 (and (= (the piece (bref board c)) (the player (opponent player)))
285 (find-bracketing-piece (+ c dir) player board dir))))
287 (defun find-bracketing-piece (square player board dir)
288 "Return the square number of the bracketing piece."
289 (declare (type board board)
293 (optimize (speed 3) (safety 0))
295 (cond ((= (bref board square) player) square)
296 ((= (bref board square) (the player (opponent player)))
297 (find-bracketing-piece (the square (+ square dir)) player board dir))
300 (defun next-to-play (board previous-player &optional (print nil))
301 "Compute the player to move next, or NIL if nobody can move."
302 (declare (type board board)
303 (type player previous-player)
304 (type boolean print))
305 (let ((opp (opponent previous-player)))
306 (cond ((any-legal-move? opp board) opp)
307 ((any-legal-move? previous-player board)
309 (format t "~&~c has no moves and must pass."
314 (defun any-legal-move? (player board)
315 "Does player have any legal moves in this position?"
316 (declare (type player player)
318 (some #'(lambda (move) (declare (type move move)) (legal-p move player board))
322 (defun legal-moves (player board)
323 "Returns a list of legal moves for player"
324 ;;*** fix, segre, 3/30/93. Was remove-if, which can share with all-squares.
325 (declare (type player player)
327 (loop for move in all-squares
328 when (legal-p move player board) collect move))
331 (defun replace-board (to from)
335 (defun replace-board (to from)
336 (declare (type board to from)
337 (optimize (safety 0) (debug 0) (speed 3))
340 (declare (type 'fixnum i))
341 (setf (aref to i) (aref from i)))
345 (defun replace-board (to from)
346 (declare (type board to from))
347 (ff::fslot-memory-copy to 0 400 from)
351 (apply #'vector (loop repeat 40 collect (initial-board))))
355 (defvar *move-number* 1 "The number of the move to be played")
356 (declaim (type fixnum *move-number*))
358 (defun make-game (bl-strategy wh-strategy
361 (minutes +default-max-minutes+)
364 (make-instance 'reversi-game :bl-strategy bl-strategy
365 :wh-strategy wh-strategy
367 :record-game? record-game
368 :max-minutes minutes)))
369 (setf (clock game) (make-clock minutes))
372 (defun play-game (game)
374 (until (null (player game))
375 (setq *move-number* (move-number game))
377 (if (= (player game) black)
381 (board game) (print? game) (clock game))
383 (next-to-play (board game) (player game) (print? game)))
384 (incf (move-number game))))
386 (format t "~&The game is over. Final result:")
387 (print-board (board game) (clock game)))
388 (count-difference black (board game)))
391 (defun reversi (bl-strategy wh-strategy
392 &optional (print t) (minutes +default-max-minutes+))
393 (play-game (make-game bl-strategy wh-strategy :print print
394 :record-game nil :minutes minutes)))
396 (defvar *clock* (make-clock +default-max-minutes+) "A copy of the game clock")
397 (defvar *board* (initial-board) "A copy of the game board")
399 (defun get-move (game strategy player board print clock)
400 "Call the player's strategy function to get a move.
401 Keep calling until a legal move is made."
402 ;; Note we don't pass the strategy function the REAL board.
403 ;; If we did, it could cheat by changing the pieces on the board.
404 (when print (print-board board clock))
405 (replace *clock* clock)
406 (let* ((t0 (get-internal-real-time))
407 (move (funcall strategy player (replace-board *board* board)))
408 (t1 (get-internal-real-time)))
409 (decf (elt clock player) (- t1 t0))
411 ((< (elt clock player) 0)
412 (format t "~&~c has no time left and forfeits."
414 (throw 'game-over (if (eql player black) -64 64)))
416 (throw 'game-over (if (eql player black) -64 64)))
417 ((and (valid-p move) (legal-p move player board))
419 (format t "~&~c moves to ~a."
420 (name-of player) (88->h8 move)))
421 (make-game-move game move player))
422 (t (warn "Illegal move: ~a" (88->h8 move))
423 (get-move game strategy player board print clock)))))
426 (defun random-reversi-series (strategy1 strategy2
427 n-pairs &optional (n-random 10))
428 "Play a series of 2*n games, starting from a random position."
430 (switch-strategies #'random-strategy n-random strategy1)
431 (switch-strategies #'random-strategy n-random strategy2)
434 (defun switch-strategies (strategy1 m strategy2)
435 "Make a new strategy that plays strategy1 for m moves,
436 then plays according to strategy2."
437 #'(lambda (player board)
438 (funcall (if (<= *move-number* m) strategy1 strategy2)
441 (defun reversi-series (strategy1 strategy2 n-pairs)
442 "Play a series of 2*n-pairs games, swapping sides."
445 for random-state = (make-random-state)
446 collect (reversi strategy1 strategy2 nil)
447 do (setf *random-state* random-state)
448 collect (- (reversi strategy2 strategy1 nil)))))
449 ;; Return the number of wins (1/2 for a tie),
450 ;; the total of the point differences, and the
451 ;; scores themselves, all from strategy1's point of view.
452 (values (+ (count-if #'plusp scores)
453 (/ (count-if #'zerop scores) 2))
457 (defun round-robin (strategies n-pairs &optional
458 (n-random 10) (names strategies))
459 "Play a tournament among the strategies.
460 N-PAIRS = games each strategy plays as each color against
461 each opponent. So with N strategies, a total of
462 N*(N-1)*N-PAIRS games are played."
463 (let* ((N (length strategies))
464 (totals (make-array N :initial-element 0))
465 (scores (make-array (list N N)
466 :initial-element 0)))
469 (loop for j from (+ i 1) to (- N 1) do
470 (let* ((wins (random-reversi-series
474 (losses (- (* 2 n-pairs) wins)))
475 (incf (aref scores i j) wins)
476 (incf (aref scores j i) losses)
477 (incf (aref totals i) wins)
478 (incf (aref totals j) losses))))
481 (format t "~&~a~20T ~4f: " (elt names i) (elt totals i))
483 (format t "~4f " (if (eql i j) '---
484 (aref scores i j)))))))