diff options
| -rw-r--r-- | chess-display.el | 16 | ||||
| -rw-r--r-- | chess-game.el | 3 | ||||
| -rw-r--r-- | chess-ply.el | 273 |
3 files changed, 153 insertions, 139 deletions
diff --git a/chess-display.el b/chess-display.el index c272a4a..69a7e47 100644 --- a/chess-display.el +++ b/chess-display.el @@ -231,8 +231,7 @@ modeline." (defun chess-display-set-index (display index) (chess-with-current-buffer display (chess-display-set-index* nil index) - (chess-display-update nil t) - (chess-display-update-modeline))) + (chess-display-update nil t))) (defsubst chess-display-index (display) (chess-with-current-buffer display @@ -244,6 +243,7 @@ modeline." (funcall chess-display-event-handler 'draw (chess-display-position nil) (chess-display-perspective nil)) + (chess-display-update-modeline) (if (and popup (not chess-display-no-popup) (chess-display-main-p nil)) (chess-display-popup nil)))) @@ -335,9 +335,6 @@ See `chess-display-type' for the different kinds of displays." ((eq event 'destroy) (chess-display-detach-game nil)) - ((eq event 'post-move) - (chess-display-update-modeline)) - ((eq event 'pass) (let ((my-color (chess-game-data game 'my-color))) (chess-game-set-data game 'my-color (not my-color)) @@ -525,8 +522,7 @@ The key bindings available in this mode are: "Just redraw the current display." (interactive) (erase-buffer) - (chess-display-update nil) - (chess-display-update-modeline)) + (chess-display-update nil)) (defsubst chess-display-active-p () "Return non-nil if the displayed chessboard reflects an active game. @@ -1041,9 +1037,9 @@ Clicking once on a piece selects it; then click on the target location." (> piece ?a) (< piece ?a)) (throw 'message (chess-string 'wrong-color))) - ;((null (chess-legal-plies position :index coord)) - ; (throw 'message (chess-string 'piece-immobile))) - ) + ((and chess-display-highlight-legal + (null (chess-legal-plies position :any :index coord))) + (throw 'message (chess-string 'piece-immobile)))) (setq chess-display-last-selected (list (point) coord)) (chess-display-highlight nil coord) (if chess-display-highlight-legal diff --git a/chess-game.el b/chess-game.el index 73176b6..55b7588 100644 --- a/chess-game.el +++ b/chess-game.el @@ -237,8 +237,7 @@ progress (nil), if it is drawn, resigned, mate, etc." (chess-game-run-hooks game 'move current-ply)))) (t - (chess-game-run-hooks game 'move current-ply) - (chess-game-run-hooks game 'post-move))))) + (chess-game-run-hooks game 'move current-ply))))) (defsubst chess-game-end (game keyword) "End the current game, by resignation, draw, etc." diff --git a/chess-ply.el b/chess-ply.el index 5d0836c..b9141c7 100644 --- a/chess-ply.el +++ b/chess-ply.el @@ -115,6 +115,11 @@ (chess-rf-to-index (if color 7 0) (if long 3 5)) (if long :long-castle :castle))))) +(chess-message-catalog 'english + '((pawn-promote-query . "Promote pawn to queen/rook/knight/bishop? "))) + +(defvar chess-ply-no-promotions nil) + (defun chess-ply-create (position &rest changes) "Create a ply from the given POSITION by applying the suppiled CHANGES. This function will guarantee the resulting ply is legal, and will also @@ -162,9 +167,10 @@ maneuver." ;; haven't already been told, ask for the piece to promote ;; it to (if (and (not (memq :promote changes)) + (not chess-ply-no-promotions) (= (if color 0 7) (chess-index-rank (cadr changes)))) (let ((new-piece (completing-read - "Promote pawn to queen/rook/knight/bishop? " + (chess-string 'pawn-promote-query) chess-piece-name-table nil t "queen"))) (setq new-piece (cdr (assoc new-piece chess-piece-name-table))) @@ -225,6 +231,8 @@ maneuver." (chess-ply-any-keyword ply :draw :perpetual :repetition :stalemate :resign :checkmate)) +(defvar chess-ply-throw-if-any nil) + (eval-when-compile (defvar position) (defvar candidate) @@ -232,15 +240,19 @@ maneuver." (defvar plies)) (defsubst chess-ply--add (rank-adj file-adj &optional pos) "This is totally a shortcut." - (push (chess-ply-create position candidate - (or pos (chess-incr-index candidate - rank-adj file-adj))) - plies)) + (let ((ply (chess-ply-create position candidate + (or pos (chess-incr-index candidate + rank-adj file-adj))))) + (when ply + (if chess-ply-throw-if-any + (throw 'any-found t)) + (push ply plies)))) (defun chess-legal-plies (position &rest keywords) "Return a list of all legal plies in POSITION. KEYWORDS allowed are: + :any return t if any piece can move at all :color <t or nil> :piece <piece character> :file <number 0 to 7> [can only be used if :piece is present] @@ -248,130 +260,137 @@ KEYWORDS allowed are: These will constrain the plies generated to those matching the above criteria." - (if (null keywords) - (let ((plies (list t))) - (dolist (p '(?P ?R ?N ?B ?K ?Q ?p ?r ?n ?b ?k ?q)) - (nconc plies (chess-legal-plies position :piece p))) - (cdr plies)) - (if (memq :color keywords) - (let ((plies (list t)) - (color (cadr (memq :color keywords)))) - (dolist (p '(?P ?R ?N ?B ?K ?Q)) - (nconc plies (chess-legal-plies position - :piece (if color p - (downcase p))))) - (cdr plies)) - (let* ((piece (cadr (memq :piece keywords))) - (color (if piece (< piece ?a) - (chess-pos-side-to-move position))) - (test-piece - (upcase (or piece - (chess-pos-piece position - (cadr (memq :index keywords)))))) - pos plies file) - ;; since we're looking for moves of a particular piece, do a - ;; more focused search - (dolist (candidate - (cond - ((setq pos (cadr (memq :index keywords))) - (list pos)) - ((setq file (cadr (memq :file keywords))) - (let (candidates) - (dotimes (rank 8) - (setq pos (chess-rf-to-index rank file)) - (if (chess-pos-piece-p position pos piece) - (push pos candidates))) - candidates)) - (t - (chess-pos-search position piece)))) - (cond - ;; pawn movement, which is diagonal 1 when taking, but forward - ;; 1 or 2 when moving (the most complex piece, actually) - ((= test-piece ?P) - (let* ((bias (if color -1 1)) - (ahead (chess-incr-index candidate bias 0)) - (2ahead (chess-incr-index candidate (if color -2 2) 0))) - (when (chess-pos-piece-p position ahead ? ) - (chess-ply--add bias 0) - (if (and (= (if color 6 1) (chess-index-rank candidate)) - (chess-pos-piece-p position 2ahead ? )) - (chess-ply--add (if color -2 2) 0))) - (when (setq pos (chess-incr-index candidate bias -1)) - (if (chess-pos-piece-p position pos (not color)) - (chess-ply--add nil nil pos)) - ;; check for en passant capture toward queenside - (if (= (or (chess-pos-en-passant position) 100) - (or (chess-incr-index pos (if color 1 -1) 0) 200)) - (chess-ply--add nil nil pos))) - (when (setq pos (chess-incr-index candidate bias 1)) + (cond + ((null keywords) + (let ((plies (list t))) + (dolist (p '(?P ?R ?N ?B ?K ?Q ?p ?r ?n ?b ?k ?q)) + (nconc plies (chess-legal-plies position :piece p))) + (cdr plies))) + ((memq :any keywords) + (let ((chess-ply-throw-if-any t)) + (catch 'any-found + (apply 'chess-legal-plies position (delq :any keywords))))) + ((memq :color keywords) + (let ((plies (list t)) + (color (cadr (memq :color keywords)))) + (dolist (p '(?P ?R ?N ?B ?K ?Q)) + (nconc plies (chess-legal-plies position + :piece (if color p + (downcase p))))) + (cdr plies))) + (t + (let* ((piece (cadr (memq :piece keywords))) + (color (if piece (< piece ?a) + (chess-pos-side-to-move position))) + (test-piece + (upcase (or piece + (chess-pos-piece position + (cadr (memq :index keywords)))))) + (chess-ply-no-promotions t) + pos plies file) + ;; since we're looking for moves of a particular piece, do a + ;; more focused search + (dolist (candidate + (cond + ((setq pos (cadr (memq :index keywords))) + (list pos)) + ((setq file (cadr (memq :file keywords))) + (let (candidates) + (dotimes (rank 8) + (setq pos (chess-rf-to-index rank file)) + (if (chess-pos-piece-p position pos piece) + (push pos candidates))) + candidates)) + (t + (chess-pos-search position piece)))) + (cond + ;; pawn movement, which is diagonal 1 when taking, but forward + ;; 1 or 2 when moving (the most complex piece, actually) + ((= test-piece ?P) + (let* ((bias (if color -1 1)) + (ahead (chess-incr-index candidate bias 0)) + (2ahead (chess-incr-index candidate (if color -2 2) 0))) + (when (chess-pos-piece-p position ahead ? ) + (chess-ply--add bias 0) + (if (and (= (if color 6 1) (chess-index-rank candidate)) + (chess-pos-piece-p position 2ahead ? )) + (chess-ply--add (if color -2 2) 0))) + (when (setq pos (chess-incr-index candidate bias -1)) + (if (chess-pos-piece-p position pos (not color)) + (chess-ply--add nil nil pos)) + ;; check for en passant capture toward queenside + (if (= (or (chess-pos-en-passant position) 100) + (or (chess-incr-index pos (if color 1 -1) 0) 200)) + (chess-ply--add nil nil pos))) + (when (setq pos (chess-incr-index candidate bias 1)) + (if (chess-pos-piece-p position pos (not color)) + (chess-ply--add nil nil pos)) + ;; check for en passant capture toward kingside + (if (= (or (chess-pos-en-passant position) 100) + (or (chess-incr-index pos (if color 1 -1) 0) 200)) + (chess-ply--add nil nil pos))))) + + ;; the rook, bishop and queen are the easiest; just look along + ;; rank and file and/or diagonal for the nearest pieces! + ((memq test-piece '(?R ?B ?Q)) + (dolist (dir (cond + ((= test-piece ?R) + '( (-1 0) + (0 -1) (0 1) + (1 0))) + ((= test-piece ?B) + '((-1 -1) (-1 1) + + (1 -1) (1 1))) + ((= test-piece ?Q) + '((-1 -1) (-1 0) (-1 1) + (0 -1) (0 1) + (1 -1) (1 0) (1 1))))) + ;; up the current file + (setq pos (apply 'chess-incr-index candidate dir)) + ;; jww (2002-04-11): In Fischer Random castling, the rook can + ;; move in wacky ways + (while pos + (if (chess-pos-piece-p position pos ? ) + (progn + (chess-ply--add nil nil pos) + (setq pos (apply 'chess-incr-index pos dir))) (if (chess-pos-piece-p position pos (not color)) (chess-ply--add nil nil pos)) - ;; check for en passant capture toward kingside - (if (= (or (chess-pos-en-passant position) 100) - (or (chess-incr-index pos (if color 1 -1) 0) 200)) - (chess-ply--add nil nil pos))))) - - ;; the rook, bishop and queen are the easiest; just look along - ;; rank and file and/or diagonal for the nearest pieces! - ((memq test-piece '(?R ?B ?Q)) - (dolist (dir (cond - ((= test-piece ?R) - '( (-1 0) - (0 -1) (0 1) - (1 0))) - ((= test-piece ?B) - '((-1 -1) (-1 1) - - (1 -1) (1 1))) - ((= test-piece ?Q) - '((-1 -1) (-1 0) (-1 1) - (0 -1) (0 1) - (1 -1) (1 0) (1 1))))) - ;; up the current file - (setq pos (apply 'chess-incr-index candidate dir)) - ;; jww (2002-04-11): In Fischer Random castling, the rook can - ;; move in wacky ways - (while pos - (if (chess-pos-piece-p position pos ? ) - (progn - (chess-ply--add nil nil pos) - (setq pos (apply 'chess-incr-index pos dir))) - (if (chess-pos-piece-p position pos (not color)) - (chess-ply--add nil nil pos)) - (setq pos nil))))) - - ;; the king is a trivial case of the queen, except when castling - ((= test-piece ?K) - (dolist (dir '((-1 -1) (-1 0) (-1 1) - (0 -1) (0 1) - (1 -1) (1 0) (1 1))) - (setq pos (apply 'chess-incr-index candidate dir)) - (if (and pos - (or (chess-pos-piece-p position pos ? ) - (chess-pos-piece-p position pos (not color)))) - (chess-ply--add nil nil pos))) - - (if (chess-pos-can-castle position (if color ?K ?k)) - (chess-ply--add 0 2)) - (if (chess-pos-can-castle position (if color ?Q ?q)) - (chess-ply--add 0 -2))) - - ;; the knight is a zesty little piece; there may be more than - ;; one, but at only one possible square in each direction - ((= test-piece ?N) - (dolist (dir '((-2 -1) (-2 1) - (-1 -2) (-1 2) - (1 -2) (1 2) - (2 -1) (2 1))) - ;; up the current file - (if (and (setq pos (apply 'chess-incr-index candidate dir)) - (or (chess-pos-piece-p position pos ? ) - (chess-pos-piece-p position pos (not color)))) - (chess-ply--add nil nil pos)))) - - (t (chess-error 'piece-unrecognized)))) - - (delq nil plies))))) + (setq pos nil))))) + + ;; the king is a trivial case of the queen, except when castling + ((= test-piece ?K) + (dolist (dir '((-1 -1) (-1 0) (-1 1) + (0 -1) (0 1) + (1 -1) (1 0) (1 1))) + (setq pos (apply 'chess-incr-index candidate dir)) + (if (and pos + (or (chess-pos-piece-p position pos ? ) + (chess-pos-piece-p position pos (not color)))) + (chess-ply--add nil nil pos))) + + (if (chess-pos-can-castle position (if color ?K ?k)) + (chess-ply--add 0 2)) + (if (chess-pos-can-castle position (if color ?Q ?q)) + (chess-ply--add 0 -2))) + + ;; the knight is a zesty little piece; there may be more than + ;; one, but at only one possible square in each direction + ((= test-piece ?N) + (dolist (dir '((-2 -1) (-2 1) + (-1 -2) (-1 2) + (1 -2) (1 2) + (2 -1) (2 1))) + ;; up the current file + (if (and (setq pos (apply 'chess-incr-index candidate dir)) + (or (chess-pos-piece-p position pos ? ) + (chess-pos-piece-p position pos (not color)))) + (chess-ply--add nil nil pos)))) + + (t (chess-error 'piece-unrecognized)))) + + (delq nil plies))))) (provide 'chess-ply) |