From: Kevin M. Rosenberg <kevin@rosenberg.net>
Date: Fri, 25 Oct 2002 08:36:42 +0000 (+0000)
Subject: r3180: *** empty log message ***
X-Git-Tag: debian-1.0.14-3~58
X-Git-Url: http://git.kpe.io/?p=reversi.git;a=commitdiff_plain;h=b29c5d666cbd1d0c08d4da49b32e4ed41c6dabba

r3180: *** empty log message ***
---

b29c5d666cbd1d0c08d4da49b32e4ed41c6dabba
diff --git a/.cvsignore b/.cvsignore
new file mode 100644
index 0000000..e5f6120
--- /dev/null
+++ b/.cvsignore
@@ -0,0 +1,2 @@
+.bin
+edge-table.dat
diff --git a/debian/changelog b/debian/changelog
new file mode 100644
index 0000000..9f0bf0e
--- /dev/null
+++ b/debian/changelog
@@ -0,0 +1,6 @@
+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
+
diff --git a/debian/control b/debian/control
new file mode 100644
index 0000000..603bedd
--- /dev/null
+++ b/debian/control
@@ -0,0 +1,18 @@
+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.
+
+
+
diff --git a/debian/copyright b/debian/copyright
new file mode 100644
index 0000000..75ecf06
--- /dev/null
+++ b/debian/copyright
@@ -0,0 +1,58 @@
+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.
diff --git a/debian/postinst b/debian/postinst
new file mode 100755
index 0000000..61fd1b8
--- /dev/null
+++ b/debian/postinst
@@ -0,0 +1,48 @@
+#! /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
+
+
diff --git a/debian/prerm b/debian/prerm
new file mode 100755
index 0000000..b947ab1
--- /dev/null
+++ b/debian/prerm
@@ -0,0 +1,42 @@
+#! /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
+
+
diff --git a/debian/rules b/debian/rules
new file mode 100755
index 0000000..f9b404b
--- /dev/null
+++ b/debian/rules
@@ -0,0 +1,68 @@
+#!/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
diff --git a/edge-table-storage.lisp b/edge-table-storage.lisp
new file mode 100644
index 0000000..34a3142
--- /dev/null
+++ b/edge-table-storage.lisp
@@ -0,0 +1,46 @@
+;;;;***************************************************************************
+;;;;
+;;;; 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))))
+
+
+
+
+
diff --git a/edge-table.lisp b/edge-table.lisp
new file mode 100644
index 0000000..ec5013c
--- /dev/null
+++ b/edge-table.lisp
@@ -0,0 +1,254 @@
+;;;;***************************************************************************
+;;;;
+;;;; 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))))
+
diff --git a/io-clim.lisp b/io-clim.lisp
new file mode 100644
index 0000000..3cd7f28
--- /dev/null
+++ b/io-clim.lisp
@@ -0,0 +1,702 @@
+;;;;***************************************************************************
+;;;;
+;;;; 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+))))))))))))))
+
+
+
diff --git a/io.lisp b/io.lisp
new file mode 100644
index 0000000..6a61dba
--- /dev/null
+++ b/io.lisp
@@ -0,0 +1,80 @@
+;;;;***************************************************************************
+;;;;
+;;;; 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)))
+
+
+       
+    
diff --git a/package.lisp b/package.lisp
new file mode 100644
index 0000000..cb7fbce
--- /dev/null
+++ b/package.lisp
@@ -0,0 +1,45 @@
+;;;;***************************************************************************
+;;;;
+;;;; 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
+))
+
diff --git a/strategies.lisp b/strategies.lisp
new file mode 100644
index 0000000..3d0570b
--- /dev/null
+++ b/strategies.lisp
@@ -0,0 +1,531 @@
+;;;;***************************************************************************
+;;;;
+;;;; 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)))
+
+  
+
+					  
+      
diff --git a/utils.lisp b/utils.lisp
new file mode 100644
index 0000000..57b64a8
--- /dev/null
+++ b/utils.lisp
@@ -0,0 +1,103 @@
+;;;;***************************************************************************
+;;;;
+;;;; 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))
+
+
+