diff options
Diffstat (limited to 'chess-ai.el')
| -rw-r--r-- | chess-ai.el | 183 |
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))))) |