+++ /dev/null
-;;;; -*- Mode: Lisp; Syntax: Common-Lisp -*-
-;;;; Code from Paradigms of AI Programming
-;;;; Copyright (c) 1991 Peter Norvig
-
-;;;; File othello.lisp: An othello monitor, with all strategies
-;;;; up to and including section 18.8
-
-;;; One bug fix by Alberto Segre, segre@cs.cornell.edu, March 1993.
-
-(defun mappend (fn list)
- "Append the results of calling fn on each element of list.
- Like mapcon, but uses append instead of nconc."
- (apply #'append (mapcar fn list)))
-
-(defun random-elt (seq)
- "Pick a random element out of a sequence."
- (elt seq (random (length seq))))
-
-(defun concat-symbol (&rest args)
- "Concatenate symbols or strings to form an interned symbol"
- (intern (format nil "~{~a~}" args)))
-
-(defun cross-product (fn xlist ylist)
- "Return a list of all (fn x y) values."
- (mappend #'(lambda (y)
- (mapcar #'(lambda (x) (funcall fn x y))
- xlist))
- ylist))
-
-(defconstant all-directions '(-11 -10 -9 -1 1 9 10 11))
-
-(defconstant empty 0 "An empty square")
-(defconstant black 1 "A black piece")
-(defconstant white 2 "A white piece")
-(defconstant outer 3 "Marks squares outside the 8x8 board")
-
-(deftype piece () `(integer ,empty ,outer))
-
-(defun name-of (piece) (char ".@O?" piece))
-
-(defun opponent (player) (if (eql player black) white black))
-
-(deftype board () '(simple-array piece (100)))
-
-(defun bref (board square) (aref board square))
-(defsetf bref (board square) (val)
- `(setf (aref ,board ,square) ,val))
-
-(defun copy-board (board)
- (copy-seq board))
-
-(defconstant all-squares
- (loop for i from 11 to 88 when (<= 1 (mod i 10) 8) collect i))
-
-(defun initial-board ()
- "Return a board, empty except for four pieces in the middle."
- ;; Boards are 100-element vectors, with elements 11-88 used,
- ;; and the others marked with the sentinel OUTER. Initially
- ;; the 4 center squares are taken, the others empty.
- (let ((board (make-array 100 :element-type 'piece
- :initial-element outer)))
- (dolist (square all-squares)
- (setf (bref board square) empty))
- (setf (bref board 44) white (bref board 45) black
- (bref board 54) black (bref board 55) white)
- board))
-
-(defun count-difference (player board)
- "Count player's pieces minus opponent's pieces."
- (- (count player board)
- (count (opponent player) board)))
-
-(defun valid-p (move)
- "Valid moves are numbers in the range 11-88 that end in 1-8."
- (and (integerp move) (<= 11 move 88) (<= 1 (mod move 10) 8)))
-
-(defun legal-p (move player board)
- "A Legal move must be into an empty square, and it must
- flip at least one opponent piece."
- (and (eql (bref board move) empty)
- (some #'(lambda (dir) (would-flip? move player board dir))
- all-directions)))
-
-(defun make-move (move player board)
- "Update board to reflect move by player"
- ;; First make the move, then make any flips
- (setf (bref board move) player)
- (dolist (dir all-directions)
- (make-flips move player board dir))
- board)
-
-(defun make-flips (move player board dir)
- "Make any flips in the given direction."
- (let ((bracketer (would-flip? move player board dir)))
- (when bracketer
- (loop for c from (+ move dir) by dir until (eql c bracketer)
- do (setf (bref board c) player)))))
-
-(defun would-flip? (move player board dir)
- "Would this move result in any flips in this direction?
- If so, return the square number of the bracketing piece."
- ;; A flip occurs if, starting at the adjacent square, c, there
- ;; is a string of at least one opponent pieces, bracketed by
- ;; one of player's pieces
- (let ((c (+ move dir)))
- (and (eql (bref board c) (opponent player))
- (find-bracketing-piece (+ c dir) player board dir))))
-
-(defun find-bracketing-piece (square player board dir)
- "Return the square number of the bracketing piece."
- (cond ((eql (bref board square) player) square)
- ((eql (bref board square) (opponent player))
- (find-bracketing-piece (+ square dir) player board dir))
- (t nil)))
-
-(defun next-to-play (board previous-player print)
- "Compute the player to move next, or NIL if nobody can move."
- (let ((opp (opponent previous-player)))
- (cond ((any-legal-move? opp board) opp)
- ((any-legal-move? previous-player board)
- (when print
- (format t "~&~c has no moves and must pass."
- (name-of opp)))
- previous-player)
- (t nil))))
-
-(defun any-legal-move? (player board)
- "Does player have any legal moves in this position?"
- (some #'(lambda (move) (legal-p move player board))
- all-squares))
-
-(defun random-strategy (player board)
- "Make any legal move."
- (random-elt (legal-moves player board)))
-
-(defun legal-moves (player board)
- "Returns a list of legal moves for player"
- ;;*** fix, segre, 3/30/93. Was remove-if, which can share with all-squares.
- (loop for move in all-squares
- when (legal-p move player board) collect move))
-
-(defun maximize-difference (player board)
- "A strategy that maximizes the difference in pieces."
- (funcall (maximizer #'count-difference) player board))
-
-(defun maximizer (eval-fn)
- "Return a strategy that will consider every legal move,
- apply EVAL-FN to each resulting board, and choose
- the move for which EVAL-FN returns the best score.
- FN takes two arguments: the player-to-move and board"
- #'(lambda (player board)
- (let* ((moves (legal-moves player board))
- (scores (mapcar #'(lambda (move)
- (funcall
- eval-fn
- player
- (make-move move player
- (copy-board board))))
- moves))
- (best (apply #'max scores)))
- (elt moves (position best scores)))))
-
-(defparameter *weights*
- '#(0 0 0 0 0 0 0 0 0 0
- 0 120 -20 20 5 5 20 -20 120 0
- 0 -20 -40 -5 -5 -5 -5 -40 -20 0
- 0 20 -5 15 3 3 15 -5 20 0
- 0 5 -5 3 3 3 3 -5 5 0
- 0 5 -5 3 3 3 3 -5 5 0
- 0 20 -5 15 3 3 15 -5 20 0
- 0 -20 -40 -5 -5 -5 -5 -40 -20 0
- 0 120 -20 20 5 5 20 -20 120 0
- 0 0 0 0 0 0 0 0 0 0))
-
-(defun weighted-squares (player board)
- "Sum of the weights of player's squares minus opponent's."
- (let ((opp (opponent player)))
- (loop for i in all-squares
- when (eql (bref board i) player)
- sum (aref *weights* i)
- when (eql (bref board i) opp)
- sum (- (aref *weights* i)))))
-
-(defconstant winning-value most-positive-fixnum)
-(defconstant losing-value most-negative-fixnum)
-
-(defun final-value (player board)
- "Is this a win, loss, or draw for player?"
- (case (signum (count-difference player board))
- (-1 losing-value)
- ( 0 0)
- (+1 winning-value)))
-
-(defun minimax (player board ply eval-fn)
- "Find the best move, for PLAYER, according to EVAL-FN,
- searching PLY levels deep and backing up values."
- (if (= ply 0)
- (funcall eval-fn player board)
- (let ((moves (legal-moves player board)))
- (if (null moves)
- (if (any-legal-move? (opponent player) board)
- (- (minimax (opponent player) board
- (- ply 1) eval-fn))
- (final-value player board))
- (let ((best-move nil)
- (best-val nil))
- (dolist (move moves)
- (let* ((board2 (make-move move player
- (copy-board board)))
- (val (- (minimax
- (opponent player) board2
- (- ply 1) eval-fn))))
- (when (or (null best-val)
- (> val best-val))
- (setf best-val val)
- (setf best-move move))))
- (values best-val best-move))))))
-
-(defun minimax-searcher (ply eval-fn)
- "A strategy that searches PLY levels and then uses EVAL-FN."
- #'(lambda (player board)
- (multiple-value-bind (value move)
- (minimax player board ply eval-fn)
- (declare (ignore value))
- move)))
-
-(defun alpha-beta (player board achievable cutoff ply eval-fn)
- "Find the best move, for PLAYER, according to EVAL-FN,
- searching PLY levels deep and backing up values,
- using cutoffs whenever possible."
- (if (= ply 0)
- (funcall eval-fn player board)
- (let ((moves (legal-moves player board)))
- (if (null moves)
- (if (any-legal-move? (opponent player) board)
- (- (alpha-beta (opponent player) board
- (- cutoff) (- achievable)
- (- ply 1) eval-fn))
- (final-value player board))
- (let ((best-move (first moves)))
- (loop for move in moves do
- (let* ((board2 (make-move move player
- (copy-board board)))
- (val (- (alpha-beta
- (opponent player) board2
- (- cutoff) (- achievable)
- (- ply 1) eval-fn))))
- (when (> val achievable)
- (setf achievable val)
- (setf best-move move)))
- until (>= achievable cutoff))
- (values achievable best-move))))))
-
-(defun alpha-beta-searcher (depth eval-fn)
- "A strategy that searches to DEPTH and then uses EVAL-FN."
- #'(lambda (player board)
- (multiple-value-bind (value move)
- (alpha-beta player board losing-value winning-value
- depth eval-fn)
- (declare (ignore value))
- move)))
-
-(defun modified-weighted-squares (player board)
- "Like WEIGHTED-SQUARES, but don't take off for moving
- near an occupied corner."
- (let ((w (weighted-squares player board)))
- (dolist (corner '(11 18 81 88))
- (when (not (eql (bref board corner) empty))
- (dolist (c (neighbors corner))
- (when (not (eql (bref board c) empty))
- (incf w (* (- 5 (aref *weights* c))
- (if (eql (bref board c) player)
- +1 -1)))))))
- w))
-
-(let ((neighbor-table (make-array 100 :initial-element nil)))
- ;; Initialize the neighbor table
- (dolist (square all-squares)
- (dolist (dir all-directions)
- (if (valid-p (+ square dir))
- (push (+ square dir)
- (aref neighbor-table square)))))
-
- (defun neighbors (square)
- "Return a list of all squares adjacent to a square."
- (aref neighbor-table square)))
-
-(let ((square-names
- (cross-product #'concat-symbol
- '(? a b c d e f g h ?)
- '(? 1 2 3 4 5 6 7 8 ?))))
-
- (defun h8->88 (str)
- "Convert from alphanumeric to numeric square notation."
- (or (position (string str) square-names :test #'string-equal)
- str))
-
- (defun 88->h8 (num)
- "Convert from numeric to alphanumeric square notation."
- (if (valid-p num)
- (elt square-names num)
- num)))
-
-(defun human (player board)
- "A human player for the game of Othello"
- (format t "~&~c to move ~a: " (name-of player)
- (mapcar #'88->h8 (legal-moves player board)))
- (h8->88 (read)))
-
-(defvar *move-number* 1 "The number of the move to be played")
-
-(defun othello (bl-strategy wh-strategy
- &optional (print t) (minutes 30))
- "Play a game of othello. Return the score, where a positive
- difference means black, the first player, wins."
- (let ((board (initial-board))
- (clock (make-array (+ 1 (max black white))
- :initial-element
- (* minutes 60
- internal-time-units-per-second))))
- (catch 'game-over
- (loop for *move-number* from 1
- for player = black then (next-to-play board player print)
- for strategy = (if (eql player black)
- bl-strategy
- wh-strategy)
- until (null player)
- do (get-move strategy player board print clock))
- (when print
- (format t "~&The game is over. Final result:")
- (print-board board clock))
- (count-difference black board))))
-
-(defvar *clock* (make-array 3) "A copy of the game clock")
-(defvar *board* (initial-board) "A copy of the game board")
-
-(defun get-move (strategy player board print clock)
- "Call the player's strategy function to get a move.
- Keep calling until a legal move is made."
- ;; Note we don't pass the strategy function the REAL board.
- ;; If we did, it could cheat by changing the pieces on the board.
- (when print (print-board board clock))
- (replace *clock* clock)
- (let* ((t0 (get-internal-real-time))
- (move (funcall strategy player (replace *board* board)))
- (t1 (get-internal-real-time)))
- (decf (elt clock player) (- t1 t0))
- (cond
- ((< (elt clock player) 0)
- (format t "~&~c has no time left and forfeits."
- (name-of player))
- (THROW 'game-over (if (eql player black) -64 64)))
- ((eq move 'resign)
- (THROW 'game-over (if (eql player black) -64 64)))
- ((and (valid-p move) (legal-p move player board))
- (when print
- (format t "~&~c moves to ~a."
- (name-of player) (88->h8 move)))
- (make-move move player board))
- (t (warn "Illegal move: ~a" (88->h8 move))
- (get-move strategy player board print clock)))))
-
-(defun print-board (&optional (board *board*) clock)
- "Print a board, along with some statistics."
- ;; First print the header and the current score
- (format t "~2& a b c d e f g h [~c=~2a ~c=~2a (~@d)]"
- (name-of black) (count black board)
- (name-of white) (count white board)
- (count-difference black board))
- ;; Print the board itself
- (loop for row from 1 to 8 do
- (format t "~& ~d " row)
- (loop for col from 1 to 8
- for piece = (bref board (+ col (* 10 row)))
- do (format t "~c " (name-of piece))))
- ;; Finally print the time remaining for each player
- (when clock
- (format t " [~c=~a ~c=~a]~2&"
- (name-of black) (time-string (elt clock black))
- (name-of white) (time-string (elt clock white)))))
-
-(defun time-string (time)
- "Return a string representing this internal time in min:secs."
- (multiple-value-bind (min sec)
- (floor (round time internal-time-units-per-second) 60)
- (format nil "~2d:~2,'0d" min sec)))
-
-(defun random-othello-series (strategy1 strategy2
- n-pairs &optional (n-random 10))
- "Play a series of 2*n games, starting from a random position."
- (othello-series
- (switch-strategies #'random-strategy n-random strategy1)
- (switch-strategies #'random-strategy n-random strategy2)
- n-pairs))
-
-(defun switch-strategies (strategy1 m strategy2)
- "Make a new strategy that plays strategy1 for m moves,
- then plays according to strategy2."
- #'(lambda (player board)
- (funcall (if (<= *move-number* m) strategy1 strategy2)
- player board)))
-
-(defun othello-series (strategy1 strategy2 n-pairs)
- "Play a series of 2*n-pairs games, swapping sides."
- (let ((scores
- (loop repeat n-pairs
- for random-state = (make-random-state)
- collect (othello strategy1 strategy2 nil)
- do (setf *random-state* random-state)
- collect (- (othello strategy2 strategy1 nil)))))
- ;; Return the number of wins (1/2 for a tie),
- ;; the total of the point differences, and the
- ;; scores themselves, all from strategy1's point of view.
- (values (+ (count-if #'plusp scores)
- (/ (count-if #'zerop scores) 2))
- (apply #'+ scores)
- scores)))
-
-(defun round-robin (strategies n-pairs &optional
- (n-random 10) (names strategies))
- "Play a tournament among the strategies.
- N-PAIRS = games each strategy plays as each color against
- each opponent. So with N strategies, a total of
- N*(N-1)*N-PAIRS games are played."
- (let* ((N (length strategies))
- (totals (make-array N :initial-element 0))
- (scores (make-array (list N N)
- :initial-element 0)))
- ;; Play the games
- (dotimes (i N)
- (loop for j from (+ i 1) to (- N 1) do
- (let* ((wins (random-othello-series
- (elt strategies i)
- (elt strategies j)
- n-pairs n-random))
- (losses (- (* 2 n-pairs) wins)))
- (incf (aref scores i j) wins)
- (incf (aref scores j i) losses)
- (incf (aref totals i) wins)
- (incf (aref totals j) losses))))
- ;; Print the results
- (dotimes (i N)
- (format t "~&~a~20T ~4f: " (elt names i) (elt totals i))
- (dotimes (j N)
- (format t "~4f " (if (= i j) '---
- (aref scores i j)))))))
-
-(defun mobility (player board)
- "The number of moves a player has."
- (length (legal-moves player board)))
-
projects / reversi.git / blobdiff