--- /dev/null
+.bin
+edge-table.dat
--- /dev/null
+cl-othello (1.0-1) unstable; urgency=low
+
+ * Initial Release (closes: 166290)
+
+ -- Kevin M. Rosenberg <kmr@debian.org> Fri, 25 Oct 2002 01:20:07 -0600
+
--- /dev/null
+Source: cl-othello
+Section: devel
+Priority: optional
+Maintainer: Kevin M. Rosenberg <kmr@debian.org>
+Build-Depends-Indep: debhelper (>= 4.0.0)
+Standards-Version: 3.5.7.0
+
+Package: cl-othello
+Architecture: all
+Depends: ${shlibs:Depends}, common-lisp-controller (>= 3.37)
+Description: Othello game for Common Lisp
+ This package is based on Peter Norvig's othello program in the book
+ Paradigms of Artificial Intelligence. Compared to the code in the book,
+ this package employs significant optimizations and includes a CLIM-based
+ graphical user interface.
+
+
+
--- /dev/null
+This package was debianized by Kevin M. Rosenberg <kmr@debian.org> in
+Oct 2002.
+
+It was downloaded from http://reversi.b9.com/
+Upstream Authors: Kevin Rosenberg & Peter Norvig
+
+
+CL-Reversi's Copyright Statement
+--------------------------------
+
+Copyright (c) 2000-2002 Kevin Rosenberg
+Copyright (c) 1998-2002 Peter Norvig
+
+This code is free software; you can redistribute it and/or modify it
+under the terms of the version 2.1 of the GNU Lesser General Public
+License as published by the Free Software Foundation, as clarified by
+the Franz preamble to the LGPL found in
+http://opensource.franz.com/preamble.html. The preambled is copied below.
+
+This code is distributed in the hope that it will be useful,
+but without any warranty; without even the implied warranty of
+merchantability or fitness for a particular purpose. See the GNU
+Lesser General Public License for more details.
+
+The GNU Lessor General Public License can be found in your Debian file
+system in /usr/share/common-licenses/LGPL.
+
+
+
+Peter Norvig's Original Copyright
+---------------------------------
+
+Copyright (c) 1998-2002 by Peter Norvig.
+
+Permission is granted to anyone to use this software, in source or
+object code form, on any computer system, and to modify, compile,
+decompile, run, and redistribute it to anyone else, subject to the
+following restrictions:
+
+ 1. The author makes no warranty of any kind, either expressed or
+implied, about the suitability of this software for any purpose.
+
+ 2. The author accepts no liability of any kind for damages or other
+consequences of the use of this software, even if they arise from
+defects in the software.
+
+ 3. The origin of this software must not be misrepresented, either
+by explicit claim or by omission.
+
+ 4. Altered versions must be plainly marked as such, and must not be
+misrepresented as being the original software. Altered versions may be
+distributed in packages under other licenses (such as the GNU
+license).
+
+If you find this software useful, it would be nice if you let me
+(peter@norvig.com) know about it, and nicer still if you send me
+modifications that you are willing to share. However, you are not
+required to do so.
--- /dev/null
+#! /bin/sh
+# postinst script for cl-reversi
+#
+# see: dh_installdeb(1)
+
+set -e
+
+# package name according to lisp
+LISP_PKG=reversi
+
+# summary of how this script can be called:
+# * <postinst> `configure' <most-recently-configured-version>
+# * <old-postinst> `abort-upgrade' <new version>
+# * <conflictor's-postinst> `abort-remove' `in-favour' <package>
+# <new-version>
+# * <deconfigured's-postinst> `abort-deconfigure' `in-favour'
+# <failed-install-package> <version> `removing'
+# <conflicting-package> <version>
+# for details, see http://www.debian.org/doc/debian-policy/ or
+# the debian-policy package
+#
+# quoting from the policy:
+# Any necessary prompting should almost always be confined to the
+# post-installation script, and should be protected with a conditional
+# so that unnecessary prompting doesn't happen if a package's
+# installation fails and the `postinst' is called with `abort-upgrade',
+# `abort-remove' or `abort-deconfigure'.
+
+case "$1" in
+ configure)
+ /usr/sbin/register-common-lisp-source ${LISP_PKG}
+ ;;
+ abort-upgrade|abort-remove|abort-deconfigure)
+ ;;
+ *)
+ echo "postinst called with unknown argument \`$1'" >&2
+ exit 1
+ ;;
+esac
+
+# dh_installdeb will replace this with shell code automatically
+# generated by other debhelper scripts.
+
+#DEBHELPER#
+
+exit 0
+
+
--- /dev/null
+#! /bin/sh
+# prerm script for cl-reversi
+#
+# see: dh_installdeb(1)
+
+set -e
+
+# package name according to lisp
+LISP_PKG=reversi
+
+# summary of how this script can be called:
+# * <prerm> `remove'
+# * <old-prerm> `upgrade' <new-version>
+# * <new-prerm> `failed-upgrade' <old-version>
+# * <conflictor's-prerm> `remove' `in-favour' <package> <new-version>
+# * <deconfigured's-prerm> `deconfigure' `in-favour'
+# <package-being-installed> <version> `removing'
+# <conflicting-package> <version>
+# for details, see http://www.debian.org/doc/debian-policy/ or
+# the debian-policy package
+
+
+case "$1" in
+ remove|upgrade|deconfigure)
+ /usr/sbin/unregister-common-lisp-source ${LISP_PKG}
+ ;;
+ failed-upgrade)
+ ;;
+ *)
+ echo "prerm called with unknown argument \`$1'" >&2
+ exit 1
+ ;;
+esac
+
+# dh_installdeb will replace this with shell code automatically
+# generated by other debhelper scripts.
+
+#DEBHELPER#
+
+exit 0
+
+
--- /dev/null
+#!/usr/bin/make -f
+
+export DH_COMPAT=4
+
+pkg := reversi
+debpkg := cl-reversi
+
+
+clc-source := usr/share/common-lisp/source
+clc-systems := usr/share/common-lisp/systems
+clc-reversi := $(clc-source)/$(pkg)
+
+doc-dir := usr/share/doc/$(debpkg)
+
+
+configure: configure-stamp
+configure-stamp:
+ dh_testdir
+ # Add here commands to configure the package.
+
+ touch configure-stamp
+
+
+build: build-stamp
+
+build-stamp: configure-stamp
+ dh_testdir
+ # Add here commands to compile the package.
+ touch build-stamp
+
+clean:
+ dh_testdir
+ dh_testroot
+ rm -f build-stamp configure-stamp
+ # Add here commands to clean up after the build process.
+ rm -f debian/cl-reversi.postinst.* debian/cl-reversi.prerm.*
+ dh_clean
+
+install: build
+ dh_testdir
+ dh_testroot
+ dh_clean -k
+ # Add here commands to install the package into debian/reversi.
+ dh_installdirs $(clc-systems) $(clc-reversi)
+ dh_install reversi.asd $(shell echo *.lisp) $(clc-reversi)
+ dh_link $(clc-reversi)/reversi.asd $(clc-systems)/reversi.asd
+
+# Build architecture-independent files here.
+binary-indep: build install
+
+
+# Build architecture-dependent files here.
+binary-arch: build install
+ dh_testdir
+ dh_testroot
+ dh_installdocs
+ dh_installchangelogs
+ dh_strip
+ dh_compress
+ dh_fixperms
+ dh_installdeb
+ dh_shlibdeps
+ dh_gencontrol
+ dh_md5sums
+ dh_builddeb
+
+binary: binary-indep binary-arch
+.PHONY: build clean binary-indep binary-arch binary install configure
--- /dev/null
+;;;;***************************************************************************
+;;;;
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: edge-table-storage.cl
+;;;; Purpose: Store precompiled edge table for reversi
+;;;; Programer: Kevin M. Rosenberg, M.D.
+;;;; Date Started: 1 Nov 2001
+;;;; CVS Id: $Id: edge-table-storage.lisp,v 1.1 2002/10/25 08:36:42 kevin Exp $
+;;;;
+;;;;***************************************************************************
+
+(in-package :reversi)
+
+(defparameter *et-path* nil)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
+ (defun store-edge-table (et &optional (path *et-path*))
+ (with-open-file (stream path :direction :output
+ :if-exists :supersede)
+ (print (length et) stream)
+ (dotimes (i (length et))
+ (print (aref et i) stream))))
+
+ (defun load-edge-table (&optional (path *et-path*))
+ (when (probe-file path)
+ (with-open-file (stream path :direction :input)
+ (let* ((length (read stream))
+ (et (make-array length :element-type 'fixnum)))
+ (dotimes (i length)
+ (setf (aref et i) (read stream)))
+ et))))
+
+ (setq *et-path* (make-pathname :defaults *load-truename* :name nil :type nil))
+
+ (unless (probe-file *et-path*)
+ (store-edge-table (make-edge-table)))
+
+ (unless *edge-table*
+ (setq *edge-table* (load-edge-table))))
+
+
+
+
+
--- /dev/null
+;;;;***************************************************************************
+;;;;
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: edge-table.cl
+;;;; Purpose: Edge table routines for reversi
+;;;; Programer: Kevin M. Rosenberg, M.D.
+;;;; Date Started: 1 Nov 2001
+;;;; CVS Id: $Id: edge-table.lisp,v 1.1 2002/10/25 08:36:42 kevin Exp $
+;;;;
+;;;;***************************************************************************
+
+
+(in-package :reversi)
+(declaim (optimize (safety 1) (debug 3) (speed 3) (compilation-speed 0)))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defparameter *edge-and-x-lists*
+ '((22 11 12 13 14 15 16 17 18 27)
+ (72 81 82 83 84 85 86 87 88 77)
+ (22 11 21 31 41 51 61 71 81 72)
+ (27 18 28 38 48 58 68 78 88 77))
+ "The four edges (with their X-squares)."))
+
+(defparameter *top-edge* (first *edge-and-x-lists*))
+
+(defvar *edge-table* nil
+ "Array of values to player-to-move for edge positions.")
+
+;;(declaim (type (simple-array fixnum #.(expt 3 10)) *edge-table*))
+
+(defun make-edge-table ()
+ (setq *edge-table* (make-array (expt 3 10) :element-type 'fixnum
+ :adjustable nil :fill-pointer nil))
+ (init-edge-table)
+ *edge-table*)
+
+
+(defun map-edge-n-pieces (fn player board n squares index)
+ "Call fn on all edges with n pieces."
+ ;; Index counts 1 for player; 2 for opponent
+ (declare (fixnum index)
+ (type player player)
+ (type square index)
+ (type (simple-array fixnum (100)) board)
+ (list squares))
+ (cond
+ ((< (length squares) n) nil)
+ ((null squares) (funcall fn board index))
+ (t (let ((index3 (* 3 index))
+ (sq (first squares)))
+ (declare (fixnum index3 sq))
+ (map-edge-n-pieces fn player board n (rest squares) index3)
+ (when (and (> n 0) (eql (bref board sq) empty))
+ (setf (bref board sq) player)
+ (map-edge-n-pieces fn player board (- n 1) (rest squares)
+ (+ 1 index3))
+ (setf (bref board sq) (opponent player))
+ (map-edge-n-pieces fn player board (- n 1) (rest squares)
+ (+ 2 index3))
+ (setf (bref board sq) empty))))))
+
+
+
+(defun possible-edge-moves-value (player board index)
+ "Consider all possible edge moves.
+ Combine their values into a single number."
+ (declare (type board board)
+ (type player player)
+ (type square index))
+ (combine-edge-moves
+ (cons
+ (list 1.0 (aref *edge-table* index)) ;; no move
+ (loop for sq in *top-edge* ;; possible moves
+ when (= (bref board sq) empty)
+ collect (possible-edge-move player board sq)))
+ player))
+
+
+(defun edge-index (player board squares)
+ "The index counts 1 for player; 2 for opponent,
+ on each square---summed as a base 3 number."
+ (declare (type board board)
+ (type player player)
+ (type cons squares)
+ (optimize (speed 3) (safety 1)))
+ (let ((index 0))
+ (declare (fixnum index))
+ (dolist (sq squares)
+ (declare (type square sq))
+ (setq index
+ (the fixnum
+ (+
+ (the fixnum (* index 3))
+ (the fixnum (cond ((= (bref board sq) empty) 0)
+ ((= (bref board sq) player) 1)
+ (t 2)))))))
+ index))
+
+(defun possible-edge-move (player board sq)
+ "Return a (prob val) pair for a possible edge move."
+ (declare (type board board)
+ (type player player)
+ (type square sq))
+ (let ((new-board (replace-board (svref *ply-boards* player) board)))
+ (make-move sq player new-board)
+ (list (edge-move-probability player board sq)
+ (- (aref *edge-table*
+ (edge-index (opponent player)
+ new-board *top-edge*))))))
+
+(defun combine-edge-moves (possibilities player)
+ "Combine the best moves."
+ (let ((prob 1.0)
+ (val 0.0)
+ (fn (if (= player black) #'> #'<)))
+ (declare (short-float prob val))
+ (loop for pair in (sort possibilities fn :key #'second)
+ while (>= prob 0.0)
+ do (incf val (* prob (first pair) (second pair)))
+ (decf prob (* prob (first pair))))
+ (round val)))
+
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (let ((corner/xsqs '((11 . 22) (18 . 27) (81. 72) (88 . 77))))
+ (defun corner-p (sq) (assoc sq corner/xsqs))
+ (defun x-square-p (sq) (rassoc sq corner/xsqs))
+ (defun x-square-for (corner) (cdr (assoc corner corner/xsqs)))
+ (defun corner-for (xsq) (car (rassoc xsq corner/xsqs)))))
+
+(defun edge-move-probability (player board square)
+ "What's the probability that player can move to this square?"
+ (declare (type board board)
+ (type player player)
+ (type square square))
+ (cond
+ ((x-square-p square) .5) ;; X-squares
+ ((legal-p square player board) 1.0) ;; immediate capture
+ ((corner-p square) ;; move to corner depends on X-square
+ (let ((x-sq (x-square-for square)))
+ (declare (type square x-sq))
+ (cond
+ ((= (bref board x-sq) empty) .1)
+ ((= (bref board x-sq) player) 0.001)
+ (t .9))))
+ (t (/ (aref
+ '#2A((.1 .4 .7)
+ (.05 .3 *)
+ (.01 * *))
+ (count-edge-neighbors player board square)
+ (count-edge-neighbors (opponent player) board square))
+ (if (legal-p square (opponent player) board) 2 1)))))
+
+(defun count-edge-neighbors (player board square)
+ "Count the neighbors of this square occupied by player."
+ (declare (type board board)
+ (type player player)
+ (type square square))
+ (count-if #'(lambda (inc)
+ (declare (type square inc))
+ (= (bref board (+ square inc)) player))
+ '(+1 -1)))
+
+(defparameter *static-edge-table*
+ '#2A(;stab semi un
+ ( * 0 -2000) ; X
+ ( 700 * *) ; corner
+ (1200 200 -25) ; C
+ (1000 200 75) ; A
+ (1000 200 50) ; B
+ (1000 200 50) ; B
+ (1000 200 75) ; A
+ (1200 200 -25) ; C
+ ( 700 * *) ; corner
+ ( * 0 -2000) ; X
+ ))
+(declaim (type (simple-array t (* *)) *static-edge-table*))
+
+(defun static-edge-stability (player board)
+ "Compute this edge's static stability"
+ (declare (type board board)
+ (type player player))
+ (loop for sq in *top-edge*
+ for i from 0
+ sum (the fixnum
+ (cond
+ ((= (bref board sq) empty) 0)
+ ((= (bref board sq) player)
+ (aref *static-edge-table* i
+ (piece-stability board sq)))
+ (t (- (aref *static-edge-table* i
+ (piece-stability board sq))))))))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (let ((stable 0) (semi-stable 1) (unstable 2))
+ (declaim (type fixnum stable semi-stable unstable))
+
+ (defun piece-stability (board sq)
+ (declare (type board board)
+ (fixnum sq))
+ (cond
+ ((corner-p sq) stable)
+ ((x-square-p sq)
+ (if (eql (bref board (corner-for sq)) empty)
+ unstable semi-stable))
+ (t (let* ((player (bref board sq))
+ (opp (opponent player))
+ (p1 (find player board :test-not #'eql
+ :start sq :end 19))
+ (p2 (find player board :test-not #'eql
+ :start 11 :end sq
+ :from-end t)))
+ (declare (fixnum player opp))
+ (cond
+ ;; unstable pieces can be captured immediately
+ ;; by playing in the empty square
+ ((or (and (eql p1 empty) (eql p2 opp))
+ (and (eql p2 empty) (eql p1 opp)))
+ unstable)
+ ;; Semi-stable pieces might be captured
+ ((and (eql p1 opp) (eql p2 opp)
+ (find empty board :start 11 :end 19))
+ semi-stable)
+ ((and (eql p1 empty) (eql p2 empty))
+ semi-stable)
+ ;; Stable pieces can never be captured
+ (t stable))))))))
+
+
+(defun init-edge-table ()
+ "Initialize *edge-table*, starting from the empty board."
+ ;; Initialize the static values
+ (loop for n-pieces from 0 to 10 do
+ (map-edge-n-pieces
+ #'(lambda (board index)
+ (declare (type board board)
+ (fixnum index))
+ (setf (aref *edge-table* index)
+ (the fixnum (static-edge-stability black board))))
+ black (initial-board) n-pieces *top-edge* 0))
+ ;; Now iterate five times trying to improve:
+ (dotimes (i 5)
+ (declare (fixnum i))
+ ;; Do the indexes with most pieces first
+ (loop for n-pieces from 9 downto 1 do
+ (map-edge-n-pieces
+ #'(lambda (board index)
+ (declare (type board board)
+ (fixnum index))
+ (setf (aref *edge-table* index)
+ (the fixnum (possible-edge-moves-value black board index))))
+ black (initial-board) n-pieces *top-edge* 0))))
+
--- /dev/null
+;;;;***************************************************************************
+;;;;
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: io-clim.cl
+;;;; Purpose: CLIM GUI for reversi
+;;;; Programer: Kevin M. Rosenberg, M.D.
+;;;; Date Started: 1 Nov 2001
+;;;; CVS Id: $Id: io-clim.lisp,v 1.1 2002/10/25 08:36:42 kevin Exp $
+;;;;
+;;;;***************************************************************************
+
+(in-package :reversi)
+
+(defparameter cell-inner-width 40)
+(defparameter cell-inner-height 40)
+(defparameter half-cell-inner-width 20)
+(defparameter half-cell-inner-height 20)
+(defparameter line-thickness 2)
+(defparameter piece-radius 16)
+(defparameter cell-width (+ line-thickness cell-inner-width))
+(defparameter cell-height (+ line-thickness cell-inner-height))
+(defparameter label-height 42)
+(defparameter label-width 42)
+
+(defparameter board-width (+ 30 (* 8 cell-width)))
+(defparameter board-height (+ 30 (* 8 cell-height)))
+
+(defparameter status-width 300)
+
+
+(defstruct (gui-player (:constructor make-gui-player-struct))
+ id name searcher eval ply strategy start-time
+ searcher-id eval-id)
+
+(defun make-gui-player (&key id name strategy searcher-id eval-id ply)
+ (let ((p (make-gui-player-struct :id id :ply ply
+ :name name :strategy strategy
+ :searcher-id searcher-id :eval-id eval-id))
+ (search-func
+ (cond
+ ((eq searcher-id :human)
+ #'human)
+ ((eq searcher-id :minimax)
+ #'minimax-searcher)
+ ((eq searcher-id :alpha-beta)
+ #'alpha-beta-searcher)
+ ((eq searcher-id :alpha-beta2)
+ #'alpha-beta-searcher2)
+ ((eq searcher-id :alpha-beta3)
+ #'alpha-beta-searcher3)
+ ((eq searcher-id :random)
+ #'random-strategy)))
+ (eval-func
+ (cond
+ ((eq eval-id :difference)
+ #'count-difference)
+ ((eq eval-id :weighted)
+ #'weighted-squares)
+ ((eq eval-id :modified-weighted)
+ #'modified-weighted-squares)
+ ((eq eval-id :iago)
+ #'iago-eval))))
+ (unless strategy
+ (cond
+ ((eq search-func #'human)
+ )
+ ((eq search-func #'random-strategy)
+ (setf (gui-player-strategy p) search-func))
+ (t
+ (setf (gui-player-strategy p)
+ (funcall search-func ply eval-func)))))
+ p))
+
+
+(defun gui-player-human? (gp)
+ (eql (gui-player-searcher-id gp) :human))
+
+(defun current-gui-player (frame)
+ (if frame
+ (aif (reversi-game frame)
+ (cond
+ ((null (player it))
+ nil)
+ ((= (player it) black)
+ (black-player frame))
+ ((= (player it) white)
+ (white-player frame))
+ (t
+ nil))
+ nil)
+ nil))
+
+(defun current-gui-player-human? (frame)
+ #+ignore
+ (aif (current-gui-player frame)
+ (gui-player-human? it)
+ nil)
+ (gui-player-human? (current-gui-player frame))
+ )
+
+(define-application-frame reversi ()
+ ((game :initform nil
+ :accessor reversi-game)
+ (minutes :initform 30
+ :accessor minutes)
+ (black-player :initform nil
+ :accessor black-player)
+ (white-player :initform nil
+ :accessor white-player)
+ (debug-messages :initform nil
+ :accessor debug-messages)
+ (msgbar-string :initform nil
+ :accessor msgbar-string)
+ (human-time-start :initform nil
+ :accessor reversi-human-time-start))
+ (:panes
+ (board :application
+ :display-function 'draw-board
+ :text-style '(:sans-serif :bold :very-large)
+;; :incremental-redisplay t
+ :text-cursor nil
+ :background +green+
+ :borders nil
+ :scroll-bars nil
+ :width (+ label-width board-width)
+ :height (+ label-height board-height)
+ :min-width board-width
+ :min-height board-height
+ :max-width +fill+
+ :max-height +fill+
+ )
+ (status :application
+ :display-function 'draw-status
+ :text-style '(:sans-serif :bold :large)
+ :incremental-redisplay t
+ :text-cursor nil
+ :background +white+
+ :scroll-bars nil
+ :width status-width
+ :max-width +fill+
+ :max-height +fill+
+ :height :compute)
+ (history :application
+ :display-function 'draw-history
+ :text-style '(:fix :roman :normal)
+ :incremental-redisplay t
+ :text-cursor nil
+ :background +white+
+ :width 220
+ :height :compute
+ :min-width 100
+ :initial-cursor-visibility :on
+ :scroll-bars :vertical
+ :max-width +fill+
+ :max-height +fill+
+ :end-of-page-action :scroll
+ :end-of-line-action :scroll)
+ (debug-window :application
+ :display-function 'draw-debug-window
+ :text-style '(:serif :roman :normal)
+ :incremental-redisplay t
+ :text-cursor nil
+ :background +white+
+ :width :compute
+ :height :compute
+ :scroll-bars :vertical
+ :max-width +fill+
+ :max-height +fill+
+ :end-of-page-action :scroll
+ :end-of-line-action :scroll
+ )
+ (msgbar :application
+ :display-function 'draw-msgbar
+ :text-style '(:sans-serif :roman :normal)
+ :incremental-redisplay t
+ :text-cursor nil
+ :background (make-rgb-color 0.75 0.75 0.75)
+ :foreground +red+
+ :scroll-bars nil
+ :width :compute
+ :height 25
+ :max-width +fill+
+ :max-height +fill+
+ :end-of-page-action :scroll
+ :end-of-line-action :scroll))
+ (:pointer-documentation nil)
+ (:command-table (reversi
+ :inherit-from (user-command-table
+ reversi-game-table
+ reversi-help-table)
+ :menu (("Game"
+ :menu reversi-game-table
+ :mnemonic #\G
+ :documentation "Game commands")
+ ("Help"
+ :menu reversi-help-table
+ :mnemonic #\H
+ :documentation "Help Commands"))))
+ (:menu-bar t)
+ (:layouts
+ (default
+ (horizontally ()
+ (vertically ()
+ (horizontally ()
+ board status)
+ msgbar
+ debug-window)
+ history)
+ ))
+ )
+
+ ;;(:spacing 3)
+
+(defmethod frame-standard-input ((reversi reversi))
+ (get-frame-pane reversi 'debug-window))
+
+(defmethod frame-standard-output ((reversi reversi))
+ (get-frame-pane reversi 'debug-window))
+
+(defmethod run-frame-top-level :before ((reversi reversi) &key)
+ (initialize-reversi reversi))
+
+
+(defmethod read-frame-command ((reversi reversi) &key (stream *standard-input*))
+ (let ((abort-chars #+Genera '(#\Abort #\End)
+ #-Genera nil))
+ (let ((command (read-command-using-keystrokes
+ (frame-command-table reversi) abort-chars
+ :stream stream)))
+ (if (characterp command)
+ (frame-exit reversi)
+ command))))
+
+(define-presentation-type reversi-cell ()
+ :inherit-from '(integer 11 88))
+
+#-lispworks
+(define-presentation-method highlight-presentation ((type reversi-cell)
+ record stream state)
+ state
+ (multiple-value-bind (xoff yoff)
+ (convert-from-relative-to-absolute-coordinates
+ stream (output-record-parent record))
+ (with-bounding-rectangle* (left top right bottom) record
+ (draw-rectangle* stream
+ (+ left xoff) (+ top yoff)
+ (+ right xoff) (+ bottom yoff)
+ :ink +flipping-ink+))))
+
+(define-reversi-command com-select-cell ((move 'reversi-cell))
+ (with-application-frame (frame)
+ (with-slots (game) frame
+ (let ((gui-player (current-gui-player frame)))
+ (when (and game gui-player (gui-player-human? gui-player))
+ (if (not (legal-p move (gui-player-id gui-player) (board game)))
+ (set-msgbar frame
+ (format nil "Illegal move: ~a"
+ (symbol-name (88->h8 move))))
+ (progn
+ (decf (elt (clock game) (player game))
+ (- (get-internal-real-time) (gui-player-start-time gui-player)))
+ (make-move-gui game move (gui-player-id gui-player))
+ (setf (player game) (next-to-play (board game) (player game)))
+ (get-move-gui frame))))))))
+
+
+(define-presentation-to-command-translator select-cell
+ (reversi-cell com-select-cell reversi
+ :documentation "Select cell"
+ :tester ((object frame window) (cell-selectable-p object frame window)))
+ (object)
+ (list object))
+
+(defun cell-selectable-p (object frame window)
+ (when (and (eq (get-frame-pane frame 'board) window)
+ (reversi-game frame))
+ (let ((game (reversi-game frame)))
+ (if (legal-p object (player game) (board game))
+ t
+ nil))))
+
+
+
+(defun new-game-gui (frame)
+ (setf (reversi-game frame)
+ (make-game
+ (gui-player-strategy (black-player frame))
+ (gui-player-strategy (white-player frame))
+ :record-game t
+ :print nil
+ :minutes (minutes frame)))
+ (set-msgbar frame "New Game")
+ (get-move-gui frame))
+
+
+
+(defmethod initialize-reversi ((reversi reversi))
+ (setf (black-player reversi)
+ (make-gui-player :id black :searcher-id :human)
+ )
+ (setf (white-player reversi)
+ (make-gui-player :id white
+ :searcher-id :alpha-beta3
+ :eval-id :iago
+ :ply 5)))
+
+
+(defun square-number (row column)
+ (declare (fixnum row column))
+ (+ (* 10 (1+ row))
+ (1+ column)))
+
+(defmethod draw-status ((reversi reversi) stream &key max-width max-height)
+ (declare (ignore max-width max-height))
+ (let ((game (reversi-game reversi)))
+ (when game
+ (if (null (player game))
+ (progn
+ (setf (final-result game) (count-difference black (board game)))
+ (format stream "Game Over~2%"))
+ (format stream "Move Number ~d~2%" (move-number game)))
+ (format stream "Pieces~% ~a ~2d~% ~a ~2d~% Difference ~2d~2&"
+ (title-of black) (count black (board game))
+ (title-of white) (count white (board game))
+ (count-difference black (board game)))
+ (when (clock game)
+ (format stream "Time Remaining~% ~a ~a~% ~a ~a~2%"
+ (title-of black) (time-string (elt (clock game) black))
+ (title-of white) (time-string (elt (clock game) white))))
+ (let ((gui-player (current-gui-player reversi)))
+ (when (and gui-player (gui-player-human? gui-player))
+ (let ((legal-moves
+ (loop for move in (legal-moves (gui-player-id gui-player)
+ (board game))
+ collect (symbol-name (88->h8 move)))))
+ (if legal-moves
+ (format stream "Valid Moves~%~A"
+ (list-to-delimited-string legal-moves #\space)))))
+ (when (null (player game))
+ (if (plusp (final-result game))
+ (format stream "Black wins by ~d!" (final-result game))
+ (format stream "White wins by ~d!" (- 0 (final-result game)))))))))
+
+
+
+(defmethod add-debug ((reversi reversi) msg)
+ (setf (debug-messages reversi) (append (debug-messages reversi) (list msg))))
+
+(defmethod set-msgbar ((reversi reversi) msg)
+ (setf (msgbar-string reversi) msg))
+
+(defmethod draw-debug-window ((reversi reversi) stream &key max-width max-height)
+ (declare (ignore max-width max-height))
+ (filling-output (stream)
+ (dolist (msg (debug-messages reversi))
+ (princ msg stream)
+ (terpri stream))))
+
+(defmethod draw-msgbar ((reversi reversi) stream &key max-width max-height)
+ (declare (ignore max-width max-height))
+ (when (msgbar-string reversi)
+ (princ (msgbar-string reversi) stream)))
+
+
+(defmethod draw-history ((reversi reversi) stream &key max-width max-height)
+ (declare (ignore max-width max-height))
+ (let ((game (reversi-game reversi)))
+ (when (and game (> (move-number game) 1))
+ (formatting-item-list (stream :move-cursor t :row-wise nil :n-columns 1)
+ (dotimes (i (1- (move-number game)))
+ (let ((state (aref (moves game) i)))
+ (when state
+ (let ((str (format nil "~2d: ~5a ~2a"
+ (1+ i) (title-of (state-player state))
+ (88->h8 (state-move state)))))
+ (updating-output (stream :unique-id i :cache-value str)
+ (with-end-of-page-action (stream :scroll)
+ (formatting-cell (stream :align-x :right :align-y :top)
+ (format stream str)
+ (terpri stream))))))))))))
+
+#+ignore
+(defmethod draw-history ((reversi reversi) stream &key max-width max-height)
+ (declare (ignore max-width max-height))
+ (let ((game (reversi-game reversi)))
+ (when (and game (> (move-number game) 1))
+ (formatting-item-list (stream :move-cursor t :row-wise nil :n-columns 2)
+ (dotimes (i (1- (move-number game)))
+ (let ((state (aref (moves game) i)))
+ (when state
+ (let ((str (format nil "~2d: ~5a ~2a"
+ (1+ i) (title-of (state-player state))
+ (88->h8 (state-move state)))))
+ (updating-output (stream :unique-id i :cache-value str)
+ (with-end-of-page-action (stream :scroll)
+ (formatting-cell (stream :align-x :right :align-y :top)
+ (format stream str)
+ (terpri stream))))))))))))
+
+
+#|
+ (let ((viewport (window-viewport stream)))
+ (multiple-value-bind (x y) (stream-cursor-position stream)
+ (add-debug reversi (format nil "~d ~d: ~s" x y viewport))
+ (if (> y (bounding-rectangle-bottom viewport))
+ (decf y (bounding-rectangle-bottom viewport)))
+ (window-set-viewport-position stream 0 0))))))
+ |#
+
+
+
+
+(defvar *reversi-frame* nil)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defparameter *force*
+ #+(and os-threads microsoft-32)
+ t
+ #-(and os-threads microsoft-32)
+ nil))
+
+(defun g ()
+ (greversi))
+
+(defun greversi ()
+ (unless (or *force* (null *reversi-frame*))
+ (setq *reversi-frame* (make-application-frame 'reversi)))
+ (setq *reversi-frame* (run-frame 'reversi *reversi-frame*)))
+
+
+(defun run-frame (frame-name frame)
+ (flet ((do-it ()
+ (when (or *force* (null frame))
+ (setq frame (make-application-frame frame-name)))
+ (run-frame-top-level frame)))
+ #+allegro
+ (mp:process-run-function (write-to-string frame-name) #'do-it)
+ #-allegro
+ (do-it))
+ frame)
+
+
+(define-command-table reversi-game-table
+ :menu (("New" :command com-reversi-new)
+ ("Backup" :command (com-reversi-backup))
+ ("Exit" :command (com-reversi-exit))))
+
+(define-command-table reversi-help-table)
+
+
+(define-command (com-reversi-new :name "New Game"
+ :command-table reversi-game-table
+ :keystroke (:n :control)
+ :menu ("New Game"
+ :after :start
+ :documentation "New Game"))
+ ()
+ (with-application-frame (frame)
+ (new-game-gui frame)))
+
+(define-command (com-reversi-recommend :name "Recommend Move"
+ :command-table reversi-game-table
+ :keystroke (:r :control)
+ :menu ("Recommend Move"
+ :after "New Game"
+ :documentation "Recommend Move"))
+ ()
+ (with-application-frame (frame)
+ (let ((game (reversi-game frame))
+ (player (current-gui-player frame)))
+ (when (and game player)
+ (when (gui-player-human? player)
+ (let* ((port (find-port))
+ (pointer (port-pointer port)))
+ (when pointer
+ (setf (pointer-cursor pointer) :busy))
+ (set-msgbar frame "Thinking...")
+ (let ((move (funcall (iago 8) (gui-player-id player)
+ (board game))))
+ (when pointer
+ (setf (pointer-cursor pointer) :default))
+ (when move
+ (set-msgbar frame
+ (format nil "Recommend move to ~a"
+ (symbol-name (88->h8 move))))))))))))
+
+(define-command (com-reversi-backup :name "Backup Move"
+ :command-table reversi-game-table
+ :keystroke (:b :control)
+ :menu ("Backup Move"
+ :after "Recommend Move"
+ :documentation "Backup Move"))
+ ()
+ (with-application-frame (frame)
+ (let ((game (reversi-game frame)))
+ (when (and game (> (move-number game) 2))
+ (reset-game game (- (move-number game) 2))))))
+
+
+(define-command (com-reversi-exit :name "Exit"
+ :command-table reversi-game-table
+ :keystroke (:q :control)
+ :menu ("Exit"
+ :after "Backup Move"
+ :documentation "Quit application"))
+ ()
+ (clim:frame-exit clim:*application-frame*))
+
+
+(define-command (com-reversi-options :name "Game Options"
+ :command-table reversi-game-table
+ :menu ("Game Options" :documentation "Game Options"))
+ ()
+ (with-application-frame (frame)
+ (game-dialog frame)))
+
+
+
+;(define-command-table reversi-game
+; :inherit-from (reversi-game-table)
+; :inherit-menu t)
+
+;(define-command-table reversi-help)
+; :inherit-from (reversi-help-commands)
+; :inherit-menu t)
+
+(define-command (com-about :command-table reversi-help-table
+ :menu
+ ("About Reversi"
+ :after :start
+ :documentation "About Reversi"))
+ ()
+ t)
+;; (acl-clim::pop-up-about-climap-dialog *application-frame*))
+
+
+
+(defun make-move-gui (game move player)
+ (make-game-move game move player))
+
+(defun get-move-gui (frame)
+ (let ((gui-player (current-gui-player frame)))
+ (when gui-player
+ (if (gui-player-human? gui-player)
+ (setf (gui-player-start-time gui-player) (get-internal-real-time))
+ (computer-move gui-player frame)))))
+
+(defun computer-move (gui-player frame)
+ (let* ((game (reversi-game frame))
+ (port (find-port))
+ (pointer (port-pointer port)))
+ (setq pointer nil) ;; pointer causes crash in CLIM. ? port value wrong
+ (when pointer
+ (setf (pointer-cursor pointer) :busy))
+ (set-msgbar frame "Thinking...")
+ (while (eq gui-player (current-gui-player frame))
+ (setf (gui-player-start-time gui-player)
+ (get-internal-real-time))
+ (let ((move (funcall (gui-player-strategy gui-player)
+ (player game)
+ (replace-board *board* (board game)))))
+ (when (and move (legal-p move (player game) (board game)))
+ (decf (elt (clock game) (player game))
+ (- (get-internal-real-time)
+ (gui-player-start-time gui-player)))
+ (make-move-gui game move (player game))
+ (setf (player game)
+ (next-to-play (board game) (player game))))))
+ (set-msgbar frame nil)
+ (when pointer
+ (setf (pointer-cursor pointer) :default)))
+ (setq gui-player (current-gui-player frame))
+
+ (if (and gui-player (not (gui-player-human? gui-player)))
+ (redisplay-frame-pane frame (get-frame-pane frame 'board)))
+ (get-move-gui frame))
+
+
+
+
+(defun game-dialog (frame)
+ (let* ((stream (get-frame-pane frame 'debug-window))
+ ;; (white-strategy-id (white-strategy-id frame)
+ ;; (black-strategy-id (black-strategy-id frame))
+ (wh (white-player frame))
+ (bl (black-player frame))
+ (white-searcher (gui-player-searcher-id wh))
+ (white-evaluator (gui-player-eval-id wh))
+ (white-ply (gui-player-ply wh))
+ (black-searcher (gui-player-searcher-id bl))
+ (black-evaluator (gui-player-eval-id bl))
+ (black-ply (gui-player-ply bl))
+ (minutes (minutes frame)))
+
+ (accepting-values (stream :own-window t
+ :label "Reversi Parameters")
+ (setq minutes
+ (accept 'integer
+ :stream stream
+ :prompt "Maximum minutes" :default minutes))
+ (terpri stream)
+ (format stream "White Player~%")
+ (setq white-searcher
+ (accept '(member :human :random :minimax :alpha-beta3)
+ :stream stream
+ :prompt "White Player Search" :default white-searcher))
+ (terpri stream)
+ (setq white-evaluator
+ (accept '(member :difference :weighted :modified-weighted :iago)
+ :stream stream
+ :prompt "White Player Evaluator" :default white-evaluator))
+ (terpri stream)
+ (setq white-ply
+ (accept 'integer
+ :stream stream
+ :prompt "White Ply" :default white-ply))
+ (terpri stream)
+ (terpri stream)
+ (format stream "Black Player~%")
+ (terpri stream)
+ (setq black-searcher
+ (accept '(member :human :random :minimax :alpha-beta3)
+ :stream stream
+ :prompt "Black Player Search" :default black-searcher))
+ (terpri stream)
+ (setq black-evaluator
+ (accept '(member :difference :weighted :modified-weighted :iago)
+ :stream stream
+ :prompt "Black Player Evaluator" :default black-evaluator))
+ (terpri stream)
+ (setq black-ply
+ (accept 'integer
+ :stream stream
+ :prompt "Black Ply" :default black-ply))
+ (terpri stream)
+ )
+ (setf (minutes frame) minutes)
+ (setf (white-player frame) (make-gui-player :id white
+ :searcher-id white-searcher
+ :eval-id white-evaluator
+ :ply white-ply))
+ (setf (black-player frame) (make-gui-player :id black
+ :searcher-id black-searcher
+ :eval-id black-evaluator
+ :ply black-ply))
+ ))
+
+
+(defmethod draw-board ((reversi reversi) stream &key max-width max-height)
+ "This should produce a checkerboard pattern."
+ (declare (ignore max-width max-height))
+ (let ((game (reversi-game reversi)))
+ (dotimes (i 8)
+ (draw-text stream
+ (elt "abcdefgh" i)
+ (make-point
+ (+ label-width (* cell-width i)
+ half-cell-inner-width)
+ 0)
+ :align-x :center :align-y :top))
+ (dotimes (i 8)
+ (draw-text stream
+ (format nil "~d" (1+ i))
+ (make-point
+ 0
+ (+ label-height (* cell-height i)
+ half-cell-inner-height))
+ :align-x :left :align-y :center))
+ (stream-set-cursor-position stream label-width label-height)
+ (surrounding-output-with-border (stream)
+ (formatting-table (stream :y-spacing 0 :x-spacing 0)
+ (dotimes (row 8)
+ (formatting-row (stream)
+ (dotimes (column 8)
+ (let* ((cell-id (square-number row column))
+ (value
+ (if game
+ (bref (board game) cell-id)
+ empty)))
+ (updating-output (stream :unique-id cell-id
+ :cache-value value)
+ (formatting-cell (stream :align-x :right :align-y :top)
+ (with-output-as-presentation (stream cell-id 'reversi-cell)
+ (draw-rectangle* stream 0 0 cell-width cell-height :filled t :ink +green+)
+ (draw-rectangle* stream 0 0 cell-width cell-height :filled nil)
+ (cond
+ ((= value black)
+ (draw-circle*
+ stream
+ half-cell-inner-width
+ half-cell-inner-height
+ piece-radius :filled t :ink +black+))
+ ((= value white)
+ (draw-circle*
+ stream
+ half-cell-inner-width
+ half-cell-inner-height
+ piece-radius :filled t :ink +white+))))))))))))))
+
+
+
--- /dev/null
+;;;;***************************************************************************
+;;;;
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: io.cl
+;;;; Purpose: Basic Input-Output for reversi
+;;;; Programer: Kevin M. Rosenberg, M.D.
+;;;; Date Started: 1 Nov 2001
+;;;; CVS Id: $Id: io.lisp,v 1.1 2002/10/25 08:36:42 kevin Exp $
+;;;;
+;;;;***************************************************************************
+
+(in-package :reversi)
+(declaim (optimize (safety 1) (debug 3) (speed 3)))
+
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+(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 moves-to-string (moves)
+ (let (move-list)
+ (dotimes (i (length moves))
+ (push (format nil "~2d: ~a ~a~%"
+ (1+ i)
+ (title-of (nth 1 (elt moves i)))
+ (symbol-name (88->h8 (nth 0 (elt moves i)))))
+ move-list))
+ (setq move-list (nreverse move-list))
+ (list-to-delimited-string move-list #\space))))
+
+(defun human (player board)
+ "A human player for the game of Reversi"
+ (format t "~&~c to move ~a: " (name-of player)
+ (mapcar #'88->h8 (legal-moves player board)))
+ (h8->88 (read)))
+
+
+(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)))
+
+
+
+
--- /dev/null
+;;;;***************************************************************************
+;;;;
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: package.cl
+;;;; Purpose: Package definition for reversi
+;;;; Programer: Kevin M. Rosenberg
+;;;; Date Started: 1 Nov 2001
+;;;; CVS Id: $Id: package.lisp,v 1.1 2002/10/25 08:36:42 kevin Exp $
+;;;;
+;;;;***************************************************************************
+
+(declaim (optimize (speed 1) (debug 3) (safety 3)))
+
+(in-package :cl-user)
+
+
+(defpackage :reversi
+ (:nicknames :o)
+ (:use :common-lisp :common-lisp-user
+ #+clisp :ext
+ #+clim :clim
+ #+clim :clim-sys)
+ #+clim
+ (:shadowing-import-from :clim :pathname)
+ #+clim
+ (:shadowing-import-from :clim :interactive-stream-p)
+ #+clim
+ (:shadowing-import-from :clim :boolean)
+ (:export
+ #:reversi
+ #:random-reversi-series
+ #:round-robin
+ #:reversi-series
+ #:human
+ #:iago
+ #:alpha-beta-searcher
+ #:alpha-beta-searcher2
+ #:alpha-beta-searcher3
+ #:count-difference
+ #:weighted-squares
+ #:modified-weighted-squares
+ #+clim #:greversi
+))
+
--- /dev/null
+;;;;***************************************************************************
+;;;;
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: strategies.cl
+;;;; Purpose: Strategy routines for reversi
+;;;; Programer: Kevin M. Rosenberg, M.D.
+;;;; Date Started: 1 Nov 2001
+;;;; CVS Id: $Id: strategies.lisp,v 1.1 2002/10/25 08:36:42 kevin Exp $
+;;;;
+;;;;***************************************************************************
+
+(in-package :reversi)
+(declaim (optimize (safety 1) (debug 3) (speed 3) (compilation-speed 0)))
+
+
+(defun random-strategy (player board)
+ "Make any legal move."
+ (declare (type player player)
+ (type board board))
+ (random-elt (legal-moves player board)))
+
+
+(defun maximize-difference (player board)
+ "A strategy that maximizes the difference in pieces."
+ (declare (type player player)
+ (type board board))
+ (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)
+ (declare (type player player)
+ (type board 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)))
+ (declare (fixnum moves best))
+ (elt moves (position best scores)))))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defparameter *weights*
+ (make-array 100 :element-type 'fixnum
+ :fill-pointer nil :adjustable nil
+ :initial-contents
+ '(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)))
+ (declaim (type (simple-array fixnum (100)) *weights*))
+)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (setq all-squares
+ (sort (loop for i from 11 to 88
+ when (<= 1 (mod i 10) 8) collect i)
+ #'> :key #'(lambda (sq) (elt *weights* sq)))))
+
+
+(defun weighted-squares (player board)
+ "Sum of the weights of player's squares minus opponent's."
+ (declare (type player player)
+ (type board board))
+ (let ((opp (opponent player)))
+ (loop for i in all-squares
+ when (= (bref board i) player)
+ sum (aref *weights* i)
+ when (= (bref board i) opp)
+ sum (- (aref *weights* i)))))
+
+(defconstant winning-value (- most-positive-fixnum 70))
+(defconstant losing-value (+ most-negative-fixnum 70))
+
+(defun final-value (player board)
+ "Is this a win, loss, or draw for player?"
+ (declare (type player player)
+ (type board board))
+ (case (signum (count-difference player board))
+ (-1 losing-value)
+ ( 0 0)
+ (+1 winning-value)))
+
+(defun final-value-weighted (player board)
+ "Is this a win, loss, or draw for player?"
+ (declare (type player player)
+ (type board board))
+ (let ((diff (count-difference player board)))
+ (case (signum diff)
+ (-1 (+ losing-value diff))
+ ( 0 0)
+ (+1 (+ winning-value diff)))))
+
+(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."
+ (declare (type player player)
+ (type board board)
+ (fixnum ply))
+ (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)
+ (declare (type player player)
+ (type board 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."
+ (declare (type player player)
+ (type board board)
+ (fixnum achievable cutoff ply))
+ (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)))
+ (declare (type move best-move))
+ (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."
+ (declare (fixnum depth))
+ #'(lambda (player board)
+ (declare (type board board)
+ (type player player))
+ (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."
+ (declare (type player player)
+ (type board board))
+ (let ((w (weighted-squares player board)))
+ (declare (fixnum w))
+ (dolist (corner '(11 18 81 88))
+ (declare (type square corner))
+ (when (not (= (bref board corner) empty))
+ (dolist (c (neighbors corner))
+ (declare (type square c))
+ (when (not (= (bref board c) empty))
+ (incf w (* (- 5 (aref *weights* c))
+ (if (= (bref board c) player)
+ +1 -1)))))))
+ w))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+(let ((neighbor-table (make-array 100 :initial-element nil)))
+ ;; Initialize the neighbor table
+ (dolist (square all-squares)
+ (declare (type square square))
+ (dolist (dir +all-directions+)
+ (declare (type dir dir))
+ (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))))
+
+
+(defun mobility-simple (player board)
+ "The number of moves a player has."
+ (length (legal-moves player board)))
+
+
+
+(defstruct (node)
+ (square nil :type square)
+ (board nil :type board)
+ (value nil :type integer))
+
+(defun alpha-beta-searcher2 (depth eval-fn)
+ "Return a strategy that does A-B search with sorted moves."
+ #'(lambda (player board)
+ (declare (type player player)
+ (type board board))
+ (multiple-value-bind (value node)
+ (alpha-beta2
+ player (make-node :board board
+ :value (funcall eval-fn player board))
+ losing-value winning-value depth eval-fn)
+ (declare (ignore value))
+ (node-square node))))
+
+(defun alpha-beta2 (player node achievable cutoff ply eval-fn)
+ "A-B search, sorting moves by eval-fn"
+ ;; Returns two values: achievable-value and move-to-make
+ (if (= ply 0)
+ (values (node-value node) node)
+ (let* ((board (node-board node))
+ (nodes (legal-nodes player board eval-fn)))
+ (if (null nodes)
+ (if (any-legal-move? (opponent player) board)
+ (values (- (alpha-beta2 (opponent player)
+ (negate-value node)
+ (- cutoff) (- achievable)
+ (- ply 1) eval-fn))
+ nil)
+ (values (final-value player board) nil))
+ (let ((best-node (first nodes)))
+ (loop for move in nodes
+ for val = (- (alpha-beta2
+ (opponent player)
+ (negate-value move)
+ (- cutoff) (- achievable)
+ (- ply 1) eval-fn))
+ do (when (> val achievable)
+ (setf achievable val)
+ (setf best-node move))
+ until (>= achievable cutoff))
+ (values achievable best-node))))))
+
+(defun negate-value (node)
+ "Set the value of a node to its negative."
+ (setf (node-value node) (- (node-value node)))
+ node)
+
+(defun legal-nodes (player board eval-fn)
+ "Return a list of legal moves, each one packed into a node."
+ (let ((moves (legal-moves player board)))
+ (sort (map-into
+ moves
+ #'(lambda (move)
+ (let ((new-board (make-move move player
+ (copy-board board))))
+ (make-node
+ :square move :board new-board
+ :value (funcall eval-fn player new-board))))
+ moves)
+ #'> :key #'node-value)))
+
+(defun alpha-beta3 (player board achievable cutoff ply eval-fn
+ killer)
+ (declare (type board board)
+ (type player player)
+ (type fixnum achievable cutoff ply))
+ "A-B search, putting killer move first."
+ (if (= ply 0)
+ (funcall eval-fn player board)
+ (let ((moves (put-first killer (legal-moves player board))))
+ (if (null moves)
+ (if (any-legal-move? (opponent player) board)
+ (- (alpha-beta3 (opponent player) board
+ (- cutoff) (- achievable)
+ (- ply 1) eval-fn nil))
+ (final-value player board))
+ (let ((best-move (first moves))
+ (new-board (svref *ply-boards* ply))
+ (killer2 nil)
+ (killer2-val winning-value))
+ (declare (type move best-move)
+ (type board new-board)
+ (type fixnum killer2-val))
+ (loop for move in moves
+ do (multiple-value-bind (val reply)
+ (alpha-beta3
+ (opponent player)
+ (make-move move player
+ (replace-board new-board board))
+ (- cutoff) (- achievable)
+ (- ply 1) eval-fn killer2)
+ (setf val (- val))
+ (when (> val achievable)
+ (setq achievable val)
+ (setq best-move move))
+ (when (and reply (< val killer2-val))
+ (setq killer2 reply)
+ (setq killer2-val val)))
+ until (>= achievable cutoff))
+ (values achievable best-move))))))
+
+(defun alpha-beta3w (player board achievable cutoff ply eval-fn
+ killer)
+ (declare (type board board)
+ (type player player)
+ (type fixnum achievable cutoff ply)
+ (type move killer))
+ "A-B search, putting killer move first."
+ (if (= ply 0)
+ (funcall eval-fn player board)
+ (let ((moves (put-first killer (legal-moves player board))))
+ (if (null moves)
+ (if (any-legal-move? (opponent player) board)
+ (- (alpha-beta3 (opponent player) board
+ (- cutoff) (- achievable)
+ (- ply 1) eval-fn nil))
+ (final-value-weighted player board))
+ (let ((best-move (first moves))
+ (new-board (svref *ply-boards* ply))
+ (killer2 nil)
+ (killer2-val winning-value))
+ (declare (type move best-move)
+ (type board new-board)
+ (type fixnum killer2-val))
+ (loop for move in moves
+ do (multiple-value-bind (val reply)
+ (alpha-beta3
+ (opponent player)
+ (make-move move player
+ (replace-board new-board board))
+ (- cutoff) (- achievable)
+ (- ply 1) eval-fn killer2)
+ (setf val (- val))
+ (when (> val achievable)
+ (setq achievable val)
+ (setq best-move move))
+ (when (and reply (< val killer2-val))
+ (setq killer2 reply)
+ (setq killer2-val val)))
+ until (>= achievable cutoff))
+ (values achievable best-move))))))
+
+
+(defun alpha-beta-searcher3 (depth eval-fn)
+ "Return a strategy that does A-B search with killer moves."
+ #'(lambda (player board)
+ (declare (type board board)
+ (type player player))
+ (multiple-value-bind (value move)
+ (alpha-beta3 player board losing-value winning-value
+ depth eval-fn nil)
+ (declare (ignore value))
+ move)))
+
+(defun alpha-beta-searcher3w (depth eval-fn)
+ "Return a strategy that does A-B search with killer moves."
+ #'(lambda (player board)
+ (multiple-value-bind (value move)
+ (alpha-beta3w player board losing-value winning-value
+ depth eval-fn nil)
+ (declare (ignore value))
+ move)))
+
+(defun put-first (killer moves)
+ "Move the killer move to the front of moves,
+ if the killer move is in fact a legal move."
+ (if (member killer moves)
+ (cons killer (delete killer moves))
+ moves))
+
+(defun mobility (player board)
+ "Current Mobility is the number of legal moves.
+ Potential mobility is the number of blank squares
+ adjacent to an opponent that are not legal moves.
+ Returns current and potential mobility for player."
+ (declare (type board board)
+ (type player player)
+ (optimize (speed 3) (safety 0 )))
+ (let ((opp (opponent player))
+ (current 0) ; player's current mobility
+ (potential 0)) ; player's potential mobility
+ (declare (type player opp)
+ (type fixnum current potential))
+ (dolist (square all-squares)
+ (declare (type square square))
+ (when (= (bref board square) empty)
+ (cond ((legal-p square player board)
+ (incf current))
+ ((some-neighbors board opp (neighbors square))
+ (incf potential))
+ )))
+ (values current (the fixnum (+ current potential)))))
+
+
+(defun some-neighbors (board opp neighbors)
+ (declare (type board board)
+ (type player opp)
+ (type cons neighbors)
+ (optimize (speed 3) (safety 0)))
+ (block search
+ (dolist (sq neighbors)
+ (declare (type square sq))
+ (when (= (bref board sq) opp)
+ (return-from search t)))
+ (return-from search nil)))
+
+(defun edge-stability (player board)
+ "Total edge evaluation for player to move on board."
+ (declare (type board board)
+ (type player player))
+ (loop for edge-list in *edge-and-x-lists*
+ sum (aref *edge-table*
+ (edge-index player board edge-list))))
+
+(defun iago-eval (player board)
+ "Combine edge-stability, current mobility and
+ potential mobility to arrive at an evaluation."
+ ;; The three factors are multiplied by coefficients
+ ;; that vary by move number:
+ (declare (type board board)
+ (type player player))
+ (let ((c-edg (+ 312000 (* 6240 *move-number*)))
+ (c-cur (if (< *move-number* 25)
+ (+ 50000 (* 2000 *move-number*))
+ (+ 75000 (* 1000 *move-number*))))
+ (c-pot 20000))
+ (declare (fixnum c-edg c-cur c-pot))
+ (multiple-value-bind (p-cur p-pot)
+ (mobility player board)
+ (multiple-value-bind (o-cur o-pot)
+ (mobility (opponent player) board)
+ ;; Combine the three factors into one sum:
+ (+ (round (* c-edg (edge-stability player board))
+ 32000)
+ (round (* c-cur (- p-cur o-cur))
+ (+ p-cur o-cur 2))
+ (round (* c-pot (- p-pot o-pot))
+ (+ p-pot o-pot 2)))))))
+
+
+;; Strategy Functions
+
+(defun iago (depth)
+ "Use an approximation of Iago's evaluation function."
+ (alpha-beta-searcher3 depth #'iago-eval))
+
+;; Maximizer (1-ply)
+(defun mx-df ()
+ (maximizer #'count-difference))
+
+(defun mx-wt ()
+ (maximizer #'weighted-squares))
+
+(defun mx-md-wt ()
+ (maximizer #'modified-weighted-squares))
+
+;; Minimax-searcher
+
+(defun mm-df (ply)
+ (minimax-searcher ply #'count-difference))
+
+(defun mm-wt (ply)
+ (minimax-searcher ply #'weighted-squares))
+
+(defun mm-md-wt (ply)
+ (minimax-searcher ply #'modified-weighted-squares))
+
+;; Alpha-beta3 searcher
+(defun ab3-df (ply)
+ (alpha-beta-searcher3 ply #'count-difference))
+
+(defun ab3-wt (ply)
+ (alpha-beta-searcher3 ply #'weighted-squares))
+
+(defun ab3-md-wt (ply)
+ (alpha-beta-searcher3 ply #'modified-weighted-squares))
+
+
+(defun ab3w-df (ply)
+ (alpha-beta-searcher3w ply #'count-difference))
+
+(defun ab3w-wt (ply)
+ (alpha-beta-searcher3w ply #'weighted-squares))
+
+(defun ab3w-md-wt (ply)
+ (alpha-beta-searcher3w ply #'modified-weighted-squares))
+
+
+(defun rr (ply n-pairs)
+ (round-robin
+ (list #'random-strategy (ab3-df ply) (ab3-wt ply) (ab3-md-wt ply) (iago 3))
+ n-pairs
+ 10
+ '(random ab3-df ab3-wt ab3-md-wt iago)))
+
+
+
+
+
--- /dev/null
+;;;;***************************************************************************
+;;;;
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: reversi-base.cl
+;;;; Purpose: Basic functions for reversi
+;;;; Programer: Kevin M. Rosenberg, M.D.
+;;;; Date Started: 1 Nov 2001
+;;;; CVS Id: $Id: utils.lisp,v 1.1 2002/10/25 08:36:42 kevin Exp $
+;;;;
+;;;;***************************************************************************
+
+(in-package :reversi)
+(declaim (optimize (safety 1) (debug 3) (speed 3)))
+
+
+;; Anaphoric macros
+
+(defmacro aif (test then &optional else)
+ `(let ((it ,test))
+ (if it ,then ,else)))
+
+(defmacro awhen (test-form &body body)
+ `(aif ,test-form
+ (progn ,@body)))
+
+(defmacro awhile (expr &body body)
+ `(do ((it ,expr ,expr))
+ ((not it))
+ ,@body))
+
+(defmacro aand (&rest args)
+ (cond ((null args) t)
+ ((null (cdr args)) (car args))
+ (t `(aif ,(car args) (aand ,@(cdr args))))))
+
+(defmacro acond (&rest clauses)
+ (if (null clauses)
+ nil
+ (let ((cl1 (car clauses))
+ (sym (gensym)))
+ `(let ((,sym ,(car cl1)))
+ (if ,sym
+ (let ((it ,sym)) ,@(cdr cl1))
+ (acond ,@(cdr clauses)))))))
+
+(defmacro alambda (parms &body body)
+ `(labels ((self ,parms ,@body))
+ #'self))
+
+
+(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))
+
+
+(defmacro until (test &body body)
+ `(do ()
+ (,test)
+ ,@body))
+
+(defmacro while (test &body body)
+ `(do ()
+ ((not ,test))
+ ,@body))
+
+#+ignore
+(defmacro while (test &body body)
+ `(do ()
+ (not ,test)
+ ,@body))
+
+#+excl
+(defun list-to-delimited-string (list &optional (separator #\space))
+ (excl:list-to-delimited-string list separator))
+
+#-excl
+(defun list-to-delimited-string (list &optional (separator #\space))
+ (let ((output (when list (format nil "~A" (car list)))))
+ (dolist (obj (rest list))
+ (setq output (concatenate 'string output
+ (format nil "~A" separator)
+ (format nil "~A" obj))))
+ output))
+
+
+
projects / reversi.git / commitdiff