diff options
| -rw-r--r-- | TODO | 8 | ||||
| -rw-r--r-- | chess-algebraic.el | 8 | ||||
| -rw-r--r-- | chess-display.el | 6 | ||||
| -rw-r--r-- | chess-game.el | 11 | ||||
| -rw-r--r-- | chess-pgn.el | 14 | ||||
| -rw-r--r-- | chess-ply.el | 219 | ||||
| -rw-r--r-- | chess-pos.el | 106 | ||||
| -rw-r--r-- | chess-var.el | 7 |
8 files changed, 201 insertions, 178 deletions
@@ -13,6 +13,9 @@ chess-coord needs to be applied to a larger area, and also the way highlight locations are found needs to be recalculated. +- Move keyboard shortcutting and mouse selection into their own + modules + - the game should go inactive once I lose by stalemate/checkmate - when a clock runs down, indicate this in the modeline, and all the @@ -30,7 +33,10 @@ - Add support for adjournments; also, implement this is such a way that an e-mail or postal game is basically a game that's adjourned - after every move + after every move; use BBDB if available + +- Allow databases to return a game moniker, which can be used to + reference that game again - There needs to be much more robustness; it's too easy to get the game into an unplayable state right now diff --git a/chess-algebraic.el b/chess-algebraic.el index 17d4fcc..62ccf0f 100644 --- a/chess-algebraic.el +++ b/chess-algebraic.el @@ -113,12 +113,10 @@ This regexp handles both long and short form.") (if promotion (nconc changes (list :promote (aref promotion 0)))))) - (when trust - (if mate - (nconc changes (list (if (equal mate "#") :checkmate :check)))) - (nconc changes (list :valid))) + (if (and trust mate) + (nconc changes (list (if (equal mate "#") :checkmate :check)))) - (or ply (apply 'chess-ply-create position changes))))) + (or ply (apply 'chess-ply-create position trust changes))))) (defun chess-ply-to-algebraic (ply &optional long) "Convert the given PLY to algebraic notation. diff --git a/chess-display.el b/chess-display.el index 8105664..d19a434 100644 --- a/chess-display.el +++ b/chess-display.el @@ -124,8 +124,8 @@ See `mode-line-format' for syntax details." (chess-with-current-buffer display (chess-display-set-index* nil 1) (chess-game-set-plies chess-module-game - (list ply (chess-ply-create - (chess-ply-next-pos ply)))))) + (list ply (chess-ply-create* + (chess-ply-next-pos ply) t))))) (defun chess-display-ply (display) (chess-with-current-buffer display @@ -920,7 +920,7 @@ Clicking once on a piece selects it; then click on the target location." (and (> t-piece ?a) (> s-piece ?a)))) (throw 'message (chess-string 'cannot-mount))) - (unless (setq ply (chess-ply-create position + (unless (setq ply (chess-ply-create position nil (cadr last-sel) coord)) (throw 'message (chess-string 'move-not-legal))) diff --git a/chess-game.el b/chess-game.el index 2697aec..0bdc76a 100644 --- a/chess-game.el +++ b/chess-game.el @@ -136,7 +136,7 @@ matches." (defsubst chess-game-set-start-position (game position) "Return the tags alist associated with GAME." - (chess-game-set-plies game (list (chess-ply-create position)))) + (chess-game-set-plies game (list (chess-ply-create* position)))) (defsubst chess-game-pos (game &optional index) "Return the position related to GAME's INDEX position." @@ -207,8 +207,9 @@ Optionally use the given starting POSITION. TAGS is the starting set of game tags (which can always be changed later using the various tag-related methods)." (let ((game (list nil tags nil - (list (chess-ply-create (or position - (chess-pos-create))))))) + (list (chess-ply-create* (or position + (chess-pos-create)) + (null position)))))) (dolist (tag (cons (cons "Date" (format-time-string "%Y.%m.%d")) chess-game-default-tags)) (unless (chess-game-tag game (car tag)) @@ -227,8 +228,8 @@ progress (nil), if it is drawn, resigned, mate, etc." (chess-error 'add-to-completed)) (assert (equal position (chess-ply-pos current-ply))) (chess-ply-set-changes current-ply changes) - (chess-game-add-ply game (chess-ply-create - (chess-ply-next-pos current-ply))) + (chess-game-add-ply game (chess-ply-create* + (chess-ply-next-pos current-ply) t)) (cond ((chess-ply-any-keyword ply :draw :perpetual :repetition :stalemate) (chess-game-set-tag game "Result" "1/2-1/2") diff --git a/chess-pgn.el b/chess-pgn.el index 91b9832..162d640 100644 --- a/chess-pgn.el +++ b/chess-pgn.el @@ -38,8 +38,8 @@ (goto-char (match-end 0)) (chess-game-set-tag game "Result" (match-string-no-properties 0)) (unless (eq t (car (last plies))) - (nconc plies (list (chess-ply-create - (chess-ply-next-pos (car (last plies))))))) + (nconc plies (list (chess-ply-create* + (chess-ply-next-pos (car (last plies))) t)))) (throw 'done t)) ((looking-at "{") @@ -61,8 +61,8 @@ (throw 'done t)) (t - (nconc plies (list (chess-ply-create - (chess-ply-next-pos (car (last plies)))))) + (nconc plies (list (chess-ply-create* + (chess-ply-next-pos (car (last plies))) t))) (throw 'done t))) (skip-chars-forward " \t\n"))) (cdr plies))) @@ -92,9 +92,9 @@ (chess-fen-to-pos fen) (chess-pos-copy chess-starting-position)) t) ;; set the starting position to the FEN string - (list (chess-ply-create (if fen - (chess-fen-to-pos fen) - chess-starting-position)))))) + (list (chess-ply-create* (if fen + (chess-fen-to-pos fen) + chess-starting-position) fen))))) game))) (defun chess-pgn-insert-annotations (game index ply) diff --git a/chess-ply.el b/chess-ply.el index 9830ed1..829510c 100644 --- a/chess-ply.el +++ b/chess-ply.el @@ -71,13 +71,9 @@ (defun chess-ply-keyword (ply keyword) (let ((item (memq keyword (chess-ply-changes ply)))) (if item - ;; these are special keywords which use a value argument; - ;; `which' is for disambiguating algebraic moves, `promote' - ;; indicates the piece to promote to, `white' is white's - ;; remaining time in seconds, and similarly for `black' - (if (memq keyword '(:which :promote :white :black)) - (cadr item) - t)))) + (if (eq item (last (chess-ply-changes ply))) + t + (cadr item))))) (defsubst chess-ply-source (ply) (let ((changes (chess-ply-changes ply))) @@ -99,10 +95,11 @@ ("knight" . ?n) ("bishop" . ?b))) -(defun chess-ply-create-castle (position &optional long) +(defun chess-ply-create-castle (position &optional long king-index) "Create castling changes; this function supports Fischer Random castling." (let* ((color (chess-pos-side-to-move position)) - (king (car (chess-pos-search position (if color ?K ?k)))) + (king (or king-index + (car (chess-pos-search position (if color ?K ?k))))) (king-target (chess-rf-to-index (if color 7 0) (if long 2 6))) (king-file (chess-index-file king)) @@ -113,8 +110,8 @@ (if (chess-pos-piece-p position index (if color ?R ?r)) (setq rook index file king-file) (setq file (funcall (if long '1+ '1-) file))))) - (if (and rook (chess-search-position position king-target - (if color ?K ?k))) + (if (and rook (chess-legal-plies position :any :index king + :target king-target)) (list king king-target rook (chess-rf-to-index (if color 7 0) (if long 3 5)) (if long :long-castle :castle))))) @@ -122,9 +119,13 @@ (chess-message-catalog 'english '((pawn-promote-query . "Promote pawn to queen/rook/knight/bishop? "))) -(defvar chess-ply-no-promotions nil) +(defvar chess-ply-checking-mate nil) -(defun chess-ply-create (position &rest changes) +(defsubst chess-ply-create* (position &optional direct) + (list (if direct position + (chess-pos-copy position)))) + +(defun chess-ply-create (position &optional valid-p &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 annotate the ply with :check or other modifiers as necessary. It will @@ -132,9 +133,7 @@ also extend castling, and will prompt for a promotion piece. Note: Do not pass in the rook move if CHANGES represents a castling maneuver." - (let* ((valid-p (memq :valid changes)) - (ply (cons (chess-pos-copy position) - (delq :valid changes))) + (let* ((ply (cons (chess-pos-copy position) changes)) (color (chess-pos-side-to-move position)) piece) (if (or (null changes) (symbolp (car changes))) @@ -142,91 +141,82 @@ maneuver." ;; validate that `changes' can be legally applied to the given ;; position (when (or valid-p - (member (car changes) - (chess-search-position position (cadr changes) - (chess-pos-piece position - (car changes))))) - (setq piece (chess-pos-piece position (car changes))) - - ;; is this a castling maneuver? - (if (and (= piece (if color ?K ?k)) - (not (or (memq :castle changes) - (memq :long-castle changes)))) - (let* ((target (cadr changes)) - (file (chess-index-file target)) - (long (= 2 file)) - new-changes) - (if (and (or (and (= file 6) - (chess-pos-can-castle position - (if color ?K ?k))) - (and long - (chess-pos-can-castle position - (if color ?Q ?q)))) - (setq new-changes - (chess-ply-create-castle position long))) - (setcdr ply new-changes)))) - - (when (= piece (if color ?P ?p)) - ;; is this a pawn move to the ultimate rank? if so, and we - ;; 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 - (chess-string 'pawn-promote-query) - chess-piece-name-table nil t "queen"))) - (setq new-piece - (cdr (assoc new-piece chess-piece-name-table))) - (if color - (setq new-piece (upcase new-piece))) - (nconc changes (list :promote new-piece)))) - - ;; is this an en-passant capture? - (if (= (or (chess-pos-en-passant position) 100) - (or (chess-incr-index (cadr changes) (if color 1 -1) 0) 200)) - (nconc changes (list :en-passant)))) - - (unless (or (memq :check changes) - (memq :checkmate changes) - (memq :stalemate changes)) - (let* ((next-pos (chess-ply-next-pos ply)) - (next-color (not color))) - ;; is the opponent's king in check/mate or stalemate now, as - ;; a result of the changes? - (let ((can-move - (catch 'can-move - ;; find out if any of `color's pieces can move. We - ;; start the search on the home row for that color, - ;; as it's likier to find a legal move faster. - (let ((rank (if next-color 7 0)) - (file 0)) - (while (funcall (if next-color '>= '<) rank - (if next-color 0 8)) - (while (< file 8) - (let* ((to (chess-rf-to-index rank file)) - (piece (chess-pos-piece next-pos to))) - (when (or (eq piece ? ) - (if next-color - (> piece ?a) - (< piece ?a))) - (if (chess-search-position next-pos to next-color) - (throw 'can-move t)))) - (setq file (1+ file))) - (setq file 0 rank (funcall (if next-color '1- '1+) - rank))))))) - - ;; see if anyone from the other side is attacking the king - ;; in the new position - (if (chess-search-position next-pos - (car (chess-pos-search - next-pos (if next-color ?K ?k))) - (not next-color)) - (nconc changes (list (if can-move :check :checkmate))) - ;; no, but is he in stalemate? - (unless can-move - (nconc changes (list :stalemate))))))) - + (chess-legal-plies position :any :index (car changes) + :target (cadr changes))) + (unless chess-ply-checking-mate + (setq piece (chess-pos-piece position (car changes))) + + ;; is this a castling maneuver? + (if (and (= piece (if color ?K ?k)) + (not (or (memq :castle changes) + (memq :long-castle changes)))) + (let* ((target (cadr changes)) + (file (chess-index-file target)) + (long (= 2 file)) + new-changes) + (if (and (or (and (= file 6) + (chess-pos-can-castle position + (if color ?K ?k))) + (and long + (chess-pos-can-castle position + (if color ?Q ?q)))) + (setq new-changes + (chess-ply-create-castle position long + (car changes)))) + (setcdr ply new-changes)))) + + (when (= piece (if color ?P ?p)) + ;; is this a pawn move to the ultimate rank? if so, and + ;; we haven't already been told, ask for the piece to + ;; promote it to + (if (and (not (memq :promote changes)) + (= (if color 0 7) (chess-index-rank (cadr changes)))) + (let ((new-piece (completing-read + (chess-string 'pawn-promote-query) + chess-piece-name-table nil t "queen"))) + (setq new-piece + (cdr (assoc new-piece chess-piece-name-table))) + (if color + (setq new-piece (upcase new-piece))) + (nconc changes (list :promote new-piece)))) + + ;; is this an en-passant capture? + (if (= (or (chess-pos-en-passant position) 100) + (or (chess-incr-index (cadr changes) + (if color 1 -1) 0) 200)) + (nconc changes (list :en-passant)))) + + ;; we must determine whether this ply results in a check, + ;; checkmate or stalemate + (unless (or (memq :check changes) + (memq :checkmate changes) + (memq :stalemate changes)) + (let* ((chess-ply-checking-mate t) + (next-pos (chess-ply-next-pos ply)) + (next-color (not color)) + (king (car (chess-pos-search next-pos + (if next-color ?K ?k)))) + in-check) + ;; first, see if the moves leaves the king in check. + ;; This is tested by seeing if any of the opponent's + ;; pieces can reach the king in the position that will + ;; result from this ply. If the king is in check, we + ;; will then test for checkmate by seeing if any of his + ;; subjects can move or not. That test will also + ;; confirm stalemate for us. + (if (or (setq in-check + (catch 'in-check + (chess-search-position next-pos king + (not next-color) t))) + (null (chess-legal-plies next-pos :any :index king))) + ;; is the opponent's king in check/mate or stalemate + ;; now, as a result of the changes? + (if (chess-legal-plies next-pos :any :color next-color) + (if in-check + (nconc changes (list :check))) + (nconc changes (list (if in-check + :checkmate + :stalemate)))))))) ;; return the annotated ply ply)))) @@ -235,22 +225,26 @@ 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) (defvar color) - (defvar plies)) + (defvar plies) + (defvar specific-target)) + +(defvar chess-ply-throw-if-any nil) + (defsubst chess-ply--add (rank-adj file-adj &optional pos) "This is totally a shortcut." - (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)))) + (let ((target (or pos (chess-incr-index candidate rank-adj file-adj)))) + (if (and (or (not specific-target) + (= target specific-target)) + (chess-pos-legal-moves position color target candidate)) + (if chess-ply-throw-if-any + (throw 'any-found t) + (let ((ply (chess-ply-create position t candidate target))) + (if ply + (push ply plies))))))) (defun chess-legal-plies (position &rest keywords) "Return a list of all legal plies in POSITION. @@ -261,6 +255,7 @@ KEYWORDS allowed are: :piece <piece character> :file <number 0 to 7> [can only be used if :piece is present] :index <coordinate index> + :target <specific target index> These will constrain the plies generated to those matching the above criteria." @@ -286,11 +281,11 @@ criteria." (let* ((piece (cadr (memq :piece keywords))) (color (if piece (< piece ?a) (chess-pos-side-to-move position))) + (specific-target (cadr (memq :target keywords))) (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 diff --git a/chess-pos.el b/chess-pos.el index fb8516c..3585e06 100644 --- a/chess-pos.el +++ b/chess-pos.el @@ -335,7 +335,15 @@ trying to move a blank square." (chess-message-catalog 'english '((piece-unrecognized . "Unrecognized piece identifier"))) -(defun chess-search-position (position target piece) +(eval-when-compile + (defvar candidates) + (defvar check-only)) +(defsubst chess--add-candidate (candidate) + (if check-only + (throw 'in-check t) + (push candidate candidates))) + +(defun chess-search-position (position target piece &optional check-only) "Look on POSITION from TARGET for a PIECE that can move there. This routine looks along legal paths of movement for PIECE. It differs from `chess-pos-search', which is a more basic function that @@ -359,12 +367,12 @@ indices which indicate where a piece may have moved from." ;; from any piece movement. This is useful for testing whether a ;; king is in check, for example. ((memq piece '(t nil)) - (setq candidates (list t)) - (dolist (p '(?P ?R ?N ?B ?K ?Q)) - (nconc candidates - (chess-search-position position target - (if piece p (downcase p))))) - (setq candidates (cdr candidates))) + (dolist (p (if check-only + '(?P ?R ?N ?B ?Q) + '(?P ?R ?N ?B ?Q ?K))) + (mapc 'chess--add-candidate + (chess-search-position position target + (if piece p (downcase p)))))) ;; skip erroneous space requests ((= test-piece ? )) @@ -388,30 +396,26 @@ indices which indicate where a piece may have moved from." (chess-pos-piece-p position pos (if color ?P ?p))))) (if color (> p ?a) (< p ?a))) - (let ((cands (list t))) + (progn (setq pos (chess-incr-index target (- bias) -1)) (if (and pos (chess-pos-piece-p position pos piece)) - (nconc cands (list pos))) + (chess--add-candidate pos)) (setq pos (chess-incr-index target (- bias) 1)) (if (and pos (chess-pos-piece-p position pos piece)) - (nconc cands (list pos))) - (if candidates - (nconc candidates (cdr cands)) - (setq candidates (cdr cands)))) + (chess--add-candidate pos))) (if (setq pos (chess-incr-index target (- bias) 0)) (if (chess-pos-piece-p position pos piece) - (setq candidates (list pos)) + (chess--add-candidate pos) (when (and (chess-pos-piece-p position pos ? ) (= (if color 4 3) (chess-index-rank target))) (setq pos (chess-incr-index pos (- bias) 0)) (if (and pos (chess-pos-piece-p position pos piece)) - (setq candidates (list pos))))))))) + (chess--add-candidate 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)) - (setq candidates (list t)) (dolist (dir (cond ((= test-piece ?R) '( (-1 0) @@ -432,12 +436,11 @@ indices which indicate where a piece may have moved from." (while pos (if (chess-pos-piece-p position pos piece) (progn - (nconc candidates (list pos)) + (chess--add-candidate pos) (setq pos nil)) (if (not (chess-pos-piece-p position pos ? )) (setq pos nil) - (setq pos (apply 'chess-incr-index pos dir)))))) - (setq candidates (cdr candidates))) + (setq pos (apply 'chess-incr-index pos dir))))))) ;; the king is a trivial case of the queen, except when castling ((= test-piece ?K) @@ -448,7 +451,9 @@ indices which indicate where a piece may have moved from." ;; up the current file (setq pos (apply 'chess-incr-index target (car dirs))) (if (and pos (chess-pos-piece-p position pos piece)) - (setq candidates (list pos) dirs nil) + (progn + (chess--add-candidate pos) + (setq dirs nil)) (setq dirs (cdr dirs))))) (let ((rank (if color 7 0))) @@ -474,12 +479,11 @@ indices which indicate where a piece may have moved from." (setq legal nil) (setq file (funcall (if long '1+ '1-) file)))) (if legal - (setq candidates (list (chess-rf-to-index rank 4)))))))) + (chess--add-candidate (chess-rf-to-index rank 4))))))) ;; 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) - (setq candidates (list t)) (dolist (dir '((-2 -1) (-2 1) (-1 -2) (-1 2) (1 -2) (1 2) @@ -487,8 +491,7 @@ indices which indicate where a piece may have moved from." ;; up the current file (if (and (setq pos (apply 'chess-incr-index target dir)) (chess-pos-piece-p position pos piece)) - (nconc candidates (list pos)))) - (setq candidates (cdr candidates))) + (chess--add-candidate pos)))) (t (chess-error 'piece-unrecognized))) @@ -496,28 +499,47 @@ indices which indicate where a piece may have moved from." ;; leave the king in check; castling through check has already ;; been eliminated. (if (char-valid-p piece) - (let ((cand candidates) last-cand pos king-pos) - (while cand - ;; determine the resulting position - (setq pos (chess-pos-move (chess-pos-copy position) - (car cand) target)) - ;; find the king (only once if the king isn't moving) - (if (or (null king-pos) - (eq (downcase piece) ?k)) - (setq king-pos (chess-pos-search pos (if color ?K ?k)))) - ;; can anybody from the opposite side reach him? if so, - ;; drop the candidate - (if (or (null king-pos) - (chess-search-position pos (car king-pos) (not color))) - (if last-cand - (setcdr last-cand (cdr cand)) - (setq candidates (cdr candidates))) - (setq last-cand cand)) - (setq cand (cdr cand))))) + (setq candidates + (apply 'chess-pos-legal-moves + position color target candidates))) ;; return the final list of candidate moves candidates)) +(defun chess-pos-legal-moves (position color target &rest candidates) + "Test if TARGET can legally be reached by any of CANDIDATES. +Return the list of candidates that can reach it. + +CANDIDATES is a list of position indices which indicate the piece to +be moved, and TARGET is the index of the location to be moved to. + +Note: All of the pieces specified by CANDIDATES must be of the same +type." + (let ((cand candidates) + (test-piece (if (boundp 'test-piece) + test-piece ; a performance hack for above + (upcase (chess-pos-piece position (car candidates))))) + last-cand pos king-pos) + (while cand + ;; determine the resulting position + (setq pos (chess-pos-move (chess-pos-copy position) + (car cand) target)) + ;; find the king (only once if the king isn't moving) + (if (or (null king-pos) + (= test-piece ?K)) + (setq king-pos (chess-pos-search pos (if color ?K ?k)))) + ;; can anybody from the opposite side reach him? if so, + ;; drop the candidate + (if (catch 'in-check + (chess-search-position pos (car king-pos) (not color) t)) + (if last-cand + (setcdr last-cand (cdr cand)) + (setq candidates (cdr candidates))) + (setq last-cand cand)) + (setq cand (cdr cand))) + candidates)) + + (provide 'chess-pos) ;;; chess-pos.el ends here diff --git a/chess-var.el b/chess-var.el index f5c789a..55be268 100644 --- a/chess-var.el +++ b/chess-var.el @@ -48,7 +48,8 @@ Optionally use the given starting POSITION. SEARCH-FUNC specifies the function used to test the legality of moves. TAGS is the starting set of var tags (which can always be changed later using the various tag-related methods)." - (list (chess-ply-create (or position (chess-pos-create))))) + (list (chess-ply-create* (or position (chess-pos-create)) + (null position)))) (defun chess-var-move (var ply) "Make a move in the current VAR, from FROM to TO. @@ -62,8 +63,8 @@ progress (nil), if it is drawn, resigned, mate, etc." (chess-error 'add-to-completed)) (assert (equal position (chess-ply-pos current-ply))) (chess-ply-set-changes current-ply changes) - (chess-var-add-ply var (chess-ply-create - (chess-ply-next-pos current-ply))))) + (chess-var-add-ply var (chess-ply-create* + (chess-ply-next-pos current-ply) t)))) (provide 'chess-var) |