diff options
| -rw-r--r-- | TODO | 4 | ||||
| -rw-r--r-- | chess-announce.el | 4 | ||||
| -rw-r--r-- | chess-crafty.el | 29 | ||||
| -rw-r--r-- | chess-display.el | 41 | ||||
| -rw-r--r-- | chess-engine.el | 75 | ||||
| -rw-r--r-- | chess-game.el | 31 | ||||
| -rw-r--r-- | chess-gnuchess.el | 22 | ||||
| -rw-r--r-- | chess-ics.el | 141 | ||||
| -rw-r--r-- | chess-network.el | 29 | ||||
| -rw-r--r-- | chess-ply.el | 19 | ||||
| -rw-r--r-- | chess.el | 5 |
11 files changed, 276 insertions, 124 deletions
@@ -54,7 +54,9 @@ - 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 ---------------------------------------------------------------------- diff --git a/chess-announce.el b/chess-announce.el index 5fb83a7..873531c 100644 --- a/chess-announce.el +++ b/chess-announce.el @@ -77,3 +77,7 @@ See `chess-display-type' for the different kinds of displays." (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 diff --git a/chess-crafty.el b/chess-crafty.el index 50b4dc0..3b58f11 100644 --- a/chess-crafty.el +++ b/chess-crafty.el @@ -18,30 +18,18 @@ :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) @@ -77,9 +65,8 @@ (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) diff --git a/chess-display.el b/chess-display.el index 0d53548..85eac1b 100644 --- a/chess-display.el +++ b/chess-display.el @@ -285,15 +285,18 @@ See `chess-display-type' for the different kinds of displays." (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)))) @@ -321,6 +324,7 @@ See `chess-display-type' for the different kinds of displays." (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) @@ -424,16 +428,14 @@ Basically, it means we are playing, not editing or reviewing." (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." @@ -475,17 +477,26 @@ Basically, it means we are playing, not editing or reviewing." (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. diff --git a/chess-engine.el b/chess-engine.el index 807f99d..bbca8e2 100644 --- a/chess-engine.el +++ b/chess-engine.el @@ -29,6 +29,7 @@ (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) @@ -56,33 +57,42 @@ (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")) @@ -186,12 +196,15 @@ (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." @@ -210,23 +223,21 @@ (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))))))) diff --git a/chess-game.el b/chess-game.el index d1eb706..a33971f 100644 --- a/chess-game.el +++ b/chess-game.el @@ -148,32 +148,37 @@ 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) + (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 diff --git a/chess-gnuchess.el b/chess-gnuchess.el index 1d87173..c619bb3 100644 --- a/chess-gnuchess.el +++ b/chess-gnuchess.el @@ -17,8 +17,6 @@ :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) @@ -28,13 +26,8 @@ (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 () @@ -85,12 +78,11 @@ (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) diff --git a/chess-ics.el b/chess-ics.el new file mode 100644 index 0000000..69eae89 --- /dev/null +++ b/chess-ics.el @@ -0,0 +1,141 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; 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 diff --git a/chess-network.el b/chess-network.el index af833ee..af22f92 100644 --- a/chess-network.el +++ b/chess-network.el @@ -8,11 +8,12 @@ (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 () @@ -30,15 +31,11 @@ (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." @@ -71,10 +68,12 @@ ((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) diff --git a/chess-ply.el b/chess-ply.el index adbeeed..a921238 100644 --- a/chess-ply.el +++ b/chess-ply.el @@ -62,8 +62,12 @@ (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))) @@ -168,15 +172,10 @@ maneuver." ;; 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." @@ -122,8 +122,9 @@ minibuffer, which works well for Emacspeak users." (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 |