summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJohn Wiegley <johnw@newartisans.com>2018-09-06 11:11:55 -0700
committerGitHub <noreply@github.com>2018-09-06 11:11:55 -0700
commit5298bf5d110073e9508f6357ae28eee46ad29406 (patch)
tree37e2af6242423e57adbbc1238433f58c92ac9bd0
parent67339d896aa65d75272b80134a8128276c8c6a0f (diff)
parent3222b53d942daa404852e5148ba9d3ebb8fe96d0 (diff)
Merge pull request #27 from dickmao/premoves
Pre-moves
-rw-r--r--Makefile.am8
-rw-r--r--chess-common.el5
-rw-r--r--chess-crafty.el5
-rw-r--r--chess-display.el368
-rw-r--r--chess-engine.el21
-rw-r--r--chess-game.el15
-rw-r--r--chess-ics.el11
-rw-r--r--chess-ics1.el7
-rw-r--r--chess-ics2.el9
-rw-r--r--chess-images.el39
-rw-r--r--chess-input.el4
-rw-r--r--chess-network.el4
-rw-r--r--chess-plain.el7
-rw-r--r--chess-ply.el192
-rw-r--r--chess-pos.el41
-rw-r--r--chess-sound.el94
-rw-r--r--features/highlight.feature67
-rw-r--r--features/ics.feature12
-rw-r--r--features/premove.feature34
-rw-r--r--features/step-definitions/emacs-chess-steps.el146
-rw-r--r--features/support/env.el33
21 files changed, 798 insertions, 324 deletions
diff --git a/Makefile.am b/Makefile.am
index 7ce0e93..b515d4e 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -108,10 +108,14 @@ chess-test:
echo "$(EMACS) -batch -L $(srcdir) -l chess-test.el -f chess-test '$(DATABASE)' $(START) $(COUNT); rm -f $(top_builddir)/chess-test" > $@
chmod u+x $@
-.PHONY: test
+.PHONY: test test24
test: $(TESTS) $(ELCFILES)
$(top_builddir)/chess-test
- cask exec ecukes
+ cask exec ecukes --no-win
+ cask exec ecukes --win
+
+test24: $(ELCFILES)
+ EMACS="$$(evm bin emacs-24.5)" cask exec ecukes
test/twic.pgn:
(set -e; f=$$(pwd)/$@; tmp_dir=`mktemp -d`; \
diff --git a/chess-common.el b/chess-common.el
index 7de9196..ac48c8e 100644
--- a/chess-common.el
+++ b/chess-common.el
@@ -63,12 +63,15 @@
((eq event 'initialize)
(let* ((name (car args))
(path (intern (concat "chess-" name "-path")))
+ (args (intern (concat "chess-" name "-args")))
proc)
(chess-message 'starting-engine name)
(unless (and (boundp path) (symbol-value path))
(chess-error 'could-not-find-engine name path))
(setq proc (start-process (concat "chess-" name)
- (current-buffer) (symbol-value path)))
+ (current-buffer) (symbol-value path)
+ (if (and (boundp args) (symbol-value args))
+ (substitute-in-file-name (symbol-value args)) "")))
(chess-message 'starting-engine-done name)
proc))
diff --git a/chess-crafty.el b/chess-crafty.el
index d37c6b1..d69a5ea 100644
--- a/chess-crafty.el
+++ b/chess-crafty.el
@@ -35,6 +35,11 @@
:type 'file
:group 'chess-crafty)
+(defcustom chess-crafty-args "bookpath=$HOME/.crafty logpath=$HOME/.crafty tbpath=$HOME/.crafty"
+ "Command line arguments to crafty executable"
+ :type 'string
+ :group 'chess-crafty)
+
(defvar chess-crafty-evaluation nil)
(make-variable-buffer-local 'chess-crafty-evaluation)
diff --git a/chess-display.el b/chess-display.el
index 2936a9d..07d5416 100644
--- a/chess-display.el
+++ b/chess-display.el
@@ -53,6 +53,26 @@ occurs."
:type 'boolean
:group 'chess-display)
+(defcustom chess-display-allow-pre-moves nil
+ "If non-nil, allow pre-moves."
+ :type 'boolean
+ :group 'chess-display)
+
+(defcustom chess-display-legal-move-color "pale green"
+ "Color to use for legal move highlight."
+ :type 'color
+ :group 'chess-display)
+
+(defcustom chess-display-last-move-color "medium sea green"
+ "Color to use for last move highlight."
+ :type 'color
+ :group 'chess-display)
+
+(defcustom chess-display-pre-move-color "pink2"
+ "Color to use for pre-move highlight."
+ :type 'color
+ :group 'chess-display)
+
(chess-message-catalog 'english
'((mode-white . "White")
(mode-black . "Black")
@@ -104,6 +124,8 @@ See `mode-line-format' for syntax details."
(defvar chess-display-event-handler nil)
(defvar chess-display-edit-mode nil)
(defvar chess-display-index-positions nil)
+(defvar chess-display-last-selected nil)
+(defvar chess-display-highlighted-legal nil)
(make-variable-buffer-local 'chess-display-index)
(make-variable-buffer-local 'chess-display-move-text)
@@ -113,6 +135,9 @@ See `mode-line-format' for syntax details."
(make-variable-buffer-local 'chess-display-event-handler)
(make-variable-buffer-local 'chess-display-edit-mode)
(make-variable-buffer-local 'chess-display-index-positions)
+(make-variable-buffer-local 'chess-display-last-selected)
+(make-variable-buffer-local 'chess-display-highlighted-legal)
+
(defvar chess-display-handling-event nil
"If non-nil, chess-display is already handling the event. This variable
@@ -141,8 +166,9 @@ of the board, if non-nil, the board is viewed from White's perspective."
(y-or-n-p "View from White's perspective? ")))
(if (require style nil t)
(let* ((chess-display-style style)
+ ;; chess-display-handler gets registered here
(display (chess-module-create 'chess-display game "*Chessboard*"
- perspective)))
+ perspective)))
(if (called-interactively-p 'any)
(progn
(chess-display-update display)
@@ -314,6 +340,11 @@ also view the same game."
(chess-with-current-buffer display
(funcall chess-display-event-handler 'draw
(chess-display-position nil) chess-display-perspective)
+ ;; race condition where both players in network mode select square for white
+ ;; and the loser's perspective gets changed causing his selected square
+ ;; to produce an unrecognized piece error on the ensuing paint-move
+ (setq chess-display-last-selected nil)
+
(if (and popup chess-display-popup
(chess-module-leader-p nil))
(chess-display-popup nil))))
@@ -349,10 +380,88 @@ also view the same game."
(point-min))))))
(aref chess-display-index-positions index)))
+(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
+are displaying with doesn't support that mode. `selected' is a mode
+that is supported by most displays, and is the default mode."
+ (chess-with-current-buffer display
+ (let ((mode :selected))
+ (dolist (arg args)
+ (if (or (symbolp arg) (stringp arg))
+ (setq mode arg)
+ (funcall chess-display-event-handler 'highlight arg mode))))))
+
+(defsubst chess-display-highlight-move (display ply color)
+ "Highlight the source and target squares of PLY in COLOR."
+ (chess-display-highlight display color
+ (chess-ply-source ply)
+ (chess-ply-target ply)))
+
+(defsubst chess-display-unhighlight-move (display ply)
+ "Unhighlight the source and target squares of PLY."
+ (chess-display-highlight display :unselected
+ (chess-ply-source ply)
+ (chess-ply-target ply)))
+
+(defun chess-display-highlight-last-move (display &optional ply)
+ (if chess-display-highlight-last-move
+ (let ((last-ply (or ply (chess-game-ply chess-module-game
+ (1- (chess-display-index display))))))
+ (chess-display-highlight-move display last-ply chess-display-last-move-color))))
+
+(defun chess-display-unhighlight-move-before-last (display)
+ (let* ((before-last (- (chess-game-index chess-module-game) 2))
+ (last-ply (chess-game-ply chess-module-game before-last)))
+ (if last-ply (chess-display-unhighlight-move display last-ply))))
+
+(defsubst chess-display-highlight-square (display index)
+ (chess-display-highlight display :selected index))
+
+(defsubst chess-display-unhighlight-square (display index)
+ (chess-display-highlight display :unselected index)
+)
+
+(defsubst chess-display-highlight-legal (display pos)
+ "Highlight all legal move targets from POS."
+ (if chess-display-highlight-legal
+ (dolist (ply (chess-legal-plies (chess-display-position display)
+ :index pos))
+ (let ((square (chess-ply-target ply)))
+ (setq chess-display-highlighted-legal (nconc chess-display-highlighted-legal (list square)))
+ (chess-display-highlight display chess-display-legal-move-color square)))))
+
+(defsubst chess-display-unhighlight-legal (display)
+ "Unhighlight all legal move targets from POS."
+ (dolist (square chess-display-highlighted-legal)
+ (chess-display-highlight display :unselected square))
+ (setq chess-display-highlighted-legal nil)
+ )
+
+(defun chess-display-highlight-passed-pawns (&optional display)
+ (interactive)
+ (mapc
+ (lambda (index) (chess-display-highlight display index :selected))
+ (append
+ (chess-pos-passed-pawns (chess-display-position display) t)
+ (chess-pos-passed-pawns (chess-display-position display) nil))))
+
(defun chess-display-paint-move (display ply)
(chess-with-current-buffer display
- (if chess-display-highlight-last-move
- (chess-display-redraw))
+ (chess-display-unhighlight-move-before-last nil)
+ (chess-display-unhighlight-legal nil)
+ (if (and chess-engine-handling-event chess-display-last-selected)
+ ;; My opponent moves after I selected a piece and before I pre-moved
+ (let* ((from-index (cdr chess-display-last-selected))
+ (s-piece (chess-pos-piece (chess-display-position display) from-index))
+ (my-color (chess-game-data chess-module-game 'my-color)))
+ (if (not (equal my-color (< s-piece ?a)))
+ (progn
+ (chess-display-unhighlight-square nil from-index)
+ (chess-display-unhighlight-legal nil)
+ (setq chess-display-last-selected nil))
+ (chess-display-highlight-square nil from-index)
+ (chess-display-highlight-legal nil from-index))))
(let ((position (chess-ply-pos ply))
(ch (chess-ply-changes ply)))
(while ch
@@ -377,8 +486,8 @@ also view the same game."
(chess-display-index-pos nil (chess-pos-en-passant position))
? (chess-pos-en-passant position))))
(setq ch (cddr ch)))))
- (if chess-display-highlight-last-move
- (chess-display-highlight-move display ply))))
+ (chess-display-highlight-last-move display ply)
+ ))
(chess-message-catalog 'english
'((not-your-move . "It is not your turn to move")
@@ -393,66 +502,69 @@ Basically, it means we are playing, not editing or reviewing."
(not (chess-game-over-p chess-module-game))
(not chess-display-edit-mode)))
+(defsubst chess-display-pre-move-data ()
+ "Returns pre-move-data if pre-move pending"
+ (car (chess-game-get-hook-data
+ chess-module-game
+ 'chess-display-pre-move-handler)))
+
+(defsubst chess-display-quit-pre-move ()
+ "Remove pre-move hook and unhighlight pre-move. Return t if pre-move quit."
+ (let ((pre-move-data (chess-display-pre-move-data)))
+ (when pre-move-data
+ (chess-game-remove-hook chess-module-game 'chess-display-pre-move-handler)
+ (chess-display-unhighlight-legal nil)
+ (chess-display-unhighlight-move nil (cons nil (cdr pre-move-data)))
+ t)))
+
+(defun chess-display-pre-move-handler (game display-changes event &rest _args)
+ (when (eq event 'pre-move)
+ (let* ((display (car display-changes))
+ (changes (cdr display-changes))
+ (last-sel (cons nil (car changes)))
+ (coord (cadr changes)))
+ (chess-with-current-buffer display (chess-display-quit-pre-move))
+ (let ((verify (chess-display-verify-then-move display game last-sel coord)))
+ (unless (null verify)
+ (message verify)
+ (chess-display-highlight-last-move display)
+)))))
+
(defun chess-display-move (display ply &optional _prev-pos _pos)
"Move a piece on DISPLAY, by applying the given PLY.
The position of PLY must match the currently displayed position.
If only START is given, it must be in algebraic move notation."
(chess-with-current-buffer display
(if (and (chess-display-active-p)
+ (not chess-display-allow-pre-moves)
;; `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-game-side-to-move chess-module-game))))
(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)))
+ (chess-game-index chess-module-game))
+ (chess-game-over-p chess-module-game))
+ (chess-error 'game-is-over)))
(if (= chess-display-index (chess-game-index chess-module-game))
(let ((chess-display-handling-event t))
- (chess-game-move chess-module-game ply)
- (chess-display-paint-move nil ply)
- (chess-display-set-index* nil (chess-game-index chess-module-game))
- (chess-game-run-hooks chess-module-game 'post-move))
+ (if (and (chess-display-active-p)
+ (chess-game-data chess-module-game 'active)
+ (not (eq (chess-game-data chess-module-game 'my-color)
+ (chess-game-side-to-move chess-module-game))))
+ (progn
+ (chess-display-quit-pre-move)
+ (chess-game-add-hook chess-module-game 'chess-display-pre-move-handler (cons (or display (current-buffer)) (chess-ply-changes ply)))
+ (chess-display-highlight-move display ply chess-display-pre-move-color))
+ (let ((chess-engine-handling-event nil))
+ (chess-game-move chess-module-game ply)
+ (chess-display-paint-move display ply)
+ (chess-display-set-index* display (chess-game-index chess-module-game))
+ (chess-game-run-hooks chess-module-game 'post-move))))
;; jww (2002-03-28): This should beget a variation within the
;; game, or alter the game, just as SCID allows
(chess-error 'cannot-yet-add))))
-(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
-are displaying with doesn't support that mode. `selected' is a mode
-that is supported by most displays, and is the default mode."
- (chess-with-current-buffer display
- (let ((mode :selected))
- (dolist (arg args)
- (if (or (symbolp arg) (stringp arg))
- (setq mode arg)
- (funcall chess-display-event-handler 'highlight arg mode))))))
-
-(defun chess-display-highlight-legal (display pos)
- "Highlight all legal move targets from POS."
- (chess-with-current-buffer display
- (dolist (ply (chess-legal-plies (chess-display-position nil)
- :index pos))
- (chess-display-highlight nil "pale green"
- (chess-ply-target ply)))))
-
-(defun chess-display-highlight-move (display ply)
- "Highlight the last move made in the current game."
- (chess-with-current-buffer display
- (chess-display-highlight nil "medium sea green"
- (chess-ply-source ply)
- (chess-ply-target ply))))
-
-(defun chess-display-highlight-passed-pawns (&optional display)
- (interactive)
- (mapc
- (lambda (index) (chess-display-highlight display index :selected))
- (append
- (chess-pos-passed-pawns (chess-display-position display) t)
- (chess-pos-passed-pawns (chess-display-position display) nil))))
-
(defun chess-display-popup (display)
"Popup the given DISPLAY, so that it's visible to the user."
(chess-with-current-buffer display
@@ -690,6 +802,10 @@ The key bindings available in this mode are:
(function
(lambda ()
(chess-display-position nil))))
+ (setq chess-input-my-color-function
+ (function
+ (lambda ()
+ (chess-game-data chess-module-game 'my-color))))
(setq chess-input-move-function 'chess-display-move))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -710,7 +826,7 @@ The key bindings available in this mode are:
(defun chess-display-kill-board (&optional arg)
"Send the current board configuration to the user."
(interactive "P")
- (let ((x-select-enable-clipboard t)
+ (let ((select-enable-clipboard t)
(game chess-module-game))
(if arg
(kill-new (with-temp-buffer
@@ -721,7 +837,7 @@ The key bindings available in this mode are:
(defun chess-display-yank-board ()
"Send the current board configuration to the user."
(interactive)
- (let ((x-select-enable-clipboard t)
+ (let ((select-enable-clipboard t)
(display (current-buffer))
(text (current-kill 0)))
(with-temp-buffer
@@ -1160,10 +1276,6 @@ to the end or beginning."
;; Mousing around on the chess-display
;;
-(defvar chess-display-last-selected nil)
-
-(make-variable-buffer-local 'chess-display-last-selected)
-
(chess-message-catalog 'english
'((cannot-mount . "You cannot move pieces on top of each other")
(move-not-legal . "That is not a legal move")
@@ -1172,6 +1284,45 @@ to the end or beginning."
(selected-empty . "You cannot select an empty square")
(piece-immobile . "That piece cannot move now")))
+(defun chess-display-verify-then-move (display game last-sel coord)
+ "Refactored verify-then-move for normal and pre-moves.
+ Return error string or nil if no errors"
+ (let* ((position (chess-display-position display))
+ (my-color (chess-game-data game 'my-color))
+ (is-pre-move (not (eq my-color (chess-game-side-to-move game))))
+ (s-piece (chess-pos-piece position (cdr last-sel)))
+ (t-piece (chess-pos-piece position coord)) ply)
+ (if chess-display-edit-mode
+ (progn
+ (chess-pos-set-piece position (cdr last-sel) ? )
+ (chess-pos-set-piece position coord s-piece)
+ (chess-display-update display)
+ nil)
+
+ ;; relax mounting restriction if pre-move
+ (if (and (not is-pre-move)
+ (/= t-piece ? )
+ (or (and (< t-piece ?a)
+ (< s-piece ?a))
+ (and (> t-piece ?a)
+ (> s-piece ?a))))
+ (chess-string 'cannot-mount)
+
+ (if (not (eq my-color (< s-piece ?a)))
+ (chess-string 'wrong-color)
+
+ (if (null (setq ply (chess-ply-create position nil
+ (cdr last-sel)
+ coord)))
+ (chess-string 'move-not-legal)
+ (condition-case-unless-debug err
+ (progn
+ (chess-display-move display ply)
+ nil)
+ (error
+ (error-message-string err))))))))
+ )
+
(defun chess-display-select-piece ()
"Select the piece under the cursor.
Clicking once on a piece selects it; then click on the target location."
@@ -1180,74 +1331,50 @@ Clicking once on a piece selects it; then click on the target location."
(position (chess-display-position nil))
message)
(when coord
+ ;; chess-display-redraw is 2000us
+ ;; chess-display-event-handler 'draw-square is 40us
(setq message
- (catch 'message
- (if chess-display-last-selected
- (let ((last-sel chess-display-last-selected))
- ;; if they select the same square again, just deselect
- ;; it by redrawing the display and removing all
- ;; highlights
- (if (= (point) (car last-sel))
- (funcall chess-display-event-handler 'draw-square
- (car last-sel)
- (chess-pos-piece position (cdr last-sel))
- (cdr last-sel))
- (let ((s-piece (chess-pos-piece position (cdr last-sel)))
- (t-piece (chess-pos-piece position coord)) ply)
- (if chess-display-edit-mode
- (progn
- (chess-pos-set-piece position (cdr last-sel) ? )
- (chess-pos-set-piece position coord s-piece)
- (chess-display-update nil))
- (if (and (/= t-piece ? )
- (or (and (< t-piece ?a)
- (< s-piece ?a))
- (and (> t-piece ?a)
- (> s-piece ?a))))
- (throw 'message (chess-string 'cannot-mount)))
- (unless (setq ply (chess-ply-create position nil
- (cdr last-sel)
- coord))
- (throw 'message (chess-string 'move-not-legal)))
- (condition-case err
- (chess-display-move nil ply
- (car last-sel) (point))
- (error
- (throw 'message (error-message-string err)))))))
- (setq chess-display-last-selected nil))
- (let ((piece (chess-pos-piece position coord)))
- (cond
- ((eq piece ? )
- (throw 'message (chess-string 'selected-empty)))
- ((not (or chess-display-edit-mode
- (not (chess-display-active-p))
- (eq (chess-pos-side-to-move position)
- (chess-game-data chess-module-game
- 'my-color))))
- (throw 'message (chess-string 'not-your-move)))
- ((and (not chess-display-edit-mode)
- (if (chess-pos-side-to-move position)
- (> piece ?a)
- (< piece ?a)))
- (throw 'message (chess-string 'wrong-color)))
- ((and (not chess-display-edit-mode)
- chess-display-highlight-legal
- (null (chess-legal-plies position :any :index coord)))
- (throw 'message (chess-string 'piece-immobile))))
- (setq chess-display-last-selected (cons (point) coord))
- (chess-display-highlight nil coord)
- (if (and (not chess-display-edit-mode)
- chess-display-highlight-legal)
- (chess-display-highlight-legal nil coord))))))
- (when message
- (when chess-display-last-selected
- (funcall chess-display-event-handler 'draw-square
- (car chess-display-last-selected)
- (chess-pos-piece position
- (cdr chess-display-last-selected))
- (cdr chess-display-last-selected))
- (setq chess-display-last-selected nil))
- (message message)))))
+ (catch 'message
+ (cond ((chess-display-quit-pre-move)
+ (chess-display-highlight-last-move nil))
+ (chess-display-last-selected
+ (let* ((last-sel chess-display-last-selected)
+ (from-point (car last-sel))
+ (from-index (cdr last-sel)))
+ (setq chess-display-last-selected nil)
+ (chess-display-unhighlight-square nil from-index)
+ (chess-display-unhighlight-legal nil)
+ (chess-display-highlight-last-move nil)
+ (if (/= (point) from-point)
+ (let ((verify (chess-display-verify-then-move nil chess-module-game last-sel coord)))
+ (unless (null verify)
+ (throw 'message verify))))))
+ (t (let ((piece (chess-pos-piece position coord)))
+ (cond
+ ((eq piece ? )
+ (throw 'message (chess-string 'selected-empty)))
+ ((not (or chess-display-allow-pre-moves
+ chess-display-edit-mode
+ (not (chess-display-active-p))
+ (eq (chess-pos-side-to-move position)
+ (chess-game-data chess-module-game
+ 'my-color))))
+ (throw 'message (chess-string 'not-your-move)))
+ ((and (not chess-display-edit-mode)
+ (if (chess-game-data chess-module-game 'my-color)
+ (> piece ?a)
+ (< piece ?a)))
+ (throw 'message (chess-string 'wrong-color)))
+ ((and (not chess-display-edit-mode)
+ (null (chess-legal-plies position :any :index coord)))
+ (throw 'message (chess-string 'piece-immobile))))
+ (setq chess-display-last-selected (cons (point) coord))
+ (chess-display-highlight-square nil coord)
+ (if (not chess-display-edit-mode)
+ (chess-display-highlight-legal nil coord))
+ )))))
+ (if (stringp message)
+ (message message)))))
(defun chess-display-mouse-select-piece (event)
"Select the piece the user clicked on."
@@ -1270,6 +1397,7 @@ Clicking once on a piece selects it; then click on the target location."
(defun chess-display-get-face (color)
(or (cdr (assoc color chess-display-face-cache))
(let ((face (make-face 'chess-display-highlight)))
+ ;; copying an already made face to the cache with new color
(set-face-attribute face nil :background color)
(add-to-list 'chess-display-face-cache (cons color face))
face)))
diff --git a/chess-engine.el b/chess-engine.el
index 0ac7541..2d6068a 100644
--- a/chess-engine.el
+++ b/chess-engine.el
@@ -130,21 +130,23 @@ If conversion fails, this function fired an 'illegal event."
((eq event 'pass)
(when (chess-game-data game 'active)
- (chess-message 'move-passed)
+ (let ((chess-engine-handling-event t))
+ (chess-engine-set-position nil (car args) t))
t))
((eq event 'match)
(if (chess-game-data game 'active)
(chess-engine-command nil 'busy)
(let ((name (> (length (car args)) 0)))
- (if (y-or-n-p (if name
- (chess-string 'want-to-play (car args))
- (chess-string 'want-to-play-a)))
+ (if (or noninteractive
+ (y-or-n-p (if name
+ (chess-string 'want-to-play (car args))
+ (chess-string 'want-to-play-a))))
(progn
- (setq chess-engine-opponent-name (or name "Anonymous"))
+ (setq chess-engine-opponent-name (if name (car args) "Anonymous"))
(let ((chess-engine-handling-event t))
(chess-engine-set-position nil))
- (chess-engine-command nil 'accept name))
+ (chess-engine-command nil 'accept chess-full-name))
(chess-engine-command nil 'decline))))
t)
@@ -213,12 +215,11 @@ If conversion fails, this function fired an 'illegal event."
(when chess-engine-pending-offer
(if (eq chess-engine-pending-offer 'match)
(unless (chess-game-data game 'active)
- (let ((name (and (> (length (car args)) 0)
- (car args))))
+ (let ((name (> (length (car args)) 0)))
(if name
- (chess-message 'opp-ready (car args))
+ (chess-message 'opp-ready (car args))
(chess-message 'opp-ready-a))
- (setq chess-engine-opponent-name (or name "Anonymous"))
+ (setq chess-engine-opponent-name (if name (car args) "Anonymous"))
(let ((chess-engine-handling-event t))
(chess-engine-set-position nil))))
(let ((chess-engine-handling-event t))
diff --git a/chess-game.el b/chess-game.el
index ed38288..8b72035 100644
--- a/chess-game.el
+++ b/chess-game.el
@@ -75,13 +75,19 @@ matches."
(if (and (eq (caar h) function)
(or (null data)
(eq data (cdar h))))
- (if last-hook
- (setcdr last-hook (cdr h))
- (setq hooks (cdr h)))
+ (if last-hook
+ (setcdr last-hook (cdr h))
+ (setq hooks (cdr h)))
(setq last-hook h))
(setq h (cdr h)))
(chess-game-set-hooks game hooks)))
+(defun chess-game-get-hook-data (game function)
+ "Get list of corresponding data (nil if none) from all event hooks that match FUNCTION."
+ (cl-assert game)
+ (cl-assert function)
+ (cl-remove-if 'null (mapcar (lambda (h) (if (eq (car h) function) (cdr h))) (chess-game-hooks game))))
+
(defsubst chess-game-run-hooks (game &rest args)
"Run the event hooks of GAME and pass ARGS."
(cl-assert game)
@@ -337,7 +343,8 @@ progress (nil), if it is drawn, resigned, mate, etc."
(if (chess-ply-keyword ply :resign)
(chess-game-run-hooks game 'resign)
- (chess-game-run-hooks game 'move current-ply))))
+ (chess-game-run-hooks game 'move current-ply)
+ (chess-game-run-hooks game 'pre-move))))
(defsubst chess-game-end (game keyword)
"End GAME, by resignation, draw, etc."
diff --git a/chess-ics.el b/chess-ics.el
index 51ce1e0..9cc5c99 100644
--- a/chess-ics.el
+++ b/chess-ics.el
@@ -376,7 +376,7 @@ standard position). In those cases, this variable should be set to nil.")
(lambda ()
(funcall #'chess-engine-default-handler 'undo
(string-to-number (match-string 1))))))
- (cons "The game has been aborted on move [^.]+\\."
+ (cons "\\S-+ has aborted the game on move [^.]+\\."
(function
(lambda ()
(let ((chess-engine-pending-offer 'abort))
@@ -386,7 +386,7 @@ standard position). In those cases, this variable should be set to nil.")
(lambda ()
(funcall #'chess-engine-default-handler 'accept))))
(cons ;; resign announcement
- "{Game \\([0-9]+\\) (\\(\\S-+\\) vs\\. \\(\\S-+\\)) \\(\\S-+\\) resigns}"
+ "{Game \\([0-9]+\\) (\\(\\S-+\\) vs\\. \\(\\S-+\\)) \\(\\S-+\\) \\(resigns\\|forfeits by disconnection\\)}"
(function
(lambda ()
(let ((chess-engine-handling-event t)
@@ -403,9 +403,10 @@ standard position). In those cases, this variable should be set to nil.")
(cons "\\(\\S-+\\) forfeits on time}"
(function
(lambda ()
- (if (string= (match-string 1) chess-engine-opponent-name)
- (funcall #'chess-engine-default-handler 'flag-fell)
- (funcall #'chess-engine-default-handler 'call-flag t)))))
+ (let ((opponent-p (not (string= chess-ics-handle (match-string 1)))))
+ (if opponent-p
+ (funcall #'chess-engine-default-handler 'flag-fell)
+ (funcall #'chess-engine-default-handler 'call-flag t))))))
(cons "Illegal move (\\([^)]+\\))\\."
(function
(lambda ()
diff --git a/chess-ics1.el b/chess-ics1.el
index ec0c3ed..a5d572f 100644
--- a/chess-ics1.el
+++ b/chess-ics1.el
@@ -132,7 +132,8 @@ PERSPECTIVE is t for white or nil for black."
(goto-char pos)))
(defun chess-ics1-highlight (index &optional mode)
- (let ((pos (chess-display-index-pos nil index)))
+ (let ((pos (chess-display-index-pos nil index))
+ (piece (chess-pos-piece (chess-display-position nil) index)))
(put-text-property pos (save-excursion
(goto-char pos)
(skip-chars-forward "^|")
@@ -140,6 +141,10 @@ PERSPECTIVE is t for white or nil for black."
'face (cond
((eq mode :selected)
'chess-ics1-highlight-face)
+ ((eq mode :unselected)
+ (if (> piece ?a)
+ 'chess-ics1-black-face
+ 'chess-ics1-white-face))
(t
(chess-display-get-face mode))))))
diff --git a/chess-ics2.el b/chess-ics2.el
index a052bea..18ff7dc 100644
--- a/chess-ics2.el
+++ b/chess-ics2.el
@@ -169,13 +169,20 @@ PERSPECTIVE is t for white or nil for black."
(goto-char pos)))
(defun chess-ics2-highlight (index &optional mode)
- (let ((pos (chess-display-index-pos nil index)))
+ (let ((pos (chess-display-index-pos nil index))
+ (piece (chess-pos-piece (chess-display-position nil) index)))
(put-text-property pos (save-excursion
(goto-char (+ pos 2))
(point))
'face (cond
((eq mode :selected)
'chess-ics2-highlight-face)
+ ((eq mode :unselected)
+ (if (> piece ?a)
+ (if (= a 0) 'chess-ics2-black-face
+ 'chess-ics2-black-face-alt)
+ (if (= a 0) 'chess-ics2-white-face
+ 'chess-ics2-white-face-alt)))
(t
(chess-display-get-face mode))))))
diff --git a/chess-images.el b/chess-images.el
index 1164c45..aacd153 100644
--- a/chess-images.el
+++ b/chess-images.el
@@ -305,22 +305,31 @@ chess board are light or dark depending on location."
(goto-char pos)))
(defun chess-images-highlight (index &optional mode)
- "Highlight the piece on the board at INDEX, using the given MODE.
-Common modes are:
- `selected' show that the piece has been selected for movement.
- `unselected' show that the piece has been unselected."
+ "Highlight the piece on the board at INDEX, using the given MODE, which
+is often an arbitrary color or
+ :selected show that the piece has been selected for movement.
+ :unselected show that the piece has been unselected."
(let* ((pos (chess-display-index-pos nil index))
- (highlight (copy-alist (get-text-property pos 'display))))
- (setcar (last highlight)
- (list (cons "light_square" (if (eq mode :selected)
- chess-images-highlight-color
- mode))
- (cons "dark_square" (if (eq mode :selected)
- chess-images-highlight-color
- mode))
- (cons "background" (if (eq mode :selected)
- chess-images-highlight-color
- mode))))
+ (highlight (copy-alist (get-text-property pos 'display)))
+ (light-color (if (eq mode :selected)
+ chess-images-highlight-color
+ (if (eq mode :unselected) chess-images-light-color mode)))
+ (dark-color (if (eq mode :selected)
+ chess-images-highlight-color
+ (if (eq mode :unselected) chess-images-dark-color mode)))
+ (square-color (% (+ (chess-index-file index) (chess-index-rank index)) 2))
+ (background (if (eq mode :selected)
+ chess-images-highlight-color
+ (if (eq mode :unselected)
+ (if (= square-color 0) chess-images-light-color chess-images-dark-color) mode)))
+ (color-syms (car (last highlight))))
+ (setcar (last highlight)
+ (mapcar (lambda (cp)
+ (cond ((string= (car cp) "light_square") (cons (car cp) light-color))
+ ((string= (car cp) "dark_square") (cons (car cp) dark-color))
+ ((string= (car cp) "background") (cons (car cp) background))
+ (t cp)))
+ color-syms))
(put-text-property pos (1+ pos) 'display highlight)))
(chess-message-catalog 'english
diff --git a/chess-input.el b/chess-input.el
index ce7b348..7d94940 100644
--- a/chess-input.el
+++ b/chess-input.el
@@ -40,12 +40,14 @@
(defvar chess-input-moves-pos nil)
(defvar chess-input-moves nil)
(defvar chess-input-position-function nil)
+(defvar chess-input-my-color-function nil)
(defvar chess-input-move-function nil)
(make-variable-buffer-local 'chess-input-move-string)
(make-variable-buffer-local 'chess-input-moves-pos)
(make-variable-buffer-local 'chess-input-moves)
(make-variable-buffer-local 'chess-input-position-function)
+(make-variable-buffer-local 'chess-input-my-color-function)
(make-variable-buffer-local 'chess-input-move-function)
(defun chess-input-test-move (ply)
@@ -90,7 +92,7 @@
(defun chess-input-shortcut (&optional display-only)
(interactive)
(let* ((position (funcall chess-input-position-function))
- (color (chess-pos-side-to-move position))
+ (color (funcall chess-input-my-color-function))
char)
(unless (memq last-command '(chess-input-shortcut
chess-input-shortcut-delete))
diff --git a/chess-network.el b/chess-network.el
index a5f3ef4..493198b 100644
--- a/chess-network.el
+++ b/chess-network.el
@@ -34,7 +34,7 @@
(cons "chess match\\(\\s-+\\(.+\\)\\)?$"
(function
(lambda ()
- (funcall chess-engine-response-handler 'match
+ (funcall chess-engine-response-handler 'match
(match-string 2)))))
(cons "fen\\s-+\\(.+\\)"
(function
@@ -143,7 +143,7 @@
(string-to-number
(read-string "Port: ")))
(start-process "*chess-network*"
- (current-buffer) "/usr/bin/nc"
+ (current-buffer) (executable-find "nc")
"-l" "-p" (read-string "Port: ")))
(open-network-stream "*chess-network*" (current-buffer)
(read-string "Host: ")
diff --git a/chess-plain.el b/chess-plain.el
index 7dd66f1..d8036b8 100644
--- a/chess-plain.el
+++ b/chess-plain.el
@@ -324,11 +324,16 @@ PERSPECTIVE is t for white or nil for black."
(goto-char pos))))
(defun chess-plain-highlight (index &optional mode)
- (let ((pos (chess-display-index-pos nil index)))
+ (let ((pos (chess-display-index-pos nil index))
+ (piece (chess-pos-piece (chess-display-position nil) index)))
(put-text-property pos (1+ pos) 'face
(cond
((eq mode :selected)
'chess-plain-highlight-face)
+ ((eq mode :unselected)
+ (if (> piece ?a)
+ 'chess-plain-black-face
+ 'chess-plain-white-face))
(t
(chess-display-get-face mode))))))
diff --git a/chess-ply.el b/chess-ply.el
index 165befa..fee23db 100644
--- a/chess-ply.el
+++ b/chess-ply.el
@@ -148,7 +148,8 @@
(defun chess-ply-castling-changes (position &optional long king-index)
"Create castling changes; this function supports Fischer Random castling."
(cl-assert (vectorp position))
- (let* ((color (chess-pos-side-to-move position))
+ (let* ((color (if king-index (< (chess-pos-piece position king-index) ?a)
+ (chess-pos-side-to-move position)))
(king (or king-index (chess-pos-king-index position color)))
(rook (chess-pos-can-castle position (if color
(if long ?Q ?K)
@@ -201,89 +202,90 @@ also extend castling, and will prompt for a promotion piece.
Note: Do not pass in the rook move if CHANGES represents a castling
maneuver."
(cl-assert (vectorp position))
- (let* ((ply (cons position changes))
- (color (chess-pos-side-to-move position))
- piece)
- (if (or (null changes) (symbolp (car changes)))
- ply
- ;; validate that `changes' can be legally applied to the given
- ;; position
- (when (or valid-p
- (chess-legal-plies position :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-castling-changes position long
- (car changes))))
- (setcdr ply new-changes)))
-
- (when (eq piece (if color ?P ?p))
- ;; is this a pawn move to the ultimate rank? if so, check
- ;; that the :promote keyword is present.
- (when (and (not (memq :promote changes))
- (= (if color 0 7)
- (chess-index-rank (cadr changes))))
- (let ((promo (ask-promotion color)))
- (nconc changes (list :promote promo))
- (setq ply (cons position changes))))
-
- ;; is this an en-passant capture?
- (when (let ((ep (chess-pos-en-passant position)))
- (when ep
- (eq ep (funcall (if color #'+ #'-) (cadr changes) 8))))
- (nconc changes (list :en-passant)))))
-
- ;; we must determine whether this ply results in a check,
- ;; checkmate or stalemate
- (unless (or chess-pos-always-white
- (memq :check changes)
- (memq :checkmate changes)
- (memq :stalemate changes))
- (let* ((chess-ply-checking-mate t)
- ;; jww (2002-04-17): this is a memory waste?
- (next-pos (chess-ply-next-pos ply))
- (next-color (not color))
- (king (chess-pos-king-index next-pos next-color))
- (in-check (catch 'in-check
- (chess-search-position next-pos king color t 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
- ;; 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 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?
- (if (chess-legal-plies next-pos :any :color next-color)
- (if in-check
- (nconc changes (list (chess-pos-set-status
- next-pos :check))))
- (nconc changes (list (chess-pos-set-status
- next-pos
- (if in-check
- :checkmate
- :stalemate)))))))))
- ;; return the annotated ply
- ply))))
+ (let ((ply (cons position changes)))
+ (if (integerp (car changes))
+ (let* ((color (< (chess-pos-piece position (car changes)) ?a))
+ (is-pre-move (not (eq color (chess-pos-side-to-move position))))
+ piece)
+ ;; validate that `changes' can be legally applied to the given
+ ;; position
+ (if (or valid-p
+ (chess-legal-plies position :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-castling-changes position long
+ (car changes))))
+ (setcdr ply new-changes)))
+
+ (when (eq piece (if color ?P ?p))
+ ;; is this a pawn move to the ultimate rank? if so, check
+ ;; that the :promote keyword is present.
+ (when (and (not (memq :promote changes))
+ (= (if color 0 7)
+ (chess-index-rank (cadr changes))))
+ (let ((promo (if is-pre-move (nth (if color 1 0) (car promotion-options))
+ (ask-promotion color))))
+ (nconc changes (list :promote promo))
+ (setq ply (cons position changes))))
+
+ ;; is this an en-passant capture?
+ (when (let ((ep (chess-pos-en-passant position)))
+ (when ep
+ (eq ep (funcall (if color #'+ #'-) (cadr changes) 8))))
+ (nconc changes (list :en-passant)))))
+
+ ;; we must determine whether this ply results in a check,
+ ;; checkmate or stalemate
+ (unless (or chess-pos-always-white
+ (memq :check changes)
+ (memq :checkmate changes)
+ (memq :stalemate changes))
+ (let* ((chess-ply-checking-mate t)
+ ;; jww (2002-04-17): this is a memory waste?
+ (next-pos (chess-ply-next-pos ply))
+ (next-color (not color))
+ (king (chess-pos-king-index next-pos next-color))
+ (in-check (catch 'in-check
+ (chess-search-position next-pos king color t 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
+ ;; 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 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?
+ (if (chess-legal-plies next-pos :any :color next-color)
+ (if in-check
+ (nconc changes (list (chess-pos-set-status
+ next-pos :check))))
+ (nconc changes (list (chess-pos-set-status
+ next-pos
+ (if in-check
+ :checkmate
+ :stalemate)))))))))
+ (setq ply nil))))
+ ;; return the annotated ply
+ ply))
(defsubst chess-ply-final-p (ply)
"Return non-nil if this is the last ply of a game/variation."
@@ -355,7 +357,11 @@ position object passed in."
(t
(let* ((piece (cadr (memq :piece keywords)))
(color (if piece (< piece ?a)
- (chess-pos-side-to-move position)))
+ (if (memq :index keywords)
+ (< (chess-pos-piece position
+ (cadr (memq :index keywords))) ?a)
+ (chess-pos-side-to-move position))))
+ (not-my-turn (not (eq color (chess-pos-side-to-move position))))
(specific-target (cadr (memq :target keywords)))
(test-piece
(upcase (or piece
@@ -399,7 +405,7 @@ position object passed in."
(if color
chess-direction-northeast
chess-direction-southwest)))
- (if (chess-pos-piece-p position pos (not color))
+ (if (or not-my-turn (chess-pos-piece-p position pos (not color)))
(chess-ply--add nil nil pos)
;; check for en passant capture toward kingside
(when (and ep (= ep (funcall (if color #'+ #'-) pos 8)))
@@ -408,7 +414,7 @@ position object passed in."
(if color
chess-direction-northwest
chess-direction-southeast)))
- (if (chess-pos-piece-p position pos (not color))
+ (if (or not-my-turn (chess-pos-piece-p position pos (not color)))
(chess-ply--add nil nil pos)
;; check for en passant capture toward queenside
(when (and ep (eq ep (funcall (if color #'+ #'-) pos 8)))
@@ -427,15 +433,16 @@ position object passed in."
(progn
(chess-ply--add nil nil pos)
(setq pos (chess-next-index pos dir)))
- (if (chess-pos-piece-p position pos (not color))
+ (if (or not-my-turn (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 chess-king-directions)
(setq pos (chess-next-index candidate dir))
- (if (and pos (or (chess-pos-piece-p position pos ? )
+ (if (and pos (or not-my-turn
+ (chess-pos-piece-p position pos ? )
(chess-pos-piece-p position pos (not color))))
(chess-ply--add nil nil pos)))
@@ -445,7 +452,7 @@ position object passed in."
candidate)))
(if changes
(if chess-ply-throw-if-any
- (throw 'any-found t)
+ (throw 'any-found t)
(if (or (not specific-target)
(= specific-target (cadr changes)))
(push (cons position changes) plies))))))
@@ -466,7 +473,8 @@ position object passed in."
(dolist (dir chess-knight-directions)
;; up the current file
(if (and (setq pos (chess-next-index candidate dir))
- (or (chess-pos-piece-p position pos ? )
+ (or not-my-turn
+ (chess-pos-piece-p position pos ? )
(chess-pos-piece-p position pos (not color))))
(chess-ply--add nil nil pos))))
diff --git a/chess-pos.el b/chess-pos.el
index 7ccb68f..f68bdac 100644
--- a/chess-pos.el
+++ b/chess-pos.el
@@ -85,6 +85,7 @@
(require 'chess-message)
(require 'cl-lib)
+
(eval-when-compile
(cl-proclaim '(optimize (speed 3) (safety 2))))
@@ -1073,28 +1074,35 @@ in check)."
(cl-assert (and (>= target 0) (< target 64)))
(cl-assert (listp candidates))
(cl-assert (> (length candidates) 0))
- (let ((cand candidates)
- (piece (chess-pos-piece position (car candidates)))
- (other-piece (chess-pos-piece position target))
- en-passant-square last-cand king-pos)
+ (let* ((cand candidates)
+ (piece (chess-pos-piece position (car candidates)))
+ (other-piece (chess-pos-piece position target))
+ (is-pre-move (not (eq color (chess-pos-side-to-move position))))
+ (ep (chess-pos-en-passant position))
+ (color-ep (if ep (< (chess-pos-piece position ep) ?a) t))
+ en-passant-square last-cand king-pos)
(while cand
(unwind-protect
(progn
;; determine the resulting position
(chess-pos-set-piece position (car cand) ? )
(chess-pos-set-piece position target piece)
- (when (and (= piece (if color ?P ?p))
- (let ((ep (chess-pos-en-passant position)))
- (when ep
- (= ep (chess-next-index target (if color
- chess-direction-south
- chess-direction-north))))))
- (chess-pos-set-piece position
- (setq en-passant-square
- (chess-incr-index target
- (if color 1 -1)
- 0))
- ? ))
+
+ (if (and ep
+ (= piece (if color ?P ?p))
+ (= ep (chess-next-index target
+ (if color
+ chess-direction-south
+ chess-direction-north)))
+ ;; need to check pawns are different colors
+ ;; because of pre-move
+ (not (eq color color-ep)))
+ (chess-pos-set-piece position
+ (setq en-passant-square
+ (chess-incr-index target
+ (if color 1 -1)
+ 0))
+ ? ))
;; find the king (only once if the king isn't moving)
(if (or (null king-pos)
(memq piece '(?K ?k)))
@@ -1102,6 +1110,7 @@ in check)."
;; can anybody from the opposite side reach him? if so,
;; drop the candidate
(if (and king-pos
+ (not is-pre-move)
(catch 'in-check
(chess-search-position position king-pos
(not color) t)))
diff --git a/chess-sound.el b/chess-sound.el
index 8397c79..c4f7166 100644
--- a/chess-sound.el
+++ b/chess-sound.el
@@ -58,16 +58,22 @@
:type '(repeat string)
:group 'chess-sound)
-(defcustom chess-sound-my-moves nil
- "If non-nil, plays the move.wav sound whenever you make a move."
+(defcustom chess-sound-moves nil
+ "If non-nil, plays move.wav for each move."
+ :type 'boolean
+ :group 'chess-sound)
+
+(defcustom chess-sound-voiced-moves nil
+ "If non-nil, announces opponent's algebraic move."
:type 'boolean
:group 'chess-sound)
(defsubst chess-sound (file)
(ignore-errors
- (funcall chess-sound-play-function
- (expand-file-name (concat file ".wav")
- chess-sound-directory))))
+ (let ((wav (expand-file-name (concat file ".wav") chess-sound-directory)))
+ (if (file-readable-p wav)
+ (funcall chess-sound-play-function wav)
+ (ding)))))
(defsubst chess-sound-play (file)
(apply 'call-process chess-sound-program
@@ -86,45 +92,45 @@
((eq event 'move)
(let* ((ply (chess-game-ply game (1- (chess-game-index game))))
(pos (chess-ply-pos ply)))
- (if (eq (chess-game-data game 'my-color)
- (chess-pos-side-to-move pos))
- (if chess-sound-my-moves
- (chess-sound "move"))
- (let* ((source (chess-ply-source ply))
- (target (chess-ply-target ply))
- (s-piece (and source (chess-pos-piece pos source)))
- (t-piece (and target (chess-pos-piece pos target)))
- (which (chess-ply-keyword ply :which)))
- (cond
- ((chess-ply-keyword ply :castle)
- (chess-sound "O-O"))
- ((chess-ply-keyword ply :long-castle)
- (chess-sound "O-O-O"))
- ((and s-piece t-piece (= t-piece ? ) target)
- (if which
- (chess-sound (char-to-string which)))
- (chess-sound (format "%c_" (downcase s-piece)))
- (chess-sound (chess-index-to-coord target)))
- ((and s-piece t-piece target)
- (if which
- (chess-sound (char-to-string which)))
- (chess-sound (format "%c_" (downcase s-piece)))
- (chess-sound "x_")
- (chess-sound (format "%c_" (downcase t-piece)))
- (chess-sound (chess-index-to-coord target))))
-
- (if (chess-ply-keyword ply :promote)
- (chess-sound
- (format "%c_" (downcase
- (chess-ply-keyword ply :promote)))))
- (if (chess-ply-keyword ply :en-passant)
- (chess-sound "enpassant"))
- (if (chess-ply-keyword ply :check)
- (chess-sound "+_"))
- (if (chess-ply-keyword ply :checkmate)
- (chess-sound "#_"))
- (if (chess-ply-keyword ply :stalemate)
- (chess-sound "smate"))))))))
+ (if (and chess-sound-voiced-moves
+ (not (eq (chess-game-data game 'my-color)
+ (chess-pos-side-to-move pos))))
+ (let* ((source (chess-ply-source ply))
+ (target (chess-ply-target ply))
+ (s-piece (and source (chess-pos-piece pos source)))
+ (t-piece (and target (chess-pos-piece pos target)))
+ (which (chess-ply-keyword ply :which)))
+ (cond
+ ((chess-ply-keyword ply :castle)
+ (chess-sound "O-O"))
+ ((chess-ply-keyword ply :long-castle)
+ (chess-sound "O-O-O"))
+ ((and s-piece t-piece (= t-piece ? ) target)
+ (if which
+ (chess-sound (char-to-string which)))
+ (chess-sound (format "%c_" (downcase s-piece)))
+ (chess-sound (chess-index-to-coord target)))
+ ((and s-piece t-piece target)
+ (if which
+ (chess-sound (char-to-string which)))
+ (chess-sound (format "%c_" (downcase s-piece)))
+ (chess-sound "x_")
+ (chess-sound (format "%c_" (downcase t-piece)))
+ (chess-sound (chess-index-to-coord target))))
+
+ (if (chess-ply-keyword ply :promote)
+ (chess-sound
+ (format "%c_" (downcase
+ (chess-ply-keyword ply :promote)))))
+ (if (chess-ply-keyword ply :en-passant)
+ (chess-sound "enpassant"))
+ (if (chess-ply-keyword ply :check)
+ (chess-sound "+_"))
+ (if (chess-ply-keyword ply :checkmate)
+ (chess-sound "#_"))
+ (if (chess-ply-keyword ply :stalemate)
+ (chess-sound "smate")))
+ (if chess-sound-moves (chess-sound "move")))))))
(provide 'chess-sound)
diff --git a/features/highlight.feature b/features/highlight.feature
new file mode 100644
index 0000000..fd72ea9
--- /dev/null
+++ b/features/highlight.feature
@@ -0,0 +1,67 @@
+Scenario: legal highlights should not persist across piece selection
+ Given I start server and client
+ Then I am ready to play
+ When white selects "d2"
+ And white selects "d2"
+ And white selects "e2"
+ Given I switch to buffer "*Chessboard*"
+ Then the square at "d3" is unhighlighted
+
+Scenario: preserve last-move highlight after changing my mind
+ Given I start server and client
+ Then I am ready to play
+ When white moves "d4"
+ And black moves "e5"
+ And white selects "d4"
+ And white selects "d4"
+ Then the square at "e5" is highlighted last-move
+ When black selects "e5"
+ And black selects "e5"
+ Then the square at "e5" is highlighted last-move
+
+Scenario: preserve last-move highlight after pre-move invalidated
+ Given I start server and client
+ Then I am ready to play
+ When white moves "d4"
+ And black moves "e5"
+ And white moves "e4"
+ And white moves "d5"
+ Then the square at "d5" is highlighted pre-move
+ When black moves "ex"
+ Given I switch to buffer "*Chessboard*"
+ Then the square at "d4" is highlighted last-move
+
+Scenario: Legal highlight locus must needs reduce after opponent moves
+ Given I start server and client
+ Then I am ready to play
+ When white moves "d4"
+ And black moves "d5"
+ And black selects "e7"
+ Then the square at "e5" is highlighted legal
+ Then the square at "f6" is highlighted legal
+ And white moves "e4"
+ Given I switch to buffer "*Chessboard*<2>"
+ Then the square at "e5" is highlighted legal
+ Then the square at "f6" is unhighlighted
+
+Scenario: My opponent invalidates my pre-move. I should not need to click twice for next selection.
+ Given I start server and client
+ Then I am ready to play
+ And white moves "d4"
+ And black moves "e5"
+ When black selects "e5"
+ Then the square at "e5" is highlighted selected
+ Then the square at "e4" is highlighted legal
+ And white moves "dx"
+ Given I switch to buffer "*Chessboard*<2>"
+ Then the square at "e5" is highlighted last-move
+ Then the square at "e4" is unhighlighted
+ When black selects "c7"
+ Then the square at "c7" is highlighted selected
+
+Scenario: paint-move had contained a redraw that was 2000 microseconds (still 1/200 of blink of an eye)
+ Given I start server and client
+ Then I am ready to play
+ When white moves "d4"
+ And black moves "c5"
+ And paint-move last 2 plies less than 300 microseconds (individually)
diff --git a/features/ics.feature b/features/ics.feature
index 5a49dfe..fcb7706 100644
--- a/features/ics.feature
+++ b/features/ics.feature
@@ -3,3 +3,15 @@ Scenario: Echo area should indicate opponent ran out of time.
When new game
And opponent forfeits on time
Then I should see message "Your opponent has forfeited the game on time"
+
+Scenario: Let me know when opponent aborts
+ Given ics session
+ When new game
+ And opponent aborts
+ Then I should see message "Your offer to abort was accepted"
+
+Scenario: Let me know when opponent forfeits by disconnection
+ Given ics session
+ When new game
+ And opponent forfeits by disconnection
+ Then I should see message "Your opponent has resigned"
diff --git a/features/premove.feature b/features/premove.feature
new file mode 100644
index 0000000..47cf85f
--- /dev/null
+++ b/features/premove.feature
@@ -0,0 +1,34 @@
+Scenario: en-passant logic assumed no pre-moves (white)
+ Given I start server and client
+ Then I am ready to play
+ When white moves "d4"
+ And white selects "d4"
+ Then the square at "d3" is unhighlighted
+
+Scenario: en-passant logic assumed no pre-moves (black)
+ Given I start server and client
+ Then I am ready to play
+ When white moves "d4"
+ And black moves "e5"
+ And black selects "e5"
+ Then the square at "e6" is unhighlighted
+
+Scenario: pre-move can leave king in check, assuming checking piece is captured
+ Given I start server and client
+ Then I am ready to play
+ And I set position of "*chess-network*<1>" to fen "3rk3/8/8/3R4/8/8/PPPPPPPP/1NBQKBNR w - -"
+ And I send position from "*chess-network*<1>"
+ When black selects "e8"
+ And black selects "d8"
+ Then the square at "d8" is highlighted pre-move
+
+
+Scenario: pre-move promotion should not ask yet
+ Given I start server and client
+ Then I am ready to play
+ And I set position of "*chess-network*<1>" to fen "rnbqkbn1/pppppppP/8/8/8/8/PPPPPPP1/RNBQKBNR w - -"
+ And I send position from "*chess-network*<1>"
+ And white moves "d4"
+ And white selects "h7"
+ And white selects "h8"
+ Then the square at "h8" is highlighted pre-move
diff --git a/features/step-definitions/emacs-chess-steps.el b/features/step-definitions/emacs-chess-steps.el
index 5e1b6cc..b0d2ae0 100644
--- a/features/step-definitions/emacs-chess-steps.el
+++ b/features/step-definitions/emacs-chess-steps.el
@@ -9,7 +9,7 @@
(process-send-string test-fifo "login:\n")
(process-send-string test-fifo "Logging you in as \"GuestME\"\n")
(process-send-string test-fifo "fics% \n")
- (sleep-for 3)
+ (sleep-for 2)
(chess-ics "nowhere.org" 5000 nil nil "sh" "-c" (format "cat %s" test-fn))
)))
@@ -20,16 +20,35 @@
(process-send-string test-fifo (format "<12> rnbqkbnr pppppppp -------- -------- -------- -------- PPPPPPPP RNBQKBNR W -1 1 1 1 1 0 23 GuestYOU GuestME -1 5 5 39 39 300 300 1 none (0:00) none 1 0 0\n"))
(process-send-string test-fifo (format "<12> rnbqkbnr pppppppp -------- -------- --P----- -------- PP-PPPPP RNBQKBNR B 2 1 1 1 1 0 23 GuestYOU GuestME 1 5 5 39 39 300 300 1 P/c2-c4 (0:00) c4 1 0 0\n"))
(process-send-string test-fifo (format "<12> rnbqkbnr pppp-ppp -------- ----p--- --P----- -------- PP-PPPPP RNBQKBNR W 4 1 1 1 1 0 23 GuestYOU GuestME -1 5 5 39 39 300 300 2 P/e7-e5 (0:00) e5 1 1 0\n"))
- (sleep-for 3)
+ (sleep-for 2)
)
)
(When "^opponent forfeits on time$"
(lambda ()
(process-send-string test-fifo (format "{Game 42 (GuestYOU vs. GuestME) GuestYOU forfeits on time} 0-1\n"))
- (sleep-for 3)
+ (sleep-for 2)
))
+(When "^opponent forfeits by disconnection$"
+ (lambda ()
+ (process-send-string test-fifo (format "{Game 42 (GuestYOU vs. GuestME) GuestYOU forfeits by disconnection} 1-0\n"))
+ (sleep-for 2)
+ ))
+
+(When "^opponent aborts$"
+ (lambda ()
+ (process-send-string test-fifo (format "Your opponent has aborted the game on move one.\n"))
+ (sleep-for 2)
+ ))
+
+(When "^I specify a good port$"
+ (lambda ()
+ (if espuds-chain-active
+ (progn
+ (setq espuds-action-chain (vconcat espuds-action-chain (string-to-vector test-port))))
+ (execute-kbd-macro (string-to-vector test-port)))))
+
(Given "^game with fen \"\\(.+\\)\"$"
(lambda (fen)
(let ((game (chess-game-create (chess-fen-to-pos fen))) objects)
@@ -37,6 +56,22 @@
'chess--create-display
game t t))))))
+(When "^I set position of \"\\(.+\\)\" to fen \"\\(.+\\)\"$"
+ (lambda (process-name fen)
+ (chess-with-current-buffer (process-buffer (get-process process-name))
+ (chess-engine-set-position nil (chess-fen-to-pos fen)))
+ (sleep-for 2)
+))
+
+
+(When "^I send position from \"\\(.+\\)\"$"
+ (lambda (process-name)
+ (chess-with-current-buffer (process-buffer (get-process process-name))
+ (chess-game-run-hooks chess-module-game 'setup-pos (chess-game-pos chess-module-game)))
+ (sleep-for 2)
+))
+
+
(Then "^the move \"\\([a-h][1-8]\\)-\\([a-h][1-8]\\)\" is illegal$"
(lambda (source target)
(let ((position (chess-display-position test-display)))
@@ -44,4 +79,109 @@
(chess-coord-to-index source)
(chess-coord-to-index target)))))))
+(Then "^I am ready to play$"
+ (lambda ()
+ (let ((ready (apply 'chess-string 'opp-ready (list user-full-name))))
+ (Then "I should see message \"%s\"" ready))))
+
+(When "^\\(white\\|black\\) moves \"\\(.+\\)\"$"
+ (lambda (color move)
+ (if (string= "white" color)
+ (Given "I switch to buffer \"*Chessboard*\"")
+ (Given "I switch to buffer \"*Chessboard*<2>\""))
+ (When "I type \"%s\"" move)
+ (sleep-for 1)
+))
+
+(When "^\\(white\\|black\\) selects \"\\([a-h][1-8]\\)\"$"
+ (lambda (color source)
+ (if (string= "white" color)
+ (Given "I switch to buffer \"*Chessboard*\"")
+ (Given "I switch to buffer \"*Chessboard*<2>\""))
+ (When "I go to point \"%s\"" (number-to-string (chess-display-index-pos nil (chess-coord-to-index source))))
+ (When "I press \"RET\"")
+ (sleep-for 1)
+))
+
+(Then "^paint-move last \\([0-9]+\\) plies less than \\([0-9]+\\) microseconds"
+ (lambda (times micros)
+ (dotimes (i (string-to-number times))
+ (let ((ply (chess-game-ply chess-module-game (1- (- chess-display-index i)))))
+ (assert (< (measure-time (chess-display-paint-move nil ply))
+ (/ (string-to-number micros) 1e6)))))))
+
+(Given "^I start server and client$"
+ (lambda ()
+ (Given "I start server")
+ (sleep-for 1)
+ (Given "I start client")
+ (sleep-for 1)
+ ))
+
+(Given "^I start server$"
+ (lambda ()
+ (And "I start an action chain")
+ (And "I press \"C-u M-x\"")
+ (And "I type \"chess\"")
+ (And "I press \"RET\"")
+ (And "I type \"network\"")
+ (And "I press \"RET\"")
+ (And "I press \"s\"")
+ (And "I specify a good port")
+ (And "I press \"RET\"")
+ (And "I execute the action chain")))
+
+(Given "^I start client$"
+ (lambda ()
+ (And "I start an action chain")
+ (And "I press \"C-u M-x\"")
+ (And "I type \"chess\"")
+ (And "I press \"RET\"")
+ (And "I type \"network\"")
+ (And "I press \"RET\"")
+ (And "I press \"c\"")
+ (And "I type \"localhost\"")
+ (And "I press \"RET\"")
+ (And "I specify a good port")
+ (And "I press \"RET\"")
+ (And "I execute the action chain")
+))
+
+(Then "^the square at \"\\([a-h][1-8]\\)\" is highlighted \\(.+\\)$"
+ (lambda (source kind)
+ (if (display-graphic-p)
+ (let ((prop (copy-alist (get-text-property
+ (chess-display-index-pos nil (chess-coord-to-index source))
+ 'display))))
+ (chess-display-highlight nil
+ (cond ((string= kind "selected")
+ chess-images-highlight-color)
+ ((string= kind "pre-move")
+ chess-display-pre-move-color)
+ ((string= kind "last-move")
+ chess-display-last-move-color)
+ ((string= kind "legal")
+ chess-display-legal-move-color)
+ (t chess-display-last-move-color))
+ (chess-coord-to-index source))
+ (assert (equal prop (get-text-property
+ (chess-display-index-pos nil (chess-coord-to-index source))
+ 'display))))
+ (assert (eq (get-text-property
+ (chess-display-index-pos nil (chess-coord-to-index source))
+ 'face) (cond ((string= kind "selected") 'chess-ics1-highlight-face)
+ (t 'chess-display-highlight)))))))
+(Then "^the square at \"\\([a-h][1-8]\\)\" is unhighlighted$"
+ (lambda (source)
+ (if (display-graphic-p)
+ (let ((prop (copy-alist (get-text-property
+ (chess-display-index-pos nil (chess-coord-to-index source))
+ 'display))))
+ (chess-display-unhighlight-square nil (chess-coord-to-index source))
+ (assert (equal prop (get-text-property
+ (chess-display-index-pos nil (chess-coord-to-index source))
+ 'display))))
+ (assert (not (eq (get-text-property
+ (chess-display-index-pos nil (chess-coord-to-index source))
+ 'face) 'chess-display-highlight))))))
diff --git a/features/support/env.el b/features/support/env.el
index 58ed42f..3429e34 100644
--- a/features/support/env.el
+++ b/features/support/env.el
@@ -9,9 +9,17 @@
(defvar emacs-chess-root-path
(f-parent emacs-chess-features-path))
+;; Nikolaj Schumacher
+(defmacro measure-time (&rest body)
+ "Measure the time it takes to evaluate BODY."
+ `(let ((time (current-time)))
+ ,@body
+ (float-time (time-since time))))
+
(add-to-list 'load-path emacs-chess-root-path)
(require 'chess-ics)
+(require 'chess)
(require 'espuds)
(require 'ert)
(require 'cl)
@@ -19,6 +27,18 @@
(Setup
(defvar test-display nil)
(defvar test-fifo nil)
+ (defvar test-port nil)
+ (setq test-port (catch 'loop
+ (dolist (cand (list "5678" "5413" "5142" "5308" "5987"))
+ (when (= 1 (call-process "nc" nil nil nil "-z" "localhost" cand))
+ (throw 'loop cand)))))
+ (setq noninteractive t)
+ (custom-set-variables '(chess-sound-moves nil)
+ '(chess-display-highlight-last-move t)
+ '(chess-display-highlight-legal t)
+ '(chess-display-popup nil)
+ '(chess-display-allow-pre-moves t)
+ '(chess-images-separate-frame nil))
)
(Before
@@ -30,12 +50,13 @@
(when test-display
(chess-module-destroy test-display)
(setq test-display nil))
- (when (process-status "*chess-ics*")
- (delete-process "*chess-ics*"))
- (when test-fifo
- (process-send-eof test-fifo)
- (delete-process test-fifo)
- (setq test-fifo nil))
+ (dolist (p (process-list))
+ (delete-process p))
+ (setq test-fifo nil)
+ (let ((buf (get-buffer "*Chessboard*"))
+ (buf2 (get-buffer "*Chessboard*<2>")))
+ (if buf (kill-buffer buf))
+ (if buf2 (kill-buffer buf2)))
)
(Teardown