code.delx.au - gnu-emacs-elpa/blob - chess-ics.el

   1 ;;; chess-ics.el --- An engine for interacting with Internet Chess Servers
   2
   3 ;; Copyright (C) 2002, 2003, 2004  Free Software Foundation, Inc.
   4
   5 ;; Author: John Wiegley
   6 ;; Maintainer: Mario Lang <mlang@delysid.org>
   7 ;; Keywords: games, processes
   8
   9 ;; This file is free software; you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation; either version 2, or (at your option)
  12 ;; any later version.
  13
  14 ;; This file is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with GNU Emacs; see the file COPYING.  If not, write to
  21 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  22 ;; Boston, MA 02111-1307, USA.
  23
  24 (eval-when-compile (require 'cl))
  25
  26 (require 'comint)
  27 (require 'chess)
  28 (require 'chess-network)
  29 (require 'chess-pos)
  30
  31 (eval-when-compile (require 'rx))
  32
  33 (defgroup chess-ics nil
  34   "Engine for interacting with Internet Chess Servers."
  35   :group 'chess-engine)
  36
  37 (defcustom chess-ics-server-list '(("freechess.org" 5000)
  38                                    ("chess.unix-ag.uni-kl.de" 5000)
  39                                    ("chess.mds.mdh.se" 5000)
  40                                    ("chessclub.com" 5000))
  41   "A list of servers to connect to.
  42 The format of each entry is:
  43
  44   (SERVER PORT [HANDLE] [PASSWORD-OR-FILENAME] [HELPER] [HELPER ARGS...])"
  45   :type '(repeat (list (string :tag "Server")
  46                        (integer :tag "Port")
  47                        (choice (const :tag "Login as guest" nil)
  48                                (string :tag "Handle"))
  49                        (choice (const :tag "No password or ask" nil)
  50                                (string :tag "Password")
  51                                (file :tag "Filename"))
  52                        (choice (const :tag "Direct connection" nil)
  53                                (file :tag "Command"))
  54                        (choice (const :tag "No arguments" nil)
  55                                (repeat string))))
  56   :group 'chess-ics)
  57
  58 (defcustom chess-ics-initial-commands
  59   (list
  60    (list "freechess.org"
  61          "iset defprompt 1"  ; So we can't be supprised by a user setting
  62          (format "set interface emacs-chess %s" chess-version)
  63          "iset seekremove 1" ; For real-time sought display
  64          "iset startpos 1"   ; Sends initial position before movelist
  65          "set style 12"      ; So we can parse the board "easily"
  66          "set bell 0")       ; We have our own way of announcing events
  67    (list nil
  68          (format "set interface emacs-chess %s" chess-version)
  69          "set style 12"      ; So we can parse the board "easily"
  70          "set bell 0"))
  71   "A list of commands to send automatically upon successful login.
  72 The format is (SERVER COMMANDS...) where SERVER is either the server-name
  73 \(see `chess-ics-server-list') or nil, which is the default to use for all
  74 servers which do not have a specialized entry in this list.  COMMAND is a
  75 string which should be sent (newline characters will be added automatically.)"
  76   :group 'chess-ics
  77   :type '(repeat
  78           (list :tag "Initialisation for"
  79                 (choice (string :tag "Server Name") (const :tag "Default" nil))
  80                 (repeat :inline t (string :tag "Command")))))
  81
  82 (defvar chess-ics-server nil
  83   "The ICS server name of this connection.")
  84 (make-variable-buffer-local 'chess-ics-server)
  85
  86 (defvar chess-ics-handle nil
  87   "The ICS handle of this connection.")
  88 (make-variable-buffer-local 'chess-ics-handle)
  89
  90 (defvar chess-ics-password nil
  91   "Password to use to identify to the server.")
  92 (make-variable-buffer-local 'chess-ics-password)
  93
  94 (defvar chess-ics-handling-login nil
  95   "Non-nil if we are currently handling the ICS login sequence.")
  96 (make-variable-buffer-local 'chess-ics-handling-login)
  97
  98 (defvar chess-ics-movelist-game-number nil
  99   "If we are about to receive a movelist, this variable is set to the
 100 game number.")
 101 (make-variable-buffer-local 'chess-ics-movelist-game-number)
 102
 103 (defvar chess-ics-movelist-game nil
 104   "If we are receiving a movelist, this variable is set to the game object.")
 105 (make-variable-buffer-local 'chess-ics-movelist-game)
 106
 107 (defvar chess-ics-movelist-start-position chess-starting-position
 108   "The starting position to use upon receiving of a movelist.
 109 It is possible to configure certain servers to automatically send a
 110 style12 board before sending a movelist, to allow retrieval of
 111 the movelist for a non-standard game (one which does not start at the
 112 standard position).  In those cases, this variable should be set to nil.")
 113 (make-variable-buffer-local 'chess-ics-movelist-start-position)
 114
 115 (defsubst chess-ics-send (string &optional buffer)
 116   "Send STRING to the ICS server."
 117   (comint-send-string (get-buffer-process (or buffer (current-buffer)))
 118                       (concat string "\n")))
 119
 120 (chess-message-catalog 'english
 121   '((ics-server-prompt . "Connect to chess server: ")
 122     (ics-connecting    . "Connecting to Internet Chess Server '%s'...")
 123     (ics-connected     . "Connecting to Internet Chess Server '%s'...done")
 124     (ics-anon-login    . "Logging in on Internet Chess Server '%s' as anonymous user...")
 125     (ics-logging-in    . "Logging in on Internet Chess Server '%s' as '%s'...")
 126     (ics-logged-in     . "Logging in on Internet Chess Server '%s' as '%s'...done")
 127     (challenge-whom    . "Whom would you like challenge? ")
 128     (failed-ics-parse  . "Failed to parse ICS move string (%s): ")))
 129
 130 (defconst chess-ics-style12-regexp
 131   (rx (and "<12> " (group (repeat 8 (in "-pnbrqkPNBRQK"))) " "
 132            (group (repeat 8 (in "-pnbrqkPNBRQK"))) " "
 133            (group (repeat 8 (in "-pnbrqkPNBRQK"))) " "
 134            (group (repeat 8 (in "-pnbrqkPNBRQK"))) " "
 135            (group (repeat 8 (in "-pnbrqkPNBRQK"))) " "
 136            (group (repeat 8 (in "-pnbrqkPNBRQK"))) " "
 137            (group (repeat 8 (in "-pnbrqkPNBRQK"))) " "
 138            (group (repeat 8 (in "-pnbrqkPNBRQK"))) " "
 139            (group (in "BW")) ? (group (and (? ?-) (in "0-7"))) ?
 140            (group (and (? ?-) digit)) ? (group (and (? ?-) digit)) ?
 141            (group (and (? ?-) digit)) ? (group (and (? ?-) digit)) ?
 142            (group (+ digit)) " "
 143            (group (+ digit)) " "
 144            (group (+ (not (in " ")))) " " (group (+ (not (in " ")))) " "
 145            (group (and (? ?-) digit)) " "
 146            (group (+ digit)) " " (group (+ digit)) " "
 147            (group (+ digit)) " " (group (+ digit)) " "
 148            (group (and (? ?-) (+ digit))) " "
 149            (group (and (? ?-) (+ digit))) " "
 150            (group (+ digit)) " "
 151            (group (+ (not (in " ")))) " "
 152            "(" (group (+ (not (in " )")))) ") "
 153            (group (+ (not (in " ")))) " "
 154            (group (and (? ?-) digit)) " " (group (and (? ?-) digit)) " "
 155            (group (and (? ?-) digit))))
 156   "A regular expression matching a style12 board string.")
 157
 158 (defvar chess-ics-matcher-alist
 159   (list
 160    (cons "\\(ogin\\|name\\):"
 161          (function
 162           (lambda ()
 163             (if (string= "guest" chess-ics-handle)
 164                 (chess-message 'ics-anon-login chess-ics-server)
 165               (chess-message
 166                'ics-logging-in chess-ics-server chess-ics-handle))
 167             (chess-ics-send chess-ics-handle)
 168             'once)))
 169    (cons "[Pp]assword:"
 170          (function
 171           (lambda ()
 172             (when chess-ics-handling-login
 173               (chess-ics-send chess-ics-password))
 174             'once)))
 175    (cons "\\(Logging you in as\\|Your name for this session will be\\) \"\\([^\"]+\\)\""
 176          (function
 177           (lambda ()
 178             (setq chess-ics-handle (match-string 2))
 179             'once)))
 180    (cons "Press return to enter the server as"
 181          (function
 182           (lambda ()
 183             (chess-ics-send "")
 184             'once)))
 185    (cons "%\\s-*$"
 186          (function
 187           (lambda ()
 188             (chess-ics-send
 189              (mapconcat 'identity
 190                         (cdr
 191                          (or
 192                           (assoc chess-ics-server chess-ics-initial-commands)
 193                           (assoc nil chess-ics-initial-commands))) "\n"))
 194             (setq chess-ics-handling-login nil)
 195             (chess-message 'ics-logged-in chess-ics-server chess-ics-handle)
 196             'once)))
 197    (cons "fics%\\s-+startpos set.$"
 198          (function
 199           (lambda ()
 200             (setq chess-ics-movelist-start-position nil)
 201             'once)))
 202    (cons "^\\([A-Za-z0-9]+\\)\\((\\*)\\|(B)\\|(CA?)\\|(H)\\|(T[DM]?)\\|(SR)\\|(FM)\\|(W?[GI]M)\\|(U)\\|([0-9-]+)\\)*\\((\\([0-9]+\\))\\| tells you\\| s-shouts\\|\\[\\([0-9]+\\)\\] kibitzes\\): \\(.+\\)$"
 203          (function
 204           (lambda ()
 205             (let ((fill-prefix (make-string
 206                                 (- (match-end 1) (match-beginning 1)) ? ))
 207                   (game-num (match-string 5))
 208                   (text-begin (match-beginning 6)))
 209               (goto-char (match-beginning 0))
 210               (save-excursion
 211                 (while (and (forward-line 1)
 212                             (looking-at "^\\\\\\s-+"))
 213                   (delete-region (1- (match-beginning 0)) (match-end 0))))
 214               (when game-num
 215                 (chess-game-run-hooks
 216                  (chess-ics-game (string-to-int game-num))
 217                  'kibitz (buffer-substring text-begin (line-end-position))))
 218               (when (> (- (line-end-position) (line-beginning-position))
 219                        fill-column)
 220                 (save-excursion
 221                  (fill-region (point) (line-end-position))))
 222               (save-excursion
 223                 (while (and (forward-line -1)
 224                             (or (looking-at "^[ \t]*$")
 225                                 (looking-at "^[af]ics%\\s-*$")))
 226                   (delete-region (match-beginning 0) (1+ (match-end 0)))))))))
 227    (cons "{Game \\([0-9]+\\) (\\(\\S-+\\) vs\\. \\(\\S-+\\)) Creating [^ ]+ \\([^ ]+\\).*}"
 228          (function
 229           (lambda ()
 230             (let ((game-number (string-to-int (match-string 1)))
 231                   (white (match-string-no-properties 2))
 232                   (black (match-string-no-properties 3)))
 233               (message "Creating game %d (%s vs. %s)" game-number white black)
 234               (chess-ics-game game-number :White white :Black black)))))
 235    (cons "^<10>$" (function (lambda () (chess-ics-send "style 12\nrefresh"))))
 236    (cons "^Game \\([0-9]+\\): \\S-+ backs up \\([0-9]+\\) moves.$"
 237          (function
 238           (lambda ()
 239             (chess-game-undo (chess-ics-game (string-to-int (match-string 1)))
 240                              (string-to-int (match-string 2))))))
 241    (cons chess-ics-style12-regexp #'chess-ics-handle-style12)
 242    (cons "Removing game \\([0-9]+\\) from observation list.$"
 243          (function
 244           (lambda ()
 245             (chess-ics-game-destroy (string-to-int (match-string 1))))))
 246    (cons "You are no longer examining game \\([0-9]+\\).$"
 247          (function
 248           (lambda ()
 249             (chess-ics-game-destroy (string-to-int (match-string 1))))))
 250    (cons "^Movelist for game \\([0-9]+\\):$"
 251          (function
 252           (lambda ()
 253             (if (or chess-ics-movelist-game-number
 254                     chess-ics-movelist-game)
 255                 (message "[movelist] left-over movelist-game[-number]")
 256               (setq chess-ics-movelist-game-number
 257                     (string-to-int (match-string 1)))))))
 258    (cons "^Move\\s-+\\(\\S-+\\)\\s-+\\(\\S-+\\)\\s-*$"
 259          (function
 260           (lambda ()
 261             (if (not chess-ics-movelist-game-number)
 262                 (message "[movelist] no gamenumber but header seen")
 263               (setq chess-ics-movelist-game
 264                     (chess-ics-game chess-ics-movelist-game-number
 265                                     :White (match-string 1)
 266                                     :Black (match-string 2)))
 267               (when chess-ics-movelist-start-position
 268               (chess-game-set-start-position
 269                chess-ics-movelist-game chess-ics-movelist-start-position)))
 270             t)))
 271    ;; Movelist item
 272    (cons (concat "^\\s-*\\([0-9]+\\)\\.\\s-+\\(" chess-algebraic-regexp "\\)"
 273                  "\\s-+\\(([0-9][0-9]?:[0-9][0-9])\\)\\s-*"
 274                  "\\(\\(" chess-algebraic-regexp "\\)\\s-+"
 275                  "\\(([0-9][0-9]?:[0-9][0-9])\\)\\s-*\\)?$")
 276          #'chess-ics-handle-movelist-item)
 277    (cons "\\s-+{Still in progress}\\s-+\\*$"
 278          (function
 279           (lambda ()
 280             (if (integerp chess-ics-movelist-game-number)
 281                 (setq chess-ics-movelist-game-number nil
 282                       chess-ics-movelist-game nil)
 283               (message "[movelist] end of movelist seen where no game known about")))))
 284    (cons "\\S-+ would like to take back \\([0-9]+\\) half move(s)."
 285          (function
 286           (lambda ()
 287             (funcall chess-engine-response-handler 'undo
 288                      (string-to-int (match-string 1))))))
 289    (cons "The game has been aborted on move [^.]+\\."
 290          (function
 291           (lambda ()
 292             (let ((chess-engine-pending-offer 'abort))
 293               (funcall chess-engine-response-handler 'accept)))))
 294    (cons "\\S-+ accepts the takeback request\\."
 295          (function
 296           (lambda ()
 297             (funcall chess-engine-response-handler 'accept))))
 298    (cons ;; resign announcement
 299     "{Game \\([0-9]+\\) (\\(\\S-+\\) vs\\. \\(\\S-+\\)) \\(\\S-+\\) resigns}"
 300     (function
 301      (lambda ()
 302        (let ((chess-engine-handling-event t)
 303              (opponent-p (not (string= chess-ics-handle (match-string 4))))
 304              (game (chess-ics-game (string-to-int (match-string 1))
 305                                    :White (match-string 2)
 306                                    :Black (match-string 3))))
 307          (with-current-buffer (chess-game-data game 'engine)
 308            (if opponent-p
 309                (funcall chess-engine-response-handler 'resign)
 310              (unless (chess-game-status game)
 311                (chess-game-end game :resign))))
 312          t))))
 313    (cons "\\(\\S-+\\) forfeits on time}"
 314          (function
 315           (lambda ()
 316             (if (string= (match-string 1) chess-engine-opponent-name)
 317                 (funcall chess-engine-response-handler 'flag-fell)
 318               (funcall chess-engine-response-handler 'call-flag t)))))
 319    (cons "Illegal move (\\([^)]+\\))\\."
 320          (function
 321           (lambda ()
 322             (funcall chess-engine-response-handler 'illegal
 323                      (match-string 1)))))
 324    (cons "Challenge: \\(\\S-+\\) \\S-+ \\S-+ \\S-+ .+"
 325          (function
 326           (lambda ()
 327             (let ((opponent (match-string 1)))
 328               (if (y-or-n-p (chess-string 'want-to-play opponent))
 329                   (chess-ics-send (concat "accept " opponent))
 330                 (chess-ics-send "decline match")))))))
 331   "An alist of regular expressions to use to scan ICS server output.
 332 The car of each element is the regexp to try, and the cdr is a function
 333 to run whenever the regexp matches.")
 334
 335 (defvar chess-ics-sessions nil
 336   "A list of chess-sessions spawned from an Internet Chess Server connection.
 337 See `chess-ics-game'.")
 338 (make-variable-buffer-local 'chess-ics-sessions)
 339
 340 (defun chess-ics-game (game-number &rest tags)
 341   "Either create, or retrieve an existing game object with GAME-NUMBER."
 342   (assert (integerp game-number))
 343   (assert (or (evenp (length tags)) (eq (car tags) t)))
 344   (or
 345    ;; First try to find a game which matches the constraints in TAGS
 346    (catch 'ics-game
 347      (let ((sessions chess-ics-sessions))
 348        (while sessions
 349          (if (not (buffer-live-p (caar sessions)))
 350              (message "Found dead engine session in `chess-ics-sessions'")
 351            (let ((game (chess-engine-game (caar sessions)))
 352                  (tag-pairs tags))
 353              (when (= game-number (chess-game-data game 'ics-game-number))
 354                (if (or (null tags) (eq (car tags) t))
 355                    (throw 'ics-game game)
 356                  (while tag-pairs
 357                    (assert (symbolp (car tag-pairs)))
 358                    (let ((tag (substring (symbol-name (car tag-pairs)) 1))
 359                          (val (cadr tag-pairs)))
 360                      (assert (stringp val))
 361                      (if (string= (chess-game-tag game tag) val)
 362                          (setq tag-pairs (cddr tag-pairs))
 363                        (if (not (string= (chess-game-tag game tag) "?"))
 364                            (message "Game %d %s %s != %s"
 365                                   game-number tag (chess-game-tag game tag) val))
 366                        ;; Update tag and proceed
 367                        (chess-game-set-tag game tag val)
 368                        (setq tags (cddr tags)))))
 369                  (throw 'ics-game game)))))
 370          (setq sessions (cdr sessions)))))
 371    ;; if we are allowed to, create a new session for this game number
 372    (unless (eq (car tags) t)
 373      (push (let (chess-engine-handling-event)
 374              (chess-session 'chess-ics))
 375            chess-ics-sessions)
 376      (assert (caar chess-ics-sessions))
 377      (let ((game (chess-engine-game (caar chess-ics-sessions))))
 378        (chess-game-set-data game 'ics-game-number game-number)
 379        (chess-game-set-data game 'ics-buffer (current-buffer))
 380        (chess-game-set-tag game "Site" chess-ics-server)
 381        (while tags
 382          (assert (keywordp (car tags)))
 383          (chess-game-set-tag
 384           game (substring (symbol-name (car tags)) 1) (cadr tags))
 385          (setq tags (cddr tags)))
 386        game))))
 387
 388 (defvar last-triggers nil)
 389
 390 (defun chess-ics-game-destroy (game-number &rest tags)
 391   (let ((sessions chess-ics-sessions)
 392         last-session)
 393     (while sessions
 394       (if (not (buffer-live-p (caar sessions)))
 395           (message "Found dead engine session in `chess-ics-sessions'")
 396         (let ((game (chess-display-game (cadar sessions)))
 397               (tag-pairs tags)
 398               (found t))
 399           (when (= game-number (chess-game-data game 'ics-game-number))
 400             (if (null tags)
 401                 (progn
 402                   (chess-display-destroy (cadar sessions))
 403                   (if last-session
 404                       (setcdr last-session (cdr sessions))
 405                     (setq chess-ics-sessions (cdr sessions))))
 406               (while (and tag-pairs found)
 407                 (assert (symbolp (car tag-pairs)))
 408                 (let ((tag (substring (symbol-name (car tag-pairs)) 1))
 409                       (val (cadr tag-pairs)))
 410                   (assert (stringp val))
 411                   (if (string= (chess-game-tag game tag) val)
 412                       (setq tag-pairs (cddr tag-pairs))
 413                     (setq found nil))))
 414               (chess-engine-destroy (cadar sessions))
 415               (if last-session
 416                   (setcdr last-session (cdr sessions))
 417                 (setq chess-ics-sessions (cdr sessions)))))))
 418       (setq last-triggers sessions
 419             sessions (cdr sessions)))))
 420
 421 (defun chess-ics-handle-movelist-item ()
 422   ;; TBD: time taken per ply
 423   (let ((chess-engine-handling-event t)
 424         (seq (string-to-int (match-string 1)))
 425         (wmove (match-string 2))
 426         (bmove (match-string 14))
 427         (game chess-ics-movelist-game))
 428     (when (and game
 429                (chess-pos-side-to-move (chess-game-pos game))
 430                (= (chess-game-seq game) seq))
 431       (chess-game-set-data game 'my-color nil)
 432       (chess-game-move
 433        game (chess-algebraic-to-ply (chess-game-pos game) wmove))
 434       (when bmove
 435         (chess-game-set-data game 'my-color t)
 436         (chess-game-move
 437          game (chess-algebraic-to-ply (chess-game-pos game) bmove))))
 438     t))
 439
 440 ;; ICS style12 format (with artificial line breaks):
 441 ;;
 442 ;; <12> rnbqkbnr pppppppp -------- -------- \
 443 ;;      -------- -------- PPPPPPPP RNBQKBNR W -1 1 1 1 1 0 \
 444 ;;      65 jwiegley GuestZYNJ 1 5 0 39 39 300 300 1 P/e2-e4 (0:00) e4 0 0 0
 445
 446 (defun chess-ics-handle-style12 ()
 447   "Handle an ICS Style12 board string."
 448   (let* ((chess-engine-handling-event t)
 449          (begin (match-beginning 0))
 450          (end (match-end 0))
 451          (position (let ((pos (chess-pos-create t)))
 452                      (dotimes (r 8)
 453                        (let ((rank (match-string (1+ r))))
 454                          (dotimes (f 8)
 455                            (unless (= (aref rank f) ?-)
 456                              (chess-pos-set-piece
 457                               pos (chess-rf-to-index r f) (aref rank f))))))
 458                      (chess-pos-set-side-to-move pos (string= (match-string 9) "W"))
 459                      (let ((file (string-to-int (match-string 10))))
 460                        (when (>= file 0)
 461                          (chess-pos-set-en-passant
 462                           pos (chess-rf-to-index
 463                                (if (chess-pos-side-to-move pos) 3 4) file))))
 464                      (mapc (lambda (info)
 465                              (if (string= (match-string (cdr info)) "1")
 466                                  (chess-pos-set-can-castle pos (car info) t)))
 467                            '((?K . 11) (?Q . 12) (?k . 13) (?q . 14))) pos))
 468          (game (save-match-data
 469                  (chess-ics-game (string-to-int (match-string 16))
 470                                  :White (match-string 17)
 471                                  :Black (match-string 18))))
 472          (status
 473           ;; my relation to this game:
 474           ;; -3 isolated position, such as for "ref 3" or the "sposition"
 475           ;;    command
 476           ;; -2 I am observing game being examined
 477           ;;  2 I am the examiner of this game
 478           ;; -1 I am playing, it is my opponent's move
 479           ;;  1 I am playing and it is my move
 480           ;;  0 I am observing a game being played
 481           (string-to-int (match-string 19))))
 482     (when (or (= status 2) (= status -2) (= status 0))
 483       (chess-game-set-data game 'my-color (chess-pos-side-to-move position)))
 484     ;; initial time and increment (in seconds) of the match
 485     (chess-game-set-tag
 486      game "TimeControl" (format "%s/%s" (match-string 20) (match-string 21)))
 487     ;; material values for each side
 488     (let ((centipawn (* 100 (- (string-to-int (match-string 22))
 489                                (string-to-int (match-string 23))))))
 490       (chess-pos-set-epd position 'ce (if (chess-pos-side-to-move position)
 491                                           centipawn (- centipawn))))
 492     ;; White's and Black's remaining time
 493     (chess-game-set-data game 'white-remaining (string-to-int (match-string 24)))
 494     (chess-game-set-data game 'black-remaining (string-to-int (match-string 25)))
 495     (let ((index (- (* (string-to-int (match-string 26)) 2)
 496                     (if (eq (chess-game-data game 'black-moved-first) t)
 497                         (if (chess-pos-side-to-move position) 3 2)
 498                       (if (chess-pos-side-to-move position) 2 1))))
 499           (move (unless (string= (match-string 29) "none")
 500                   (case (aref (match-string 29) (1- (length (match-string 29))))
 501                     (?+ (chess-pos-set-status position :check))
 502                     (?# (chess-pos-set-status position :checkmate)
 503                         (chess-pos-set-epd position 'ce 32767)))
 504                   ;; jww (2002-04-30): what about stalemate?  do I need to
 505                   ;; calculate this each time?
 506                   (when nil
 507                     (chess-pos-set-status position :stalemate))
 508                   (match-string 29))))
 509       (unwind-protect
 510           (if move
 511               (if (progn (setq error 'comparing-index)
 512                          (= (1- index) (chess-game-index game)))
 513                   (let ((ply (progn (setq error 'converting-ply)
 514                                     (chess-algebraic-to-ply
 515                                      (chess-game-pos game) move t))))
 516                     ;; each move gives the _position occurring after the ply_
 517                     (if (progn (setq error 'comparing-colors)
 518                                (eq (chess-pos-side-to-move position)
 519                                    (chess-game-data game 'my-color)))
 520                         (setq error 'applying-opponent-move)
 521                       (setq error 'applying-my-move))
 522                     ;; save us from generating a position we already have
 523                     (chess-ply-set-keyword ply :next-pos position)
 524                     (chess-pos-set-preceding-ply position ply)
 525                     ;; apply the move
 526                     (chess-game-move game ply)
 527                     (setq error nil))
 528                 (if (= index (chess-game-index game))
 529                     (setq error 'refresh) ; Ignore a "refresh" command
 530                   (if (and (> index (1+ (chess-game-index game)))
 531                              (= 1 (chess-game-seq game)))
 532                     ;; we lack a complete game, try to get it via the movelist
 533                     (progn
 534                       (setq error nil)
 535                       (chess-ics-send
 536                        (format "moves %d"
 537                                (chess-game-data game 'ics-game-number))))
 538                     (setq error
 539                           (format "comparing-index (%d:%d)" index (chess-game-index game))))))
 540             ;; no preceeding ply supplied, so this is a starting position
 541             (let ((chess-game-inhibit-events t)
 542                   (color (chess-pos-side-to-move position))
 543                   plies)
 544               (when (or (= 1 status) (= -1 status))
 545                 (chess-game-set-data game 'my-color (if (= 1 status)
 546                                                         color (not color)))
 547                 (chess-game-set-data game 'active t))
 548               (setq error 'setting-start-position)
 549               (chess-game-set-start-position game position)
 550               (chess-game-set-data game 'black-moved-first (not color)))
 551             (setq error 'orienting-board)
 552             (chess-game-run-hooks game 'orient)
 553             (setq error nil))
 554         (goto-char begin)
 555         (if error
 556             (insert (chess-string 'failed-ics-parse error))
 557           (delete-region begin end)
 558           (save-excursion
 559             (while (and (forward-line -1)
 560                         (or (looking-at "^[ \t]*$")
 561                             (looking-at "^[^% \t\n\r]+%\\s-*$")))
 562               (delete-region (match-beginning 0) (1+ (match-end 0)))))
 563           ;; we need to counter the forward-line in chess-engine-filter
 564           (forward-line -1)))
 565       t)))
 566
 567 (defface chess-ics-seek-button '((((type pc) (class color))
 568                                   (:foreground "lightblue"))
 569                                  (t :underline t))
 570   "Default face used for seek buttons."
 571   :group 'chess-ics)
 572
 573 (defvar chess-ics-seek-button-map
 574   (let ((map (make-sparse-keymap)))
 575     (define-key map "\r" 'chess-ics-push-seek-button)
 576     (define-key map [mouse-2] 'chess-ics-push-seek-button)
 577     map)
 578   "Keymap used by seek buttons.")
 579
 580 (defvar chess-ics-sought-parent-buffer nil
 581   "Contains the buffer from which this seektable originates.")
 582 (make-variable-buffer-local 'chess-ics-sought-parent-buffer)
 583
 584 (defun chess-ics-sought-accept (&optional pos)
 585   "Perform the action specified by a button at location POS.
 586 POS may be either a buffer position or a mouse-event.
 587 POS defaults to point, except when `push-button' is invoked
 588 interactively as the result of a mouse-event, in which case, the
 589 mouse event is used.
 590 If there's no button at POS, do nothing and return nil, otherwise
 591 return t."
 592   (interactive
 593    (list (if (integerp last-command-event) (point) last-command-event)))
 594   (if (and (not (integerp pos)) (eventp pos))
 595       ;; POS is a mouse event; switch to the proper window/buffer
 596       (let ((posn (event-start pos)))
 597         (with-current-buffer (window-buffer (posn-window posn))
 598           (push-button (posn-point posn) t)))
 599     ;; POS is just normal position
 600     (let ((command (get-char-property pos 'ics-command)))
 601       (when (stringp command)
 602         (chess-ics-send command chess-ics-sought-parent-buffer)
 603         t))))
 604
 605 (defvar chess-ics-popup-sought t
 606   "*If non-nil, display the sought buffer automatically.")
 607
 608 (defcustom chess-ics-sought-buffer-name "*chess-ics-sought*"
 609   "*The name of the buffer which accumulates seek ads."
 610   :group 'chess-ics
 611   :type 'string)
 612
 613 (defvar chess-ics-sought-sort-state nil
 614   "Determines the order for seek ads in the sought buffer.
 615 If nil, do not sort entries, i.e., keep the order of arrival.")
 616 (make-variable-buffer-local 'chess-ics-sought-sort-state)
 617
 618 (defvar chess-ics-sought-sort-direction nil
 619   "Determines the direction of sorting for seek ads in the sought buffer.
 620 If nil, ads are sorted in ascending order, if non-nil, they are sorted in
 621 descending order.")
 622 (make-variable-buffer-local 'chess-ics-sought-sort-direction)
 623
 624 (defun chess-ics-sought-sort ()
 625   (case chess-ics-sought-sort-state
 626    (id     (sort-numeric-fields 1 (point-min) (point-max)))
 627    (player (sort-fields 2 (point-min) (point-max)))
 628    (rating (sort-numeric-fields 3 (point-min) (point-max)))
 629    (time   (sort-numeric-fields 5 (point-min) (point-max)))
 630    (inc    (sort-numeric-fields 6 (point-min) (point-max))))
 631   (and chess-ics-sought-sort-state
 632        chess-ics-sought-sort-direction
 633        (reverse-region (point-min) (point-max))))
 634
 635 (defun chess-ics-sought-toggle-sort-state ()
 636   (interactive)
 637   (setq chess-ics-sought-sort-state
 638         (case chess-ics-sought-sort-state
 639           ((id) 'player)
 640           ((player) 'rating)
 641           ((rating) 'time)
 642           ((time) 'inc)
 643           ((inc) nil)
 644           ((nil) 'id)))
 645   (message "Sorting ads by %s..."
 646            (case chess-ics-sought-sort-state
 647              ((id) "ID")
 648              ((player) "player name")
 649              ((rating) "rating (ascending)")
 650              ((reverse-rating) "rating (descending)")
 651              ((time) "initial time")
 652              ((inc) "time increment")
 653              ((nil) "arrival")))
 654   (chess-ics-sought-sort))
 655
 656 (defun chess-ics-sought-toggle-sort-direction ()
 657   (interactive)
 658   (message "Sorting %sscending direction..."
 659            (if (setq chess-ics-sought-sort-direction
 660                      (not chess-ics-sought-sort-direction))
 661                "de" "a"))
 662   (chess-ics-sought-sort))
 663
 664 (defcustom chess-ics-sought-mode-line-format
 665   '("-" mode-line-mule-info mode-line-modified mode-line-frame-identification
 666    "   "
 667    global-mode-string
 668    "   %[("
 669    (:eval (mode-line-mode-name))
 670    minor-mode-alist
 671    "%n"
 672    ")%]--"
 673    (:eval (format "[%d ads displayed]" (count-lines (point-min) (point-max))))
 674    "-%-")
 675   "Mode line data for ICS sought mode."
 676   :group 'chess-ics
 677   :type 'sexp)
 678
 679 (defvar chess-ics-sought-mode-map
 680   (let ((map (make-sparse-keymap)))
 681     (define-key map "\r" 'chess-ics-sought-accept)
 682     (define-key map [mouse-2] 'chess-ics-sought-accept)
 683     (define-key map [??] 'describe-mode)
 684     (define-key map [?s] 'chess-ics-sought-toggle-sort-state)
 685     (define-key map [? ] 'chess-ics-sought-toggle-sort-direction)
 686     map)
 687   "Keymap for `chess-ics-sought-mode'.")
 688
 689 (define-derived-mode chess-ics-sought-mode fundamental-mode "Seek Ads"
 690   "A mode for displaying ICS game seek advertisments."
 691   (let ((map (current-local-map)))
 692     (define-key map "\r" 'chess-ics-sought-accept)
 693     (define-key map [mouse-2] 'chess-ics-sought-accept)
 694     (define-key map [??] 'describe-mode)
 695     (define-key map [?s] 'chess-ics-sought-toggle-sort-state)
 696     (define-key map [? ] 'chess-ics-sought-toggle-sort-direction))
 697   (setq sort-fold-case t
 698         mode-line-format chess-ics-sought-mode-line-format
 699         header-line-format
 700         '((3 . "ID") " "
 701           (20 "Player") " "
 702           (4 . "Elo") " "
 703           "Rated" " "
 704           (7 . "  Time") " "
 705           "Variant%-")))
 706
 707 (defun chess-ics-seeking (string)
 708   (if (not (string-match
 709             "\\`[\n\r]+\\(\\S-+\\) (\\([0-9+ -]+\\)) seeking \\([a-z]\\S-+ \\)?\\([0-9]+\\) \\([0-9]+\\) \\(\\(un\\)?rated\\) \\([^(]*\\)(\"\\([^\"]+\\)\" to respond)\\s-*[\n\r]+\\([0-2][0-9]:[0-6][0-9]_\\)?[af]ics% \\'"
 710             string))
 711       string
 712     (let* ((name (match-string 1 string))
 713            (rating (string-to-int (match-string 2 string)))
 714            (time (string-to-int (match-string 4 string)))
 715            (inc (string-to-int (match-string 5 string)))
 716            (rated (if (string= (match-string 6 string) "rated") "yes" "no"))
 717            (variant (concat (if (match-string 3 string)
 718                                 (concat (match-string 3 string) " ") "")
 719                             (match-string 8 string)))
 720            (cmd (match-string 9 string))
 721            (id (substring cmd 5))
 722            (ics-buffer (current-buffer)))
 723       (setq id (concat id (make-string (- 3 (length id)) ? )))
 724       (setq name (concat name (make-string (- 20 (length name)) ? )))
 725       (setq variant (concat variant (make-string (- 25 (length variant)) ? )))
 726       (with-current-buffer
 727           (or (get-buffer chess-ics-sought-buffer-name)
 728               (with-current-buffer (get-buffer-create
 729                                     chess-ics-sought-buffer-name)
 730                 (chess-ics-sought-mode)
 731                 (setq chess-ics-sought-parent-buffer ics-buffer)
 732                 (and chess-ics-popup-sought (display-buffer (current-buffer)))
 733                 (current-buffer)))
 734         (let ((here (point)))
 735           (when (re-search-forward (concat "^" (regexp-quote id) " ") nil t)
 736             (goto-char (line-beginning-position))
 737             (delete-region (point) (1+ (line-end-position))))
 738           (goto-char (point-min))
 739           (let ((beg (point)))
 740             (insert (format "%s %s %4d %4s  %3d/%3d %s"
 741                             id name rating rated time inc variant))
 742             (add-text-properties
 743              beg (point)
 744              (list 'rear-nonsticky t
 745                    'mouse-face 'highlight
 746                    'ics-command cmd))
 747             (insert "\n"))
 748           (chess-ics-sought-sort)
 749           (goto-char here)))
 750       "")))
 751
 752 (defun chess-ics-ads-removed (string)
 753   "Look for Seek ad removal announcements in the output stream.
 754 This function should be put on `comint-preoutput-filter-functions'."
 755   (let (ids)
 756     (while (string-match "[\n\r]+Ads removed: \\([0-9 ]+\\)\\s-*[\n\r]+\\([0-2][0-9]:[0-6][0-9]_\\)?[af]ics% $"
 757                          string)
 758       (setq ids (append (save-match-data
 759                           (split-string (match-string 1 string) " +")) ids))
 760       (setq string (concat (substring string 0 (match-beginning 0))
 761                            (substring string (match-end 0)))))
 762     (when ids
 763       (let ((buf (get-buffer chess-ics-sought-buffer-name)))
 764         (when (buffer-live-p buf)
 765           (with-current-buffer buf
 766             (let ((here (point)))
 767               (while ids
 768                 (goto-char (point-min))
 769                 (when (re-search-forward (concat "^" (car ids) " ") nil t)
 770                   (delete-region (line-beginning-position)
 771                                  (1+ (line-end-position))))
 772                 (setq ids (cdr ids)))
 773               (goto-char here)))))))
 774   string)
 775
 776 ;;;###autoload
 777 (defun chess-ics (server port &optional handle password-or-filename
 778                          helper &rest helper-args)
 779   "Connect to an Internet Chess Server."
 780   (interactive
 781    (let ((args (if (= (length chess-ics-server-list) 1)
 782                    (car chess-ics-server-list)
 783                  (assoc (completing-read (chess-string 'ics-server-prompt)
 784                                          chess-ics-server-list
 785                                          nil t (caar chess-ics-server-list))
 786                         chess-ics-server-list))))
 787      (if (and (nth 2 args) (not (nth 3 args)))
 788          (append (list (nth 0 args) (nth 1 args) (nth 2 args)
 789                        (read-passwd "Password: ")
 790                        (nth 4 args))
 791                  (nthcdr 5 args))
 792        args)))
 793   (unless handle
 794     (setq handle "guest"))
 795   (chess-message 'ics-connecting server)
 796   (let ((buf (if helper
 797                  (apply 'make-comint "chess-ics" helper nil helper-args)
 798                (make-comint "chess-ics" (cons server port)))))
 799     (chess-message 'ics-connected server)
 800     (set-buffer buf)
 801     (setq chess-ics-server server
 802           chess-ics-handle handle
 803           chess-ics-password
 804           (if (and password-or-filename
 805                    (file-readable-p password-or-filename))
 806               (with-temp-buffer
 807                 (insert-file-contents password-or-filename)
 808                 (buffer-string))
 809             password-or-filename)
 810           chess-ics-handling-login t
 811           chess-engine-regexp-alist (copy-alist chess-ics-matcher-alist)
 812           comint-prompt-regexp "^[^%\n]*% *"
 813           comint-scroll-show-maximum-output t)
 814     (add-hook 'comint-output-filter-functions 'chess-engine-filter t t)
 815     (make-variable-buffer-local 'comint-preoutput-filter-functions)
 816     (setq comint-preoutput-filter-functions
 817           '(chess-ics-ads-removed chess-ics-seeking))
 818     (let ((ntimes 50))
 819       (while (and chess-ics-handling-login
 820                   (> (setq ntimes (1- ntimes)) 0))
 821         (accept-process-output (get-buffer-process (current-buffer)) 0 100)))
 822     (switch-to-buffer buf)))
 823
 824 (defun chess-ics-handler (game event &rest args)
 825   (unless chess-engine-handling-event
 826     (cond
 827      ((eq event 'initialize))
 828
 829      ((eq event 'ready)
 830       (chess-game-run-hooks game 'announce-autosave))
 831
 832      ((eq event 'busy))                 ; ICS will inform them
 833
 834      ((eq event 'match)
 835       (setq chess-engine-pending-offer 'match)
 836       (chess-engine-send
 837        nil (format "match %s\n"
 838                    (read-string (chess-string 'challenge-whom)))))
 839
 840      ;; this handler is taken from chess-common; we need to send long
 841      ;; algebraic notation to the ICS server, not short
 842      ((eq event 'move)
 843       (chess-ics-send
 844        (if (chess-ply-any-keyword (car args) :castle :long-castle)
 845            (chess-ply-to-algebraic (car args))
 846          (concat (chess-index-to-coord
 847                   (chess-ply-source (car args))) "-"
 848                   (chess-index-to-coord
 849                    (chess-ply-target (car args)))))
 850        (chess-game-data game 'ics-buffer))
 851       (if (chess-game-over-p game)
 852           (chess-game-set-data game 'active nil)))
 853
 854      ((eq event 'flag-fell)
 855       (chess-common-handler game 'flag-fell))
 856
 857      ((eq event 'forward)
 858       (chess-ics-send "forward" (chess-game-data game 'ics-buffer)))
 859      (t
 860       (apply 'chess-network-handler game event args)))))
 861
 862 (provide 'chess-ics)
 863
 864 ;;; chess-ics.el ends here