diff options
| -rw-r--r-- | TODO | 88 | ||||
| -rw-r--r-- | chess-algebraic.el | 3 | ||||
| -rw-r--r-- | chess-display.el | 242 | ||||
| -rw-r--r-- | chess-game.el | 30 | ||||
| -rw-r--r-- | chess-german.el | 98 | ||||
| -rw-r--r-- | chess-ics1.el | 11 | ||||
| -rw-r--r-- | chess-images.el | 9 | ||||
| -rw-r--r-- | chess-input.el | 132 | ||||
| -rw-r--r-- | chess-pgn.el | 2 | ||||
| -rw-r--r-- | chess-plain.el | 46 | ||||
| -rw-r--r-- | chess-ply.el | 28 | ||||
| -rw-r--r-- | chess-pos.el | 78 |
12 files changed, 431 insertions, 336 deletions
@@ -1,36 +1,52 @@ -- Feature work remaining: - 2.0 - annotations - chatting - 2.x - display/database tie-in - analysis/highlight tools - bughouse/crazyhouse + Feature work remaining + + 2.0 annotations + chatting + + 2.x display/database tie-in + analysis/highlight tools + bughouse/crazyhouse ---------------------------------------------------------------------- -- Make use of the new chess-incr-index*, which does no checks + Hotlist -- Fix highlighting in chess-plain when chess-plain-spacing is set. - chess-coord needs to be applied to a larger area, and also the way - highlight locations are found needs to be recalculated. +- Make the mode-line much more informative, with information on who is + playing, etc. -- Move keyboard shortcutting and mouse selection into their own - modules +- Add an "mlang" user, and "chess" group to my laptop. -- Use chess-ply-set-keyword wherever keywords are being set now. +- Polish chess-input.el - Find a way that regexp-alist entries that only need to fire once are only scanned once. -- Extend elp.el to do any kind of memory profiling +- Make any game-modifying commands in a display use C-c C-? + +- Copy some of ics.el's nicer functionality into chess-ics.el + +- Complete the ICS12 parser, based on Mario's comments + +- Add support for ICS observing -- Queue up input that comes in from an engine, then process the queue - -- instead of using chess-engine-last-pos +- Use server-side sockets in chess-network, if Emacs supports it + +- Allow ASCII displays to use a separate frame + +- Still need to test many areas: position editing + +- Add chess-game-strip-annotations, for removing all annotations from + a game object + +- Let the user specify a default size for the chess-images display + +- Resize the chess board on a window resize event, if possible. ---------------------------------------------------------------------- + To-do List + - Need to implement the "50 moves after irreversible" draw rule - The game should go inactive once I lose by stalemate/checkmate @@ -43,7 +59,7 @@ - in chess-engine-filter and chess-ics-filter, if an error is encountered, skip that line so the same error isn't triggered again -- SPACE to pass, then try to move (against an engine) fails saying +- SPACE to pass, then try to move (against an engine) fails saying: it's not our turn to move - Add support for adjournments; also, implement this is such a way @@ -63,46 +79,23 @@ - Read-only mode needs to be more vigorous. There's nothing preventing the user from using M-x commands. -- Complete chess-pgn-mode's automatic entry - -- Make any game-modifying commands in a display use C-c C-? +- Complete chess-pgn-mode's automatic entry, using chess-input, and + making space/return perform the move - Use MIME attachments (application/x-chess-pgn) for sending e-mail chess games back and forth. -- Copy some of ics.el's nicer functionality into chess-ics.el - -- Complete the ICS12 parser, based on Mario's comments - -- Add support for ICS observing - -- Make the mode-line much more informative, with information on who is - playing, etc. - -- Use server-side sockets in chess-network, if Emacs supports it - -- Allow ASCII displays to use a separate frame - - In edit mode, mouse-2 and mouse-3 should provide a drop-down list of pieces the square can be set to. Cursor movement is really not the best for chess-images. I still need to figure out how best to handle cursor-type with that display. -- Still need to test many areas: position editing - - Implement engine options; then, in chess-puzzle set the option that tells the engine not to resign. - Remote displays are horribly insecure. -- Resize the chess board on a window resize event, if possible. - -- Add chess-game-strip-annotations, for removing all annotations from - a game object - -- Let the user specify a default size for the chess-images display - -- Port image display code to XEmacs +---------------------------------------------------------------------- Training features @@ -114,6 +107,8 @@ - Add a chess tutor program, to teach people how to play chess +---------------------------------------------------------------------- + Analysis features - Add an engine function for obtaining an evaluation of the current @@ -137,8 +132,11 @@ defense/attack/both, etc. Basically, everything that can be known about the current board, and one move ahead (on both sides). +---------------------------------------------------------------------- + BEFORE FINAL RELEASE + port the code to XEmacs profile mem profile docstring diff --git a/chess-algebraic.el b/chess-algebraic.el index b84bf7d..0bdcac8 100644 --- a/chess-algebraic.el +++ b/chess-algebraic.el @@ -148,8 +148,7 @@ If LONG is non-nil, render the move into long notation." ((= rank 1) (setq differentiator (+ (- 7 from-rank) ?1))) (t (chess-error 'could-not-diff))) - (nconc (chess-ply-changes ply) - (list :which differentiator))))) + (chess-ply-set-keyword ply :which differentiator)))) (concat (unless (= (upcase from-piece) ?P) (char-to-string (upcase from-piece))) diff --git a/chess-display.el b/chess-display.el index 037d44b..ff2da04 100644 --- a/chess-display.el +++ b/chess-display.el @@ -7,6 +7,8 @@ (require 'chess-var) (require 'chess-algebraic) (require 'chess-fen) +(require 'chess-mouse) +(require 'chess-input) (defgroup chess-display nil "Common code used by chess displays." @@ -29,7 +31,7 @@ (mode-checkmate . "CHECKMATE") (mode-resigned . "RESIGNED") (mode-stalemate . "STALEMATE") - (mode-drawn . "DRAWMN"))) + (mode-drawn . "DRAWN"))) (defcustom chess-display-mode-line-format '(" " chess-display-side-to-move " " @@ -215,8 +217,10 @@ also view the same game." "Just redraw the current display." (interactive) (chess-with-current-buffer display - (erase-buffer) - (chess-display-update nil))) + (let ((here (point))) + (erase-buffer) + (chess-display-update nil) + (goto-char here)))) (defvar chess-display-index-positions nil) @@ -265,6 +269,18 @@ If only START is given, it must be in algebraic move notation." (chess-game-move chess-module-game ply)) (error "What to do here?? NYI")))) +(defun chess-assert-can-move (position) + (if (and (chess-display-active-p) + ;; `active' means we're playing against an engine + (chess-game-data chess-module-game 'active) + (not (eq (chess-game-data chess-module-game 'my-color) + (chess-pos-side-to-move position)))) + (chess-error 'not-your-move) + (if (and (= chess-display-index + (chess-game-index chess-module-game)) + (chess-game-over-p chess-module-game)) + (chess-error 'game-is-over)))) + (defun chess-display-highlight (display &rest args) "Highlight the square at INDEX on the current position. The given highlighting MODE is used, or the default if the style you @@ -304,6 +320,31 @@ that is supported by most displays, and is the default mode." ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; +;; Default window and frame popup functions +;; + +(defun chess-display-popup-in-window () + "Popup the given DISPLAY, so that it's visible to the user." + (unless (get-buffer-window (current-buffer)) + (fit-window-to-buffer (display-buffer (current-buffer))))) + +(defun chess-display-popup-in-frame (height width &optional display) + "Popup the given DISPLAY, so that it's visible to the user." + (let ((window (get-buffer-window (current-buffer) t))) + (if window + (let ((frame (window-frame window))) + (unless (eq frame (selected-frame)) + (raise-frame frame))) + (let ((params (list (cons 'name "*Chessboard*") + (cons 'height height) + (cons 'width width)))) + (if display + (push (cons 'display display) params)) + (select-frame (make-frame params)) + (set-window-dedicated-p (selected-window) t))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ;; Event handler ;; @@ -463,7 +504,8 @@ The key bindings available in this mode are: (use-local-map chess-display-mode-map) (buffer-disable-undo) (setq buffer-auto-save-file-name nil - mode-line-format 'chess-display-mode-line-format)) + mode-line-format 'chess-display-mode-line-format) + (setq chess-input-move-function 'chess-display-move)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; @@ -750,184 +792,6 @@ to the end or beginning." ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; -;; Default window and frame popup functions -;; - -(defun chess-display-popup-in-window () - "Popup the given DISPLAY, so that it's visible to the user." - (unless (get-buffer-window (current-buffer)) - (fit-window-to-buffer (display-buffer (current-buffer))))) - -(defun chess-display-popup-in-frame (height width &optional display) - "Popup the given DISPLAY, so that it's visible to the user." - (let ((window (get-buffer-window (current-buffer) t))) - (if window - (let ((frame (window-frame window))) - (unless (eq frame (selected-frame)) - (raise-frame frame))) - (let ((params (list (cons 'name "*Chessboard*") - (cons 'height height) - (cons 'width width)))) - (if display - (push (cons 'display display) params)) - (select-frame (make-frame params)) - (set-window-dedicated-p (selected-window) t))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; Maintain a face cache for given color strings -;; - -(defvar chess-display-face-cache '((t . t))) - -(defun chess-display-get-face (color) - (or (cdr (assoc color chess-display-face-cache)) - (let ((face (make-face 'chess-display-highlight))) - (set-face-attribute face nil :background color) - (add-to-list 'chess-display-face-cache (cons color face)) - face))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; Keyboard entry of algebraic notation, using shortcutting -;; -;; This scheme was adapted from the way SCID -;; (http://scid.sourceforge.net), by Shane Hudson, behaves. It's the -;; only way to move your pieces around! -;; - -(defvar chess-move-string "") -(defvar chess-legal-moves-pos nil) -(defvar chess-legal-moves nil) - -(make-variable-buffer-local 'chess-move-string) -(make-variable-buffer-local 'chess-legal-moves-pos) -(make-variable-buffer-local 'chess-legal-moves) - -(chess-message-catalog 'english - '((not-your-move . "It is not your turn to move") - (game-is-over . "This game is over"))) - -(defun chess-display-assert-can-move (position) - (if (and (chess-display-active-p) - ;; `active' means we're playing against an engine - (chess-game-data chess-module-game 'active) - (not (eq (chess-game-data chess-module-game 'my-color) - (chess-pos-side-to-move position)))) - (chess-error 'not-your-move) - (if (and (= chess-display-index - (chess-game-index chess-module-game)) - (chess-game-over-p chess-module-game)) - (chess-error 'game-is-over)))) - -(defun chess-keyboard-test-move (move-ply) - "Return the given MOVE if it matches the user's current input." - (let* ((move (cdr move-ply)) - (i 0) (x 0) (l (length move)) - (xl (length chess-move-string)) - (match t)) - (unless (or (and (equal (downcase chess-move-string) "ok") - (string-match "\\`O-O[+#]\\'" move)) - (and (equal (downcase chess-move-string) "oq") - (string-match "\\`O-O-O[+#]\\'" move))) - (while (and (< i l) (< x xl)) - (let ((move-char (aref move i)) - (entry-char (aref chess-move-string x))) - (if (and (= move-char ?x) - (/= entry-char ?x)) - (setq i (1+ i)) - (if (/= entry-char (if (< entry-char ?a) - move-char - (downcase move-char))) - (setq match nil i l) - (setq i (1+ i) x (1+ x))))))) - (if match - move-ply))) - -(defsubst chess-keyboard-display-moves (&optional move-list) - (if (> (length chess-move-string) 0) - (message "[%s] %s" chess-move-string - (mapconcat 'cdr - (or move-list - (delq nil (mapcar 'chess-keyboard-test-move - (cdr chess-legal-moves)))) - " ")))) - -(defun chess-keyboard-shortcut-delete () - (interactive) - (when (and chess-move-string - (stringp chess-move-string) - (> (length chess-move-string) 0)) - (setq chess-move-string - (substring chess-move-string 0 (1- (length chess-move-string)))) - (chess-keyboard-display-moves))) - -(defun chess-keyboard-shortcut (&optional display-only) - (interactive) - (let* ((position (chess-display-position nil)) - (color (chess-pos-side-to-move position)) - char) - (chess-display-assert-can-move position) - (unless (memq last-command '(chess-keyboard-shortcut - chess-keyboard-shortcut-delete)) - (setq chess-move-string nil)) - (unless display-only - (setq chess-move-string - (concat chess-move-string (char-to-string last-command-char)))) - (unless (and chess-legal-moves - (eq position chess-legal-moves-pos) - (or (> (length chess-move-string) 1) - (eq (car chess-legal-moves) last-command-char))) - (setq char (if (eq (downcase last-command-char) ?o) ?k - last-command-char) - chess-legal-moves-pos position - chess-legal-moves - (cons char - (sort - (mapcar - (function - (lambda (ply) - (cons ply (chess-ply-to-algebraic ply)))) - (if (eq char ?b) - (append (chess-legal-plies - position :piece (if color ?P ?p) :file 1) - (chess-legal-plies - position :piece (if color ?B ?b))) - (if (and (>= char ?a) - (<= char ?h)) - (chess-legal-plies position - :piece (if color ?P ?p) - :file (- char ?a)) - (chess-legal-plies position - :piece (if color - (upcase char) - (downcase char)))))) - (function - (lambda (left right) - (string-lessp (cdr left) (cdr right))))))))) - (let ((moves (delq nil (mapcar 'chess-keyboard-test-move - (cdr chess-legal-moves))))) - (cond - ((or (= (length moves) 1) - ;; if there is an exact match except for case, it must be an - ;; abiguity between a bishop and a b-pawn move. In this - ;; case, always take the b-pawn move; to select the bishop - ;; move, use B to begin the keyboard shortcut - (and (= (length moves) 2) - (string= (downcase (cdr (car moves))) - (downcase (cdr (cadr moves)))) - (setq moves (cdr moves)))) - (chess-display-move nil (caar moves)) - (setq chess-move-string nil - chess-legal-moves nil - chess-legal-moves-pos nil)) - ((null moves) - (chess-keyboard-shortcut-delete)) - (t - (chess-keyboard-display-moves moves))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; ;; Mousing around on the chess-display ;; @@ -1019,6 +883,20 @@ Clicking once on a piece selects it; then click on the target location." (goto-char (posn-point (event-end event))) (chess-display-select-piece)))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Maintain a face cache for given color strings +;; + +(defvar chess-display-face-cache '((t . t))) + +(defun chess-display-get-face (color) + (or (cdr (assoc color chess-display-face-cache)) + (let ((face (make-face 'chess-display-highlight))) + (set-face-attribute face nil :background color) + (add-to-list 'chess-display-face-cache (cons color face)) + face))) + (provide 'chess-display) ;;; chess-display.el ends here diff --git a/chess-game.el b/chess-game.el index a34d6a3..43a62e5 100644 --- a/chess-game.el +++ b/chess-game.el @@ -232,24 +232,30 @@ progress (nil), if it is drawn, resigned, mate, etc." (let ((current-ply (chess-game-ply game)) (changes (chess-ply-changes ply)) (position (chess-ply-pos ply))) + (if (chess-ply-final-p current-ply) (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) t)) - (if (> (length changes) 2) - (if (chess-ply-any-keyword ply :resign :checkmate) - (let ((color (chess-game-side-to-move game))) - (chess-game-set-tag game "Result" (if color "0-1" "1-0")) - (if (chess-ply-keyword ply :resign) - (chess-game-run-hooks game 'resign color) - (chess-game-run-hooks game 'move current-ply))) - (when (chess-ply-any-keyword ply :draw :perpetual :repetition - :stalemate) - (chess-game-set-tag game "Result" "1/2-1/2") - (chess-game-run-hooks game 'drawn))) - (chess-game-run-hooks game 'move current-ply)) + + (let ((long (> (length changes) 2))) + (cond + ((and long (chess-ply-any-keyword ply :resign :checkmate)) + (let ((color (chess-game-side-to-move game))) + (chess-game-set-tag game "Result" (if color "0-1" "1-0")) + (if (chess-ply-keyword ply :resign) + (chess-game-run-hooks game 'resign color) + (chess-game-run-hooks game 'move current-ply)))) + ((and long (chess-ply-any-keyword ply :draw :perpetual :repetition + :stalemate)) + (chess-game-set-tag game "Result" "1/2-1/2") + (chess-game-run-hooks game 'drawn)) + (t + (chess-game-run-hooks game 'move current-ply)))) + (chess-game-run-hooks game 'post-move))) (defsubst chess-game-end (game keyword) diff --git a/chess-german.el b/chess-german.el index be8c720..3ada61d 100644 --- a/chess-german.el +++ b/chess-german.el @@ -1,21 +1,89 @@ (require 'chess-message) (chess-message-catalog 'german - '((queen . "Dame") - (king . "König") - (bishop . "Läufer") - (knight . "Springer") - (rook . "Turm") - (pawn . "Bauer") - (short-castle . "Kurze Rochade") - (long-castle . "Lange Rochade") - (check . "Schach") - (checkmate . "Schach matt") - (stalemate . "Patt") - (en-passant . "on possont") - (piece-moves . "%s nach %s") - (piece-takes . "%s schlägt %s auf %s"))) + '((queen . "Dame") + (king . "König") + (bishop . "Läufer") + (knight . "Springer") + (rook . "Turm") + (pawn . "Bauer") + (short-castle . "Kurze Rochade") + (long-castle . "Lange Rochade") + (check . "Schach") + (checkmate . "Schach matt") + (stalemate . "Patt") + (en-passant . "on possont") + (piece-moves . "%s nach %s") + (piece-takes . "%s schlägt %s auf %s") + + (illegal-move . "Illegal move") + (draw-offer-declined . "Your draw offer was declined") + (could-not-find-engine . "Cannot find %s executable; check `%s'") + (starting-engine-done . "Starting chess program '%s'...done") + (starting-engine . "Starting chess program '%s'...") + (chess-delete-autosave . "Delete the autosave file? ") + (chess-read-autosave . "There is a chess autosave file, read it? ") + (piece-images-loaded . "Loading chess piece images...done") + (piece-images-loading . "Loading chess piece images...") + (no-images . "Cannot find any piece images; check `chess-images-directory'") + (no-images-fallback . "Could not find suitable chess images") + (no-such-database . "There is no such chess database module '%s'") + (engine-not-running . "The engine you were using is no longer running") + (failed-start . "Failed to start chess engine process") + (opp-illegal . "Your opponent states your last command was illegal") + (opp-undo-ret . "Your opponent has retracted their request to undo %d moves") + (opp-abort-ret . "Your opponent has retracted their offer to abort") + (opp-draw-ret . "Your opponent has retracted their draw offer") + (opp-undo-dec . "Your request to undo %d moves was decline") + (opp-abort-dec . "Your offer to abort was declined") + (opp-draw-dec . "Your draw offer was declined") + (opp-undo-acc . "Request to undo %d moves was accepted") + (opp-abort-acc . "Your offer to abort was accepted") + (opp-draw-acc . "Your draw offer was accepted") + (opp-ready-a . "Your opponent is now ready to play") + (opp-ready . "Your opponent, %s, is now ready to play") + (opp-undo . "Your opponent wants to take back %d moves, accept? ") + (opp-abort . "Your opponent wants to abort this game, accept? ") + (opp-draw . "Your opponent offers a draw, accept? ") + (opp-resigned . "Your opponent has resigned") + (opp-quit . "Your opponent has quit playing") + (want-to-play-a . "Do you wish to play a chess game against an anonymous opponent? ") + (want-to-play . "Do you wish to play a chess game against %s? ") + (move-passed . "Your opponent has passed the move to you") + (now-black . "Your opponent played the first move, you are now black") + (invalid-pgn . "Received invalid PGN text") + (invalid-fen . "Received invalid FEN string: %s") + (piece-immobile . "That piece cannot move now") + (selected-empty . "You cannot select an empty square") + (wrong-color . "You cannot move your opponent's pieces") + (move-not-legal . "That is not a legal move") + (cannot-mount . "You cannot move pieces on top of each other") + (game-is-over . "This game is over") + (not-your-move . "It is not your turn to move") + (editing-directly . "Now editing position directly, use S when complete...") + (return-to-current . "Use '>' to return to the current position") + (draw-offer . "You offer a draw") + (want-to-quit . "Do you really want to quit? ") + (illegal-notation . "Illegal move notation: %s") + (no-such-style . "There is no such chessboard display style '%s'") + (mode-drawn . "DRAWN") + (mode-stalemate . "STALEMATE") + (mode-resigned . "RESIGNED") + (mode-checkmate . "CHECKMATE") + (mode-start . "START") + (mode-black . "Black") + (mode-white . "White") + (no-candidates . "There are no candidate moves for '%s'") + (could-not-diff . "Could not differentiate piece") + (could-not-clarify . "Could not determine which piece to use") + (clarify-piece . "Clarify piece to move by rank or file") + (no-such-module . "There is no module named '%s'") + (add-to-completed . "Cannot add moves to a completed game") + (undo-limit-reached . "Cannot undo further") + (pawn-promote-query . "Promote pawn to queen/rook/knight/bishop? ") + (piece-unrecognized . "Unrecognized piece identifier") + (move-from-blank . "Attempted piece move from blank square %s"))) (provide 'chess-german) -;;; chess-german.el ends here +;;; diff --git a/chess-ics1.el b/chess-ics1.el index 067a67a..4d0d35c 100644 --- a/chess-ics1.el +++ b/chess-ics1.el @@ -63,10 +63,10 @@ (defsubst chess-ics1-draw-square (pos piece index) "Draw a piece image at point on an already drawn display." (save-excursion - (goto-char pos) - (forward-char) - (delete-char 1) - (insert (chess-ics1-piece-text piece)))) + (let ((inhibit-redisplay t)) + (goto-char pos) + (delete-char 3) + (insert ? (chess-ics1-piece-text piece) ? )))) (defun chess-ics1-draw (position perspective) "Draw the given POSITION from PERSPECTIVE's point of view. @@ -76,8 +76,7 @@ PERSPECTIVE is t for white or nil for black." (erase-buffer) (let* ((inverted (not perspective)) (rank (if inverted 7 0)) - (file (if inverted 7 0)) - beg) + (file (if inverted 7 0)) beg) (insert "\n +---+---+---+---+---+---+---+---+\n") (while (if inverted (>= rank 0) (< rank 8)) (if (/= rank (if inverted 7 0)) diff --git a/chess-images.el b/chess-images.el index f92b9c7..597b2c8 100644 --- a/chess-images.el +++ b/chess-images.el @@ -415,11 +415,10 @@ This is necessary for bizzare Emacs reasons." `(("background" . ,chess-images-dark-color) ("background" . ,chess-images-light-color)))))) (if foreground - (nconc - syms - (list (nth foreground - `(("dark_piece" . ,chess-images-black-color) - ("light_piece" . ,chess-images-white-color)))))) + (nconc syms + (list (nth foreground + `(("dark_piece" . ,chess-images-black-color) + ("light_piece" . ,chess-images-white-color)))))) (if chess-images-border-width (create-image (chess-images-hack-xpm file chess-images-border-width diff --git a/chess-input.el b/chess-input.el new file mode 100644 index 0000000..9a3a28a --- /dev/null +++ b/chess-input.el @@ -0,0 +1,132 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Keyboard entry of algebraic notation, using shortcut notation +;; +;; This scheme was adapted from the way SCID +;; (http://scid.sourceforge.net), by Shane Hudson, behaves. It's the +;; only way to move your pieces around! +;; + +(defvar chess-move-string "") +(defvar chess-legal-moves-pos nil) +(defvar chess-legal-moves nil) +(defvar chess-input-move-function nil) + +(make-variable-buffer-local 'chess-move-string) +(make-variable-buffer-local 'chess-legal-moves-pos) +(make-variable-buffer-local 'chess-legal-moves) +(make-variable-buffer-local 'chess-input-move-function) + +(chess-message-catalog 'english + '((not-your-move . "It is not your turn to move") + (game-is-over . "This game is over"))) + +(defun chess-keyboard-test-move (move-ply) + "Return the given MOVE if it matches the user's current input." + (let* ((move (cdr move-ply)) + (i 0) (x 0) (l (length move)) + (xl (length chess-move-string)) + (match t)) + (unless (or (and (equal (downcase chess-move-string) "ok") + (string-match "\\`O-O[+#]?\\'" move)) + (and (equal (downcase chess-move-string) "oq") + (string-match "\\`O-O-O[+#]?\\'" move))) + (while (and (< i l) (< x xl)) + (let ((move-char (aref move i)) + (entry-char (aref chess-move-string x))) + (if (and (= move-char ?x) + (/= entry-char ?x)) + (setq i (1+ i)) + (if (/= entry-char (if (< entry-char ?a) + move-char + (downcase move-char))) + (setq match nil i l) + (setq i (1+ i) x (1+ x))))))) + (if match + move-ply))) + +(defsubst chess-keyboard-display-moves (&optional move-list) + (if (> (length chess-move-string) 0) + (message "[%s] %s" chess-move-string + (mapconcat 'cdr + (or move-list + (delq nil (mapcar 'chess-keyboard-test-move + (cdr chess-legal-moves)))) + " ")))) + +(defun chess-keyboard-shortcut-delete () + (interactive) + (when (and chess-move-string + (stringp chess-move-string) + (> (length chess-move-string) 0)) + (setq chess-move-string + (substring chess-move-string 0 (1- (length chess-move-string)))) + (chess-keyboard-display-moves))) + +(defun chess-keyboard-shortcut (&optional display-only) + (interactive) + (let* ((position (chess-display-position nil)) + (color (chess-pos-side-to-move position)) + char) + (chess-display-assert-can-move position) + (unless (memq last-command '(chess-keyboard-shortcut + chess-keyboard-shortcut-delete)) + (setq chess-move-string nil)) + (unless display-only + (setq chess-move-string + (concat chess-move-string (char-to-string last-command-char)))) + (unless (and chess-legal-moves + (eq position chess-legal-moves-pos) + (or (> (length chess-move-string) 1) + (eq (car chess-legal-moves) last-command-char))) + (setq char (if (eq (downcase last-command-char) ?o) ?k + last-command-char) + chess-legal-moves-pos position + chess-legal-moves + (cons char + (sort + (mapcar + (function + (lambda (ply) + (cons ply (chess-ply-to-algebraic ply)))) + (if (eq char ?b) + (append (chess-legal-plies + position :piece (if color ?P ?p) :file 1) + (chess-legal-plies + position :piece (if color ?B ?b))) + (if (and (>= char ?a) + (<= char ?h)) + (chess-legal-plies position + :piece (if color ?P ?p) + :file (- char ?a)) + (chess-legal-plies position + :piece (if color + (upcase char) + (downcase char)))))) + (function + (lambda (left right) + (string-lessp (cdr left) (cdr right))))))))) + (let ((moves (delq nil (mapcar 'chess-keyboard-test-move + (cdr chess-legal-moves))))) + (cond + ((or (= (length moves) 1) + ;; if there is an exact match except for case, it must be an + ;; abiguity between a bishop and a b-pawn move. In this + ;; case, always take the b-pawn move; to select the bishop + ;; move, use B to begin the keyboard shortcut + (and (= (length moves) 2) + (string= (downcase (cdr (car moves))) + (downcase (cdr (cadr moves)))) + (setq moves (cdr moves)))) + (funcall chess-input-move-function nil (caar moves)) + (setq chess-move-string nil + chess-legal-moves nil + chess-legal-moves-pos nil)) + ((null moves) + (chess-keyboard-shortcut-delete)) + (t + (chess-keyboard-display-moves moves))))) + +(provide 'chess-input) + +;;; chess-input.el ends here diff --git a/chess-pgn.el b/chess-pgn.el index 5460caf..41abf86 100644 --- a/chess-pgn.el +++ b/chess-pgn.el @@ -26,7 +26,7 @@ (goto-char (match-end 0)) (setq prevpos position) (let* ((move (match-string 0)) - (ply (chess-algebraic-to-ply position (match-string 0)))) + (ply (chess-algebraic-to-ply position move))) (unless ply (chess-error 'pgn-read-error move)) (setq position (chess-ply-next-pos ply)) diff --git a/chess-plain.el b/chess-plain.el index bc0e46f..6041dba 100644 --- a/chess-plain.el +++ b/chess-plain.el @@ -66,11 +66,31 @@ modify `chess-plain-piece-chars' to avoid real confusion.)" :type '(choice (const 'color) (const 'square-color))) ;; fails somehow -(defcustom chess-plain-spacing 0 +(defcustom chess-plain-spacing 1 "*Number of spaces between pieces." :group 'chess-plain :type 'integer) +(defface chess-plain-black-face + '((((class color) (background light)) (:foreground "Green")) + (((class color) (background dark)) (:foreground "Green")) + (t (:bold t))) + "*The face used for black pieces on the ASCII display." + :group 'chess-plain) + +(defface chess-plain-white-face + '((((class color) (background light)) (:foreground "Yellow")) + (((class color) (background dark)) (:foreground "Yellow")) + (t (:bold t))) + "*The face used for white pieces on the ASCII display." + :group 'chess-plain) + +(defface chess-plain-highlight-face + '((((class color) (background light)) (:background "#add8e6")) + (((class color) (background dark)) (:background "#add8e6"))) + "Face to use for highlighting pieces that have been selected." + :group 'chess-plain) + (defcustom chess-plain-popup-function 'chess-display-popup-in-window "The function used to popup a chess-plain display." :type 'function @@ -101,14 +121,19 @@ modify `chess-plain-piece-chars' to avoid real confusion.)" (if white-square chess-plain-white-square-char chess-plain-black-square-char) - (let ((what chess-plain-upcase-indicates) - (pchar (cdr (assq piece chess-plain-piece-chars)))) - (cond - ((eq what 'square-color) - (if white-square - (downcase pchar) - (upcase pchar))) - (t pchar)))))) + (let* ((what chess-plain-upcase-indicates) + (pchar (cdr (assq piece chess-plain-piece-chars))) + (piece (cond + ((eq what 'square-color) + (if white-square + (downcase pchar) + (upcase pchar))) + (t pchar))) + (p (char-to-string piece))) + (add-text-properties 0 1 (list 'face (if (> piece ?a) + 'chess-ics1-black-face + 'chess-ics1-white-face)) p) + p)))) (defsubst chess-plain-draw-square (pos piece index) "Draw a piece image at point on an already drawn display." @@ -126,8 +151,7 @@ PERSPECTIVE is t for white or nil for black." (erase-buffer) (let* ((inverted (not perspective)) (rank (if inverted 7 0)) - (file (if inverted 7 0)) - beg) + (file (if inverted 7 0)) beg) (if chess-plain-draw-border (insert ? (nth 0 chess-plain-border-chars) (make-string (+ 8 (* 7 chess-plain-spacing)) diff --git a/chess-ply.el b/chess-ply.el index f44553b..27154bc 100644 --- a/chess-ply.el +++ b/chess-ply.el @@ -107,8 +107,7 @@ (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 (or king-index - (car (chess-pos-search position (if color ?K ?k))))) + (king (or king-index (chess-pos-king-index position color))) (king-target (chess-rf-to-index (if color 7 0) (if long 2 6))) (king-file (chess-index-file king)) @@ -203,9 +202,10 @@ maneuver." (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) + (king (chess-pos-king-index next-pos next-color)) + (in-check (catch 'in-check + (chess-search-position next-pos king + (not next-color) t)))) ;; 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 @@ -213,10 +213,7 @@ maneuver." ;; 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))) + (if (or in-check (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? @@ -245,7 +242,7 @@ maneuver." (defsubst chess-ply--add (rank-adj file-adj &optional pos) "This is totally a shortcut." - (let ((target (or pos (chess-incr-index candidate rank-adj file-adj)))) + (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 @@ -320,10 +317,10 @@ criteria." (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) + (chess-ply--add bias 0 ahead) (if (and (= (if color 6 1) (chess-index-rank candidate)) - (chess-pos-piece-p position 2ahead ? )) - (chess-ply--add (if color -2 2) 0))) + 2ahead (chess-pos-piece-p position 2ahead ? )) + (chess-ply--add (if color -2 2) 0 2ahead))) (when (setq pos (chess-incr-index candidate bias -1)) (if (chess-pos-piece-p position pos (not color)) (chess-ply--add nil nil pos)) @@ -374,9 +371,8 @@ criteria." (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)))) + (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)) diff --git a/chess-pos.el b/chess-pos.el index 9564d6d..d016eef 100644 --- a/chess-pos.el +++ b/chess-pos.el @@ -106,7 +106,7 @@ "Return the piece on POSITION at INDEX." (aref position index)) -(defsubst chess-pos-king-pos (position color) +(defsubst chess-pos-king-index (position color) (aref position (if color 72 73))) (defsubst chess-pos-set-king-pos (position color index) @@ -176,7 +176,7 @@ Also, EPD evaluation numbers/strings can be set here." (nconc ann (list annotation)) (aset position 71 (list annotation))))) -(defun chess-pos-copy (position) +(defsubst chess-pos-copy (position) "Create a new chess position, set at the starting position. If BLANK is non-nil, all of the squares will be empty. The current side-to-move always starts as white." @@ -188,7 +188,7 @@ The current side-to-move always starts as white." (chess-pos-set-status copy (copy-alist i))) copy)) -(defun chess-pos-create (&optional blank) +(defsubst chess-pos-create (&optional blank) "Create a new chess position, set at the starting position. If BLANK is non-nil, all of the squares will be empty. The current side-to-move is always white." @@ -242,17 +242,11 @@ color will do." "Look on POSITION anywhere for PIECE-OR-COLOR, returning all coordinates. If PIECE-OR-COLOR is t for white or nil for black, any piece of that color will do." - (cond - ((eq piece-or-color ?K) - (list (chess-pos-king-pos position t))) - ((eq piece-or-color ?k) - (list (chess-pos-king-pos position nil))) - (t - (let (found) - (dotimes (i 64) - (if (chess-pos-piece-p position i piece-or-color) - (push i found))) - found)))) + (let (found) + (dotimes (i 64) + (if (chess-pos-piece-p position i piece-or-color) + (push i found))) + found)) (defsubst chess-pos-to-string (position &optional full) (chess-pos-to-fen position full)) @@ -304,9 +298,9 @@ trying to move a blank square." ;; if the move was en-passant, remove the captured pawn (if (memq :en-passant changes) - (chess-pos-set-piece position (chess-incr-index (cadr changes) - (if color 1 -1) 0) - ? )) + (chess-pos-set-piece position + (chess-incr-index (cadr changes) + (if color 1 -1) 0) ? )) ;; once a piece is moved, en passant is no longer available (chess-pos-set-en-passant position nil) @@ -321,7 +315,7 @@ trying to move a blank square." (chess-pos-set-can-castle position (if color ?Q ?q) nil)) ((= piece ?r) - (let ((king (car (chess-pos-search position (if color ?K ?k))))) + (let ((king (chess-pos-king-index position color))) (if (and (chess-pos-can-castle position (if color ?K ?k)) (< (chess-index-file (car changes)) king)) (chess-pos-set-can-castle position (if color ?K ?k) nil) @@ -413,7 +407,7 @@ indices which indicate where a piece may have moved from." (and (= (chess-index-rank target) (if color 2 5)) ;; make this fail if no en-passant is possible (= (or (chess-pos-en-passant position) 100) - (chess-incr-index target (if color 1 -1) 0)) + (or (chess-incr-index target (if color 1 -1) 0) 200)) (or (and (setq pos (chess-incr-index target (if color 1 -1) -1)) (chess-pos-piece-p position pos @@ -424,21 +418,20 @@ indices which indicate where a piece may have moved from." (if color ?P ?p))))) (if color (> p ?a) (< p ?a))) (progn - (setq pos (chess-incr-index target (- bias) -1)) - (if (and pos (chess-pos-piece-p position pos piece)) + (if (and (setq pos (chess-incr-index target (- bias) -1)) + (chess-pos-piece-p position pos piece)) (chess--add-candidate pos)) - (setq pos (chess-incr-index target (- bias) 1)) - (if (and pos (chess-pos-piece-p position pos piece)) + (if (and (setq pos (chess-incr-index target (- bias) 1)) + (chess-pos-piece-p position pos piece)) (chess--add-candidate pos))) (if (setq pos (chess-incr-index target (- bias) 0)) (if (chess-pos-piece-p position pos piece) (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)) - (chess--add-candidate pos)))))))) + (if (and (chess-pos-piece-p position pos ? ) + (= (if color 4 3) (chess-index-rank target)) + (setq pos (chess-incr-index pos (- bias) 0)) + (chess-pos-piece-p position pos piece)) + (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! @@ -465,9 +458,8 @@ indices which indicate where a piece may have moved from." (progn (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 pos (and (chess-pos-piece-p position pos ? ) + (apply 'chess-incr-index pos dir))))))) ;; the king is a trivial case of the queen, except when castling ((= test-piece ?K) @@ -492,7 +484,7 @@ indices which indicate where a piece may have moved from." (chess-pos-can-castle position (if color ?K ?k))) (and (equal target (chess-rf-to-index rank 2)) (chess-pos-can-castle position (if color ?Q ?q))))) - (let* ((king (car (chess-pos-search position piece))) + (let* ((king (chess-pos-king-index position color)) (king-file (chess-index-file king)) (long (= 2 (chess-index-file target))) (file (if long 1 6)) @@ -542,28 +534,32 @@ 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 (upcase (chess-pos-piece position (car candidates)))) - last-cand pos king-pos) + (piece (chess-pos-piece position (car candidates))) + (pos (chess-pos-copy position)) + last-cand king-pos) (while cand ;; determine the resulting position - (setq pos (chess-pos-move (chess-pos-copy position) - (car cand) target)) + (chess-pos-set-piece pos (car cand) ? ) + (chess-pos-set-piece pos target piece) ;; 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)))) + (memq piece '(?K ?k))) + (setq king-pos (chess-pos-king-index pos color))) ;; 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)) + (chess-search-position pos king-pos (not color) t)) (if last-cand (setcdr last-cand (cdr cand)) (setq candidates (cdr candidates))) (setq last-cand cand)) + ;; return the position to its original state + (when (cdr cand) + (chess-pos-set-piece pos target ? ) + (chess-pos-set-piece pos (car cand) piece)) (setq cand (cdr cand))) candidates)) - (provide 'chess-pos) ;;; chess-pos.el ends here |