- Let the user specify a default size for the chess-images display
-- allow dragging of pieces
+- Allow dragging of pieces
+
+- check for chess engine resignations
----------------------------------------------------------------------
(when (and proc (eq (process-status proc) 'run))
(process-send-string proc (concat text "\n"))
(process-send-eof proc))))
+
+(provide 'chess-announce)
+
+;;; chess-announce.el ends here
:type 'file
:group 'chess-crafty)
-(defvar chess-crafty-now-moving nil)
-
(defvar chess-crafty-regexp-alist
- (list (cons
- (concat "\\s-*\\(White\\|Black\\)\\s-*([0-9]+):\\s-+\\("
- chess-algebraic-regexp "\\)\\s-*$")
- 'chess-crafty-perform-move)
+ (list (cons (concat "\\s-*\\(White\\|Black\\)\\s-*([0-9]+):\\s-+\\("
+ chess-algebraic-regexp "\\)\\s-*$")
+ (function
+ (lambda ()
+ (funcall chess-engine-response-handler 'move
+ (match-string 0)))))
(cons "Illegal move:\\s-*\\(.*\\)"
(function
(lambda ()
(signal 'chess-illegal (match-string 1)))))))
-(defun chess-crafty-perform-move ()
- (let ((position (chess-engine-position nil))
- (move (match-string 2)) ply)
- (when (string= (if (chess-pos-side-to-move position)
- "White" "Black")
- (match-string 1))
- (setq ply (chess-algebraic-to-ply position move))
- (unless ply
- (error "Could not convert engine move: %s" move))
- (let ((chess-crafty-now-moving t))
- (funcall chess-engine-response-handler 'move ply)))))
-
(defun chess-crafty-handler (event &rest args)
(cond
((eq event 'initialize)
(chess-engine-send nil "go\n"))
((eq event 'move)
- (unless chess-crafty-now-moving
- (chess-engine-send nil (concat (chess-ply-to-algebraic (car args))
- "\n"))))))
+ (chess-engine-send nil (concat (chess-ply-to-algebraic (car args))
+ "\n")))))
(provide 'chess-crafty)
(with-current-buffer display
(cond
((eq event 'shutdown)
- (chess-display-destroy nil))
+ (ignore-errors
+ (chess-display-destroy nil)))
((eq event 'pass)
(chess-display-set-perspective
nil (not (chess-display-perspective nil))))
- ((memq event '(move game-over))
- (chess-display-set-index
- nil (chess-game-index (chess-display-game nil)))))
+ ((memq event '(move game-over resign))
+ (chess-display-set-index nil (chess-game-index
+ (chess-display-game nil)))))
+ (if (eq event 'resign)
+ (message-box "%s resigns" (if (car args) "White" "Black")))
(unless (eq event 'shutdown)
(chess-display-update nil))))
(define-key map [?@] 'chess-display-remote)
(define-key map [? ] 'chess-display-pass)
(define-key map [?S] 'chess-display-shuffle)
+ (define-key map [?R] 'chess-display-resign)
(define-key map [?<] 'chess-display-move-first)
(define-key map [?,] 'chess-display-move-backward)
(interactive)
(let* ((x-select-enable-clipboard t)
(fen (chess-pos-to-fen (chess-display-position nil))))
- (kill-new fen)
- (message "Copied board: %s" fen)))
+ (kill-new fen)))
(defun chess-display-paste-board ()
"Send the current board configuration to the user."
(interactive)
(let* ((x-select-enable-clipboard t)
(fen (current-kill 0)))
- (chess-display-set-from-fen fen)
- (message "Pasted board: %s" fen)))
+ (chess-display-set-from-fen fen)))
(defun chess-display-set-piece ()
"Set the piece under point to command character, or space for clear."
(defun chess-display-pass ()
"Pass the move to your opponent. Only valid on the first move."
(interactive)
- (when (and (chess-display-active-p)
- (= 0 (chess-display-index nil)))
- (chess-game-run-hooks chess-display-game 'pass)))
+ (if (and (chess-display-active-p)
+ (= 0 (chess-display-index nil)))
+ (chess-game-run-hooks chess-display-game 'pass)
+ (ding)))
(defun chess-display-shuffle ()
"Generate a shuffled opening position."
(interactive)
- (when (and (chess-display-active-p)
- (= 0 (chess-display-index nil)))
- (chess-game-set-start-position chess-display-game
- (chess-fischer-random-position))))
+ (if (and (chess-display-active-p)
+ (= 0 (chess-display-index nil)))
+ (chess-game-set-start-position chess-display-game
+ (chess-fischer-random-position))
+ (ding)))
+
+(defun chess-display-resign ()
+ "Generate a shuffled opening position."
+ (interactive)
+ (if (chess-display-active-p)
+ (chess-game-resign chess-display-game)
+ (ding)))
(defun chess-display-set-current (dir)
"Change the currently displayed board.
(defvar chess-engine-process nil)
(defvar chess-engine-last-pos nil)
(defvar chess-engine-working nil)
+(defvar chess-engine-handling-event nil)
(make-variable-buffer-local 'chess-engine-process)
(make-variable-buffer-local 'chess-engine-last-pos)
(setq chess-engine-position (chess-ply-next-pos ply)))))
(defun chess-engine-default-handler (event &rest args)
- (cond
- ((eq event 'move)
- (chess-engine-do-move (car args)))
+ (let ((chess-engine-handling-event t))
+ (cond
+ ((eq event 'move)
+ (let ((ply (chess-algebraic-to-ply (chess-engine-position nil)
+ (car args))))
+ (if ply
+ (chess-engine-do-move ply)
+ (message "Received invalid move from engine: %s" (car args)))))
+
+ ((eq event 'pass)
+ (message "Your opponent has passed the first move to you"))
- ((eq event 'pass)
- (message "Your opponent has passed the first move to you"))
+ ((eq event 'connect)
+ (message "Your opponent, %s, is now ready to play" (car args)))
- ((eq event 'connect)
- (message "Your opponent, %s, is now ready to play" (car args)))
+ ((eq event 'quit)
+ (message "Your opponent has quit playing"))
- ((eq event 'quit)
- (message "Your opponent has quit playing"))
+ ((eq event 'resign)
+ (if chess-engine-game
+ (chess-engine-resign chess-engine-game)))
- ((eq event 'setup)
- (chess-game-set-start-position (chess-engine-game nil)
- (chess-fen-to-pos (car args))))))
+ ((eq event 'setup)
+ (chess-game-set-start-position (chess-engine-game nil)
+ (chess-fen-to-pos (car args)))))))
(defun chess-engine-create (module &optional user-handler &rest args)
(let ((regexp-alist (intern-soft (concat (symbol-name module)
"-regexp-alist")))
(handler (intern-soft (concat (symbol-name module) "-handler"))))
(with-current-buffer (generate-new-buffer " *chess-engine*")
- (setq chess-engine-regexp-alist (symbol-value regexp-alist)
- chess-engine-event-handler handler
- chess-engine-response-handler (or user-handler
- 'chess-engine-default-handler))
(let ((proc (apply handler 'initialize args)))
+ (setq chess-engine-regexp-alist (symbol-value regexp-alist)
+ chess-engine-event-handler handler
+ chess-engine-response-handler
+ (or user-handler 'chess-engine-default-handler))
(when (processp proc)
(unless (memq (process-status proc) '(run open))
(error "Failed to start chess engine process"))
(defun chess-engine-event-handler (game engine event &rest args)
"Handle any commands being sent to this instance of this module."
- (with-current-buffer engine
- (assert (eq game (chess-engine-game nil)))
- (apply chess-engine-event-handler event args)
+ (unless chess-engine-handling-event
+ (if (buffer-live-p engine)
+ (with-current-buffer engine
+ (assert (eq game (chess-engine-game nil)))
+ (apply chess-engine-event-handler event args)))
(cond
((eq event 'shutdown)
- (chess-engine-destroy engine)))))
+ (ignore-errors
+ (chess-engine-destroy engine))))))
(defun chess-engine-filter (proc string)
"Filter for receiving text for an engine from an outside source."
(unless chess-engine-working
(setq chess-engine-working t)
(unwind-protect
- (progn
+ (save-excursion
(if chess-engine-last-pos
(goto-char chess-engine-last-pos)
(goto-char (point-min)))
(beginning-of-line)
(while (not (eobp))
- (condition-case err
- (let ((triggers chess-engine-regexp-alist))
- (while triggers
- ;; this could be accelerated by joining
- ;; together the regexps
- (if (looking-at (caar triggers))
- (progn
- (funcall (cdar triggers))
- (setq triggers nil))
- (setq triggers (cdr triggers)))))
- (chess-illegal (error-message-string err)))
+ (let ((triggers chess-engine-regexp-alist))
+ (while triggers
+ ;; this could be accelerated by joining
+ ;; together the regexps
+ (if (looking-at (caar triggers))
+ (progn
+ (funcall (cdar triggers))
+ (setq triggers nil))
+ (setq triggers (cdr triggers)))))
(forward-line)))
(setq chess-engine-last-pos (point)
chess-engine-working nil)))))))
(let ((current-ply (chess-game-ply game))
(changes (chess-ply-changes ply))
(position (chess-ply-pos ply)))
+ (if (chess-ply-final-p current-ply)
+ (error "Cannot add moves to a completed game"))
(unless (equal position (chess-ply-pos current-ply))
(error "Positions do not match"))
- (unless (chess-search-position
- position (cadr (chess-ply-changes ply))
- (chess-pos-piece position (car (chess-ply-changes ply))))
+ (unless (or (chess-ply-has-keyword ply :resign)
+ (chess-search-position
+ position (cadr (chess-ply-changes ply))
+ (chess-pos-piece position (car (chess-ply-changes ply)))))
(signal 'chess-illegal "Illegal move"))
(chess-ply-set-changes current-ply changes)
(chess-game-add-ply game (chess-ply-create
(chess-ply-next-pos current-ply)))
(cond
- ((or (memq :draw changes)
- (memq :perpetual changes)
- (memq :repetition changes)
- (memq :stalemate changes))
+ ((chess-ply-has-keyword ply :draw :perpetual :repetition :stalemate)
(chess-game-set-tag game "Result" "1/2-1/2")
- (chess-game-run-hooks game 'game-over))
+ (chess-game-run-hooks game 'game-drawn))
- ((or (memq :resign changes)
- (memq :checkmate changes))
- (chess-game-set-tag game "Result" (if (chess-game-side-to-move game)
- "0-1" "1-0"))
- (chess-game-run-hooks game 'game-over))
+ ((chess-ply-has-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-has-keyword ply :resign)
+ (chess-game-run-hooks game 'resign color)
+ (chess-game-run-hooks game 'game-over))))
(t
(chess-game-run-hooks game 'move current-ply)))))
+(defsubst chess-game-resign (game)
+ "Resign the current game."
+ (chess-game-move game (list (chess-game-pos game) :resign)))
+
(provide 'chess-game)
;;; chess-game.el ends here
:type 'file
:group 'chess-gnuchess)
-(defvar chess-gnuchess-now-moving nil)
-
(defvar chess-gnuchess-temp-files nil)
(defvar chess-gnuchess-bad-board nil)
(make-variable-buffer-local 'chess-gnuchess-temp-files)
(list (cons (concat "My move is : \\(" chess-algebraic-regexp "\\)")
(function
(lambda ()
- (let* ((move (match-string 1))
- (ply (chess-algebraic-to-ply
- (chess-engine-position nil) move)))
- (unless ply
- (error "Could not convert engine move: %s" move))
- (let ((chess-gnuchess-now-moving t))
- (funcall chess-engine-response-handler 'move ply))))))
+ (funcall chess-engine-response-handler 'move
+ (match-string 1)))))
(cons "Illegal move:"
(function
(lambda ()
(setq chess-gnuchess-bad-board nil))
((eq event 'move)
- (unless chess-gnuchess-now-moving
- (chess-engine-send nil (concat (chess-ply-to-algebraic (car args))
- "\n"))
- (when chess-gnuchess-bad-board
- (chess-engine-send nil "go\n")
- (setq chess-gnuchess-bad-board nil))))))
+ (chess-engine-send nil (concat (chess-ply-to-algebraic (car args))
+ "\n"))
+ (when chess-gnuchess-bad-board
+ (chess-engine-send nil "go\n")
+ (setq chess-gnuchess-bad-board nil)))))
(provide 'chess-gnuchess)
--- /dev/null
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; An engine for interacting with Internet Chess Servers
+;;
+;; $Revision$
+
+(require 'chess-network)
+(require 'ics)
+
+(defgroup chess-ics nil
+ "Engine for interacting with Internet Chess Servers."
+ :group 'chess-engine)
+
+(defvar chess-ics-ensure-ics12 nil)
+(make-variable-buffer-local 'chess-ics-ensure-ics12)
+
+;; ICS12 format:
+;; <12> rnbqkbnr pppppppp -------- -------- -------- -------- PPPPPPPP RNBQKBNR W -1 1 1 1 1 0 65 jwiegley GuestZYNJ 1 5 0 39 39 300 300 1 none (0:00) none 0 0 0
+
+(defun chess-ics-handle-move ()
+ (let ((begin (match-beginning 1))
+ (end (match-end 1))
+ (color (string= (match-string 2) "W"))
+ (white (match-string 3))
+ (move (match-string 4)))
+ (if (and (not (string= white ics-handle))
+ (= 0 (chess-game-index (chess-engine-game nil))))
+ (chess-game-run-hooks (chess-engine-game nil) 'pass)
+ (if (eq color (chess-pos-side-to-move
+ (chess-engine-position nil)))
+ (funcall chess-engine-response-handler
+ 'move move))
+ (delete-region begin end))))
+
+(defvar chess-ics-regexp-alist
+ (list
+ (cons (concat "\\(<12> \\S-+ \\S-+ \\S-+ \\S-+ \\S-+ \\S-+ \\S-+ \\S-+ "
+ "\\([BW]\\) [-0-9]+ "
+ "[-0-9]+ [-0-9]+ [-0-9]+ [-0-9]+ [-0-9]+ "
+ "[-0-9]+ \\(\\S-+\\) \\S-+ "
+ "[-0-9]+ [-0-9]+ [-0-9]+ "
+ "[-0-9]+ [-0-9]+ [-0-9]+ [-0-9]+ "
+ "[-0-9]+ \\S-+ \\S-+ \\(\\S-+\\)\\)")
+ 'chess-ics-handle-move)
+ (cons "You accept the match offer from \\([^\\.]+\\)."
+ (function
+ (lambda ()
+ (funcall chess-engine-response-handler 'connect
+ (match-string 1)))))))
+
+(defun chess-ics-handler (event &rest args)
+ (cond
+ ((eq event 'initialize)
+ (let* ((old-buffer (current-buffer))
+ (address-or-alias (read-from-minibuffer
+ "ICS Server address or alias: "))
+ (server-info-list (cdr (assoc address-or-alias
+ ics-servers-alist)))
+ (ics-address (or (car (cdr server-info-list))
+ address-or-alias))
+ (ics-connect-method (or (car (nthcdr 3 server-info-list))
+ ics-default-connect-method))
+ (server-name (or (car server-info-list)
+ address-or-alias))
+ (ics-port (or (car (nthcdr 2 server-info-list))
+ (read-from-minibuffer "ICS port: "
+ ics-default-port)))
+ (handle (read-from-minibuffer "ICS Handle: "
+ ics-default-handle))
+ (proc (concat server-name ":" handle))
+ (buffer (concat "*" proc "*")))
+
+ (setq ics-handle handle)
+
+ (if (comint-check-proc buffer)
+ (set-buffer buffer)
+ (run-hooks 'ics-pre-connect-hook)
+ (set-buffer (make-comint proc (cons ics-address ics-port)))
+ (run-hooks 'ics-post-connect-hook)
+ (ics-mode))
+
+ (set (make-variable-buffer-local 'ics-last-command-time)
+ (ics-current-time))
+ (set (make-variable-buffer-local 'ics-idle-p) nil)
+ (set (make-variable-buffer-local 'ics-interface-variable-set) nil)
+ (set (make-variable-buffer-local 'ics-wakeup-last-alarm-time)
+ (ics-current-time))
+ (set (make-variable-buffer-local 'ics-last-highlight-end) nil)
+ (set (make-variable-buffer-local 'ics-last-add-buttons-end) nil)
+
+ (add-hook 'comint-output-filter-functions 'chess-ics-filter t t)
+ (set (make-local-variable 'comint-preoutput-filter-functions)
+ '(chess-ics-strip-cr))
+
+ (display-buffer buffer)
+ (kill-buffer old-buffer)
+
+ nil))
+
+ ((eq event 'shutdown)
+ (ignore-errors
+ (chess-engine-send nil "quit\n")))
+
+ ((eq event 'move)
+ (unless chess-ics-ensure-ics12
+ (comint-send-string (get-buffer-process (current-buffer))
+ "set style 12\n")
+ (setq chess-ics-ensure-ics12 t))
+ (chess-engine-send nil (concat (chess-ply-to-algebraic (car args))
+ "\n")))
+
+ ((eq event 'send)
+ (comint-send-string (get-buffer-process (current-buffer)) (car args)))))
+
+(defun chess-ics-filter (string)
+ (save-excursion
+ (if chess-engine-last-pos
+ (goto-char chess-engine-last-pos)
+ (goto-char (point-min)))
+ (beginning-of-line)
+ (while (not (eobp))
+ (let ((triggers chess-ics-regexp-alist))
+ (while triggers
+ ;; this could be accelerated by joining together the
+ ;; regexps
+ (if (looking-at (concat "[^\n\r]*" (caar triggers)))
+ (progn
+ (funcall (cdar triggers))
+ (setq triggers nil))
+ (setq triggers (cdr triggers)))))
+ (forward-line))
+ (setq chess-engine-last-pos (point))))
+
+(defun chess-ics-strip-cr (string)
+ (while (string-match "\r" string)
+ (setq string (replace-match "" t t string)))
+ string)
+
+(provide 'chess-ics)
+
+;;; chess-ics.el ends here
(require 'chess-fen)
(require 'chess-algebraic)
-(defvar chess-network-now-moving nil)
-
(defvar chess-network-regexp-alist
(list (cons chess-algebraic-regexp
- 'chess-network-perform-move)
+ (function
+ (lambda ()
+ (funcall chess-engine-response-handler 'move
+ (match-string 0)))))
(cons "pass"
(function
(lambda ()
(cons "quit"
(function
(lambda ()
- (funcall chess-engine-response-handler 'quit))))))
-
-(defun chess-network-perform-move ()
- (let* ((move (match-string 1))
- (ply (chess-algebraic-to-ply (chess-engine-position nil) move)))
- (if ply
- (let ((chess-network-now-moving t))
- (funcall chess-engine-response-handler 'move ply))
- (message "Received invalid move: %s" move))))
+ (funcall chess-engine-response-handler 'quit))))
+ (cons "resign"
+ (function
+ (lambda ()
+ (funcall chess-engine-response-handler 'resign))))))
(defun chess-network-handler (event &rest args)
"Initialize the network chess engine."
((eq event 'pass)
(chess-engine-send nil "pass\n"))
+ ((eq event 'resign)
+ (chess-engine-send nil "resign\n"))
+
((eq event 'move)
- (unless chess-network-now-moving
- (chess-engine-send nil (concat (chess-ply-to-algebraic (car args))
- "\n"))))))
+ (chess-engine-send nil (concat (chess-ply-to-algebraic (car args))
+ "\n")))))
(provide 'chess-network)
(defsubst chess-ply-set-changes (ply changes)
(setcdr ply changes))
-(defsubst chess-ply-has-keyword (ply keyword)
- (memq keyword (chess-ply-changes)))
+(defun chess-ply-has-keyword (ply &rest keywords)
+ (let (found)
+ (dolist (keyword keywords)
+ (if (memq keyword (chess-ply-changes ply))
+ (setq found t)))
+ found))
(defsubst chess-ply-source (ply)
(car (chess-ply-changes)))
;; return the annotated ply
ply))))
-(defun chess-ply-final-p (ply)
+(defsubst chess-ply-final-p (ply)
"Return non-nil if this is the last ply of a game/variation."
- (let ((changes (chess-ply-changes ply)))
- (or (memq :draw changes)
- (memq :perpetual changes)
- (memq :repetition changes)
- (memq :stalemate changes)
- (memq :resign changes)
- (memq :checkmate changes))))
+ (chess-ply-has-keyword ply :draw :perpetual :repetition :stalemate
+ :resign :checkmate))
(defun chess-legal-plies (position)
"Return a list of all legal plies in POSITION."
(when (and engine-module
(require engine-module nil t))
(chess-engine-set-game (chess-engine-create engine-module) game)
- (if chess-announce-moves
- (chess-announce-for-game game t))))))
+ (when chess-announce-moves
+ (require 'chess-announce)
+ (chess-announce-for-game game t))))))
(cons display engine)))
;;;###autoload