chess-ai.el: Simpler search function, progress reporter and bug fixed.

1 files changed, 107 insertions, 76 deletions

diff --git a/chess-ai.el b/chess-ai.el
index 4dca2cf..8e6452e 100644
--- a/chess-ai.el
+++ b/chess-ai.el
@@ -26,53 +26,53 @@
 (require 'chess-pos)
 (require 'chess-ply)
 (eval-when-compile
-  (require 'cl))
+  (require 'cl-lib))
 
 (defgroup chess-ai ()
-  "A simple chess engine written in elisp.
+  "A simple chess engine written in Emacs Lisp.
 
 This module does not allow for configuring search time used to calculate
 reply moves.  You can only specify the search depth (see `chess-ai-depth')."
   :group 'chess)
 
 (defcustom chess-ai-depth 2
-  "*The default depth used to prune the search tree."
+  "The default search depth used to prune the search tree."
   :group 'chess-ai
   :type 'integer)
 
 (defcustom chess-ai-pawn-value 100
-  "*Value of a Pawn."
+  "Value of a Pawn."
   :group 'chess-ai
   :type 'integer)
 
 (defcustom chess-ai-knight-value 300
-  "*Value of a Knight."
+  "Value of a Knight."
   :group 'chess-ai
   :type 'integer)
 
 (defcustom chess-ai-bishop-value 300
-  "*Value of a Bishop."
+  "Value of a Bishop."
   :group 'chess-ai
   :type 'integer)
 
 (defcustom chess-ai-rook-value 500
-  "*Value of a Rook."
+  "Value of a Rook."
   :group 'chess-ai
   :type 'intger)
 
 (defcustom chess-ai-queen-value 900
-  "*Value of a Queen."
+  "Value of a Queen."
   :group 'chess-ai
   :type 'integer)
 
 (defcustom chess-ai-passed-pawn 50
-  "*Extra Score for a passed Pawn."
+  "Extra Score for a passed Pawn."
   :group 'chess-ai
   :type 'integer)
 
-(defun chess-eval-static (position)
+(defun chess-ai-eval-static (position)
   "Calculate the static score for POSITION."
-  (assert (vectorp position))
+  (cl-assert (vectorp position))
   (let ((v 0)
 	(status (chess-pos-status position)))
     (if (eq status :checkmate)
@@ -86,21 +86,21 @@ reply moves.  You can only specify the search depth (see `chess-ai-depth')."
 	    (let ((piece (aref position i)))
 	      (unless (= piece ? )
 		(cond
-		 ((= piece ?P) (push i white-pawns) (incf v chess-ai-pawn-value))
-		 ((= piece ?p) (push i black-pawns) (decf v chess-ai-pawn-value))
-		 ((= piece ?Q) (push i white-queens) (incf v chess-ai-queen-value))
-		 ((= piece ?q) (push i black-queens) (decf v chess-ai-queen-value))
-		 ((= piece ?R) (push i white-rooks) (incf v chess-ai-rook-value))
-		 ((= piece ?r) (push i black-rooks) (decf v chess-ai-rook-value))
-		 ((= piece ?B) (push i white-bishops) (incf v chess-ai-bishop-value))
-		 ((= piece ?b) (push i black-bishops) (decf v chess-ai-bishop-value))
-		 ((= piece ?N) (push i white-knights) (incf v chess-ai-knight-value))
-		 ((= piece ?n) (push i black-knights) (decf v chess-ai-knight-value))))))
+		 ((= piece ?P) (push i white-pawns) (cl-incf v chess-ai-pawn-value))
+		 ((= piece ?p) (push i black-pawns) (cl-decf v chess-ai-pawn-value))
+		 ((= piece ?Q) (push i white-queens) (cl-incf v chess-ai-queen-value))
+		 ((= piece ?q) (push i black-queens) (cl-decf v chess-ai-queen-value))
+		 ((= piece ?R) (push i white-rooks) (cl-incf v chess-ai-rook-value))
+		 ((= piece ?r) (push i black-rooks) (cl-decf v chess-ai-rook-value))
+		 ((= piece ?B) (push i white-bishops) (cl-incf v chess-ai-bishop-value))
+		 ((= piece ?b) (push i black-bishops) (cl-decf v chess-ai-bishop-value))
+		 ((= piece ?N) (push i white-knights) (cl-incf v chess-ai-knight-value))
+		 ((= piece ?n) (push i black-knights) (cl-decf v chess-ai-knight-value))))))
 	  ;; Reward passed Pawns
 	  (when white-pawns
-	    (setq v (+ (* (length
-			   (chess-pos-passed-pawns position t white-pawns))
-			  chess-ai-passed-pawn))))
+	    (setq v (+ v (* (length
+			     (chess-pos-passed-pawns position t white-pawns))
+			    chess-ai-passed-pawn))))
 	  (when black-pawns
 	    (setq v (- v
 		       (* (length
@@ -112,61 +112,94 @@ reply moves.  You can only specify the search depth (see `chess-ai-depth')."
 	   (+
 	    v
 	    (-
-	     (length
-	      (append (when white-queens
-			(chess-legal-plies position :piece ?Q :candidates white-queens))
-		      (when white-rooks
-			(chess-legal-plies position :piece ?R :candidates white-rooks))
-		      (when white-bishops
-			(chess-legal-plies position :piece ?B :candidates white-bishops))
-		      (when white-knights
-			(chess-legal-plies position :piece ?N :candidates white-knights))))
-	     (length
-	      (append (when black-queens
-			(chess-legal-plies position :piece ?q :candidates black-queens))
-		      (when black-rooks
-			(chess-legal-plies position :piece ?r :candidates black-rooks))
-		      (when black-bishops
-			(chess-legal-plies position :piece ?b :candidates black-bishops))
-		      (when black-knights
-			(chess-legal-plies position :piece ?n :candidates black-knights)))))))
+	     (+
+	      (if white-queens
+		  (length (chess-legal-plies position :piece ?Q
+					     :candidates white-queens))
+		0)
+	      (if white-rooks
+		  (length (chess-legal-plies position :piece ?R
+					     :candidates white-rooks))
+		0)
+	      (if white-bishops
+		  (length (chess-legal-plies position :piece ?B
+					     :candidates white-bishops))
+		0)
+	      (if white-knights
+		  (length (chess-legal-plies position :piece ?N
+					     :candidates white-knights))
+		0))
+	     (+
+	      (if black-queens
+		  (length (chess-legal-plies position :piece ?q
+					     :candidates black-queens))
+		0)
+	      (if black-rooks
+		  (length (chess-legal-plies position :piece ?r
+					     :candidates black-rooks))
+		0)
+	      (if black-bishops
+		  (length (chess-legal-plies position :piece ?b
+					     :candidates black-bishops))
+		0)
+	      (if black-knights
+		  (length (chess-legal-plies position :piece ?n
+					     :candidates black-knights))
+		0)))))
+
 	  (if (chess-pos-side-to-move position)
 	      v
 	    (- v)))))))
 
-(defun chess-ai-eval (position depth alpha beta &optional line)
+(defun chess-ai-eval-1 (position depth achievable cutoff eval-fn)
+  (if (zerop depth)
+      (funcall eval-fn position)
+    (let ((plies (chess-legal-plies position
+				    :color (chess-pos-side-to-move position))))
+      (if (null plies)
+	  (funcall eval-fn position)
+	(let ((best-ply (car plies)))
+	  (cl-loop for ply in plies
+		   do (let ((value (- (chess-ai-eval-1 (chess-ply-next-pos ply)
+						       (1- depth)
+						       (- cutoff) (- achievable)
+						       eval-fn))))
+			(when (> value achievable)
+			  (setq achievable value
+				best-ply ply)))
+		   until (>= achievable cutoff))
+	  achievable)))))
+
+(defun chess-ai-eval (position depth achievable cutoff eval-fn)
   "Evaluate POSITION using a simple AlphaBeta search algorithm using at most
 DEPTH plies."
-  ;; TBD: We do far too much consing
-  (if (= depth 0)
-      (cons (chess-eval-static position) line)
+  (if (zerop depth)
+      (cons (funcall eval-fn position) position)
     (let ((plies (chess-legal-plies
-		  position :color (chess-pos-side-to-move position)))
-	  (ret (cons alpha line)))
-      (if (= (length plies) 0)
-	  (cons (chess-eval-static position) line)
-	(while plies
-	  (let* ((tmp1 (chess-ai-eval (chess-ply-next-pos (car plies))
-				       (1- depth) (- beta) (- alpha)
-				       (cons (car plies) line)))
-		 (tmp (- (car tmp1))))
-	    (if (> tmp alpha) (setq alpha tmp
-				    ret (cons tmp (cdr tmp1))))
-	    (if (>= alpha beta)
-		(setq plies nil)
-	      (setq plies (cdr plies)))))
-	ret))))
-
-(defun chess-ai-best-move (position depth &optional func)
-  "Find the best move for POSITION using `chess-ai-eval' with DEPTH.
-Returns (VALUE . LIST-OF-PLIES) where
- VALUE is the evaluated score of the move and
- LIST-OF-PLIES is the list of plies which were actually found."
-  (let ((res (chess-ai-eval position  depth -100000 100000)))
-    (cons (car res)
-	  (if (functionp func)
-	      (mapcar func (nreverse (cdr res)))
-	    (nreverse (cdr res))))))
+		  position :color (chess-pos-side-to-move position))))
+      (if (null plies)
+	  (cons (funcall eval-fn position) position)
+	(let ((progress (make-progress-reporter "Thinking..." 0 (1- (length plies))))
+	      (best-ply (car plies)))
+	  (cl-loop for i from 0
+		   for ply in plies
+		   do (let ((value (- (chess-ai-eval-1 (chess-ply-next-pos ply)
+						       (1- depth)
+						       (- cutoff) (- achievable)
+						       eval-fn))))
+			(progress-reporter-update progress i)
+			(when (> value achievable)
+			  (setq achievable value
+				best-ply ply)))
+		   until (>= achievable cutoff))
+	  (progress-reporter-done progress)
+	  (cons achievable best-ply))))))
+
+(defun chess-ai-best-move (position depth)
+  "Find the best move for POSITION using `chess-ai-eval' with DEPTH."
+  (cdr
+   (chess-ai-eval position depth (1+ most-negative-fixnum) most-positive-fixnum
+		  #'chess-ai-eval-static)))
 
 (defun chess-ai-handler (game event &rest args)
   (unless chess-engine-handling-event
@@ -188,11 +221,9 @@ Returns (VALUE . LIST-OF-PLIES) where
      ((eq event 'post-move)
       (unless (chess-game-over-p game)
 	(let (chess-display-handling-event)
-	  (message "Thinking...")
 	  (funcall chess-engine-response-handler
-		   'move (cadr (chess-ai-best-move (chess-engine-position nil)
-						   chess-ai-depth)))
-	  (message "Thinking... done"))))
+		   'move (chess-ai-best-move (chess-engine-position nil)
+						   chess-ai-depth)))))
 
      (t
       (apply 'chess-common-handler game event args)))))