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

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;;
   3 ;; An engine for interacting with Internet Chess Servers
   4 ;;
   5 ;; jww (2002-04-23): This module has only been tested on FICS.
   6 ;;
   7
   8 (require 'comint)
   9 (require 'chess-network)
  10
  11 (defgroup chess-ics nil
  12   "Engine for interacting with Internet Chess Servers."
  13   :group 'chess-engine)
  14
  15 (defcustom chess-ics-server-list
  16   '(("freechess.org" 5000))
  17   "A list of servers to connect to.
  18 The format of each entry is:
  19
  20   (SERVER PORT [HANDLE] [PASSWORD-OR-FILENAME] [HELPER] [HELPER ARGS...])"
  21   :type '(repeat (list (string :tag "Server")
  22                        (integer :tag "Port")
  23                        (choice (const :tag "Login as guest" nil)
  24                                (string :tag "Handle"))
  25                        (choice (const :tag "No password or ask" nil)
  26                                (string :tag "Password")
  27                                (file :tag "Filename"))
  28                        (choice (const :tag "Direct connection" nil)
  29                                (file :tag "Command"))
  30                        (choice (const :tag "No arguments" nil)
  31                                (repeat string))))
  32   :group 'chess-ics)
  33
  34 (defvar chess-ics-server)
  35 (defvar chess-ics-handle)
  36 (defvar chess-ics-password)
  37 (defvar chess-ics-prompt)
  38
  39 (make-variable-buffer-local 'chess-ics-server)
  40 (make-variable-buffer-local 'chess-ics-handle)
  41 (make-variable-buffer-local 'chess-ics-password)
  42 (make-variable-buffer-local 'chess-ics-prompt)
  43
  44 (defvar chess-ics-regexp-alist
  45   (list (cons "\\(ogin\\|name\\):"
  46               (function
  47                (lambda ()
  48                  (chess-engine-send nil (concat chess-ics-handle "\n"))
  49                  'once)))
  50         (cons "[Pp]assword:"
  51               (function
  52                (lambda ()
  53                  (chess-engine-send nil (concat chess-ics-password "\n"))
  54                  'once)))
  55         (cons "%"
  56               (function
  57                (lambda ()
  58                  (chess-engine-send nil "set style 12\n")
  59                  (chess-engine-send nil "set bell 0\n")
  60                  'once)))
  61         (cons "Logging you in as \"\\([^\"]+\\)\""
  62               (function
  63                (lambda ()
  64                  (setq chess-ics-handle (match-string 1))
  65                  'once)))
  66         (cons "Press return to enter the server as"
  67               (function
  68                (lambda ()
  69                  (chess-engine-send nil "\n")
  70                  'once)))
  71         (cons "The game has been aborted on move [^.]+\\."
  72               (function
  73                (lambda ()
  74                  (let ((chess-engine-pending-offer 'abort))
  75                    (funcall chess-engine-response-handler 'accept)))))
  76         (cons "<12>\\s-+\\(.+\\)" 'chess-ics-handle-move)
  77         (cons "\\S-+ would like to take back \\([0-9]+\\) half move(s)."
  78               (function
  79                (lambda ()
  80                  (funcall chess-engine-response-handler 'undo
  81                           (string-to-int (match-string 1))))))
  82         (cons "\\S-+ accepts the takeback request\\."
  83               (function
  84                (lambda ()
  85                  (funcall chess-engine-response-handler 'accept))))
  86         (cons "\\(\\S-+\\) resigns}"
  87               (function
  88                (lambda ()
  89                  (if (string= (match-string 1) chess-engine-opponent-name)
  90                      (funcall chess-engine-response-handler 'resign)))))
  91         (cons "\\(\\S-+\\) forfeits on time}"
  92               (function
  93                (lambda ()
  94                  (if (string= (match-string 1) chess-engine-opponent-name)
  95                      (funcall chess-engine-response-handler 'flag-fell)
  96                    (funcall chess-engine-response-handler 'call-flag t)))))
  97         (cons "Illegal move (\\([^)]+\\))\\."
  98               (function
  99                (lambda ()
 100                  (funcall chess-engine-response-handler 'illegal
 101                           (match-string 1)))))
 102         (cons "Challenge: \\(\\S-+\\) \\S-+ \\S-+ \\S-+ .+"
 103               (function
 104                (lambda ()
 105                  (funcall chess-engine-response-handler 'match
 106                           (match-string 1)))))))
 107
 108 ;; ICS12 format (with artificial line breaks):
 109 ;;
 110 ;; <12> rnbqkbnr pppppppp -------- -------- \
 111 ;;      -------- -------- PPPPPPPP RNBQKBNR W \
 112 ;;      -1 1 1 1 1 0 65 jwiegley GuestZYNJ \
 113 ;;      1 5 0 39 39 300 300 1 P/e2-e4 (0:00) e4 0 0 0
 114
 115 (defun chess-ics12-parse (string)
 116   "Parse an ICS12 format string, and return a list of its info.
 117 The list is comprised of: the ply the string represents, who is white,
 118 who is black."
 119   (let ((parts (split-string string " "))
 120         (position (chess-pos-create t))
 121         white black white-time black-time move status)
 122
 123     (assert (= (length parts) 32))
 124
 125     ;; first, handle the layout of the position
 126     (dotimes (i 8)
 127       (dotimes (j 8)
 128         (let ((piece (aref (car parts) j)))
 129           (unless (= piece ?-)
 130             (chess-pos-set-piece position (chess-rf-to-index i j)
 131                                  piece))))
 132       (setq parts (cdr parts)))
 133
 134     ;; next, the "side to move"
 135     (chess-pos-set-side-to-move position (string= (car parts) "W"))
 136     (setq parts (cdr parts))
 137
 138     ;; -1 if the previous move was NOT a double pawn push, otherwise
 139     ;; the chess board file (numbered 0--7 for a--h) in which the
 140     ;; double push was made
 141     (let ((index (string-to-number (car parts))))
 142       (when (>= index 0)
 143         (chess-pos-set-en-passant
 144          position (chess-rf-to-index
 145                    (if (chess-pos-side-to-move position) 3 4) index))))
 146     (setq parts (cdr parts))
 147
 148     ;; can White still castle short? (0=no, 1=yes)
 149     (if (string= (car parts) "1")
 150         (chess-pos-set-can-castle position ?K t))
 151     (setq parts (cdr parts))
 152     ;; can White still castle long?
 153     (if (string= (car parts) "1")
 154         (chess-pos-set-can-castle position ?Q t))
 155     (setq parts (cdr parts))
 156     ;; can Black still castle short?
 157     (if (string= (car parts) "1")
 158         (chess-pos-set-can-castle position ?k t))
 159     (setq parts (cdr parts))
 160     ;; can Black still castle long?
 161     (if (string= (car parts) "1")
 162         (chess-pos-set-can-castle position ?q t))
 163     (setq parts (cdr parts))
 164
 165     ;; the number of moves made since the last irreversible move.  (0
 166     ;; if last move was irreversible.  If the value is >= 100, the
 167     ;; game can be declared a draw due to the 50 move rule.)
 168     (setq parts (cdr parts))
 169
 170     ;; The game number
 171     (setq parts (cdr parts))
 172
 173     ;; white player, black player
 174     (setq white (car parts) parts (cdr parts))
 175     (setq black (car parts) parts (cdr parts))
 176
 177     ;; my relation to this game:
 178     ;; -3 isolated position, such as for "ref 3" or the "sposition"
 179     ;;    command
 180     ;; -2 I am observing game being examined
 181     ;;  2 I am the examiner of this game
 182     ;; -1 I am playing, it is my opponent's move
 183     ;;  1 I am playing and it is my move
 184     ;;  0 I am observing a game being played
 185     (setq status (string-to-int (car parts))
 186           parts (cdr parts))
 187
 188     ;;  initial time (in seconds) of the match
 189     (setq parts (cdr parts))
 190
 191     ;;  increment In seconds) of the match
 192     (setq parts (cdr parts))
 193
 194     ;; material values for each side
 195     (setq parts (cdr parts))
 196     (setq parts (cdr parts))
 197
 198     ;;  White's and Black's remaining time
 199     (setq white-time (string-to-number (car parts)))
 200     (setq parts (cdr parts))
 201     (setq black-time (string-to-number (car parts)))
 202     (setq parts (cdr parts))
 203
 204     ;; the number of the move about to be made (standard chess
 205     ;; numbering -- White's and Black's first moves are both 1, etc.)
 206     (setq parts (cdr parts))
 207
 208     ;; move in long alegebraic notation
 209     (setq parts (cdr parts))
 210
 211     ;; time taken to make previous move "(min:sec)".
 212     (setq parts (cdr parts))
 213
 214     ;; move in short algebraic notation (SAN)
 215     (setq move (unless (string= (car parts) "none")
 216                  (car parts)))
 217     (setq parts (cdr parts))
 218
 219     ;; checkmate, etc., is stated in the SAN text
 220     (when (> (length move) 0)
 221       (cond
 222        ((= ?+ (aref move (1- (length move))))
 223         (chess-pos-set-status position :check))
 224        ((= ?# (aref move (1- (length move))))
 225         (chess-pos-set-status position :checkmate))
 226        (nil
 227         ;; jww (2002-04-30): what about stalemate?  do I need to
 228         ;; calculate this each time?
 229         (chess-pos-set-status position :stalemate))))
 230
 231     ;; flip field for board orientation: 1 = Black at bottom, 0 =
 232     ;; White at bottom.
 233     (setq parts (cdr parts))
 234
 235     ;; jww (2002-04-18): what do these two mean?
 236     (setq parts (cdr parts))
 237     (setq parts (cdr parts))
 238
 239     (list position move white black white-time black-time status)))
 240
 241 (chess-message-catalog 'english
 242   '((ics-server-prompt . "Connect to chess server: ")
 243     (ics-connecting    . "Connecting to Internet Chess Server '%s'...")
 244     (ics-connected     . "Connecting to Internet Chess Server '%s'...done")
 245     (challenge-whom    . "Whom would you like challenge? ")
 246     (failed-ics-parse  . "Failed to parse ICS move string (%s): %s")))
 247
 248 (defun chess-ics-handle-move ()
 249   (let ((chess-engine-handling-event t)
 250         (begin (match-beginning 0))
 251         (end (match-end 0))
 252         (info (chess-ics12-parse (match-string 1)))
 253         (game (chess-engine-game nil))
 254         error)
 255     (unwind-protect
 256         (if (nth 1 info)
 257             ;; each move gives the _position occurring after the ply_,
 258             ;; which means that if the move says W, it is telling us
 259             ;; what our opponents move was
 260             (if (and (setq error 'comparing-colors)
 261                      (eq (chess-pos-side-to-move (nth 0 info))
 262                          (chess-game-data game 'my-color)))
 263                 (let ((ign (setq error 'converting-ply))
 264                       (ply (chess-engine-convert-algebraic (nth 1 info) t)))
 265                   (chess-game-set-data game 'white-remaining (nth 4 info))
 266                   (chess-game-set-data game 'black-remaining (nth 5 info))
 267                   (setq error 'applying-move)
 268                   ;; save us from generating a position we already have
 269                   (chess-ply-set-keyword ply :next-pos (nth 0 info))
 270                   (chess-pos-set-preceding-ply (nth 0 info) ply)
 271                   (chess-game-move game ply)
 272                   (setq error nil))
 273               (setq error nil))
 274           (let ((chess-game-inhibit-events t)
 275                 (color (chess-pos-side-to-move (nth 0 info)))
 276                 plies)
 277             (when (or (= 1 (nth 6 info)) (= -1 (nth 6 info)))
 278               (chess-game-set-data game 'my-color (if (= 1 (nth 6 info))
 279                                                       color
 280                                                     (not color)))
 281               (setq chess-engine-opponent-name
 282                     (if (= 1 (nth 6 info))
 283                         (nth 3 info)
 284                       (nth 2 info)))
 285               (chess-game-set-data game 'active t)
 286               (chess-game-set-data game 'white-remaining (nth 4 info))
 287               (chess-game-set-data game 'black-remaining (nth 5 info)))
 288             (chess-game-set-tag game "White" (nth 2 info))
 289             (chess-game-set-tag game "Black" (nth 3 info))
 290             (chess-game-set-tag game "Site" (car chess-ics-server))
 291             (setq error 'setting-start-position)
 292             (chess-game-set-start-position game (nth 0 info)))
 293           (setq error 'orienting-board)
 294           (chess-game-run-hooks game 'orient)
 295           (setq error nil))
 296       (if error
 297           (chess-message 'failed-ics-parse error
 298                          (buffer-substring-no-properties begin end)))
 299       (goto-char begin)
 300       (delete-region begin end)
 301       (save-excursion
 302         (while (and (forward-line -1)
 303                     (or (looking-at "^[ \t]*$")
 304                         (looking-at "^[^% \t\n\r]+%\\s-*$")))
 305           (delete-region (match-beginning 0) (1+ (match-end 0)))))
 306       ;; we need to counter the forward-line in chess-engine-filter
 307       (unless error
 308         (forward-line -1)))
 309     t))
 310
 311 (defun chess-ics-handler (game event &rest args)
 312   (unless chess-engine-handling-event
 313     (cond
 314      ((eq event 'initialize)
 315       (kill-buffer (current-buffer))
 316       (chess-game-run-hooks game 'disable-autosave)
 317       (let ((server
 318              (if (= (length chess-ics-server-list) 1)
 319                  (car chess-ics-server-list)
 320                (assoc (completing-read (chess-string 'ics-server-prompt)
 321                                        chess-ics-server-list
 322                                        nil t (caar chess-ics-server-list))
 323                       chess-ics-server-list))))
 324
 325         (chess-message 'ics-connecting (nth 0 server))
 326
 327         (let ((buf (if (nth 4 server)
 328                        (apply 'make-comint "chess-ics"
 329                               (nth 4 server) nil (nth 5 server))
 330                      (make-comint "chess-ics" (cons (nth 0 server)
 331                                                     (nth 1 server))))))
 332
 333           (chess-message 'ics-connected (nth 0 server))
 334
 335           (display-buffer buf)
 336           (set-buffer buf)
 337
 338           (setq chess-ics-server server
 339                 comint-prompt-regexp "^[^%\n]*% *"
 340                 comint-scroll-show-maximum-output t)
 341
 342           (add-hook 'comint-output-filter-functions 'chess-engine-filter t t)
 343
 344           (if (null (nth 2 server))
 345               (setq chess-ics-handle "guest")
 346             (setq chess-ics-handle (nth 2 server)
 347                   chess-ics-password
 348                   (let ((pass (or (nth 3 server)
 349                                   (read-passwd "Password: "))))
 350                     (if (file-readable-p pass)
 351                         (with-temp-buffer
 352                           (insert-file-contents pass)
 353                           (buffer-string))
 354                       pass))))))
 355       t)
 356
 357      ((eq event 'ready)
 358       (chess-game-run-hooks game 'announce-autosave))
 359
 360      ((eq event 'busy))                 ; ICS will inform them
 361
 362      ((eq event 'match)
 363       (setq chess-engine-pending-offer 'match)
 364       (chess-engine-send
 365        nil (format "match %s\n"
 366                    (read-string (chess-string 'challenge-whom)))))
 367
 368      ;; this handler is taken from chess-common; we need to send long
 369      ;; algebraic notation to the ICS server, not short
 370      ((eq event 'move)
 371       (when (= 1 (chess-game-index game))
 372         (chess-game-set-tag game "White" chess-full-name)
 373         (chess-game-set-tag game "Black" chess-engine-opponent-name))
 374
 375       (let ((move
 376              (if (chess-ply-any-keyword (car args)
 377                                         :castle :long-castle)
 378                  (chess-ply-to-algebraic (car args))
 379                (concat (chess-index-to-coord
 380                         (car (chess-ply-changes (car args)))) "-"
 381                         (chess-index-to-coord
 382                          (cadr (chess-ply-changes (car args))))))))
 383         (chess-engine-send nil (concat move "\n")))
 384
 385       (if (chess-game-over-p game)
 386           (chess-game-set-data game 'active nil)))
 387
 388      ((eq event 'flag-fell)
 389       (chess-common-handler game 'flag-fell))
 390
 391      ((eq event 'send)
 392       (comint-send-string (get-buffer-process (current-buffer))
 393                           (car args)))
 394
 395      ((eq event 'set-index))
 396
 397      (t
 398       (apply 'chess-network-handler game event args)))))
 399
 400 (provide 'chess-ics)
 401
 402 ;;; chess-ics.el ends here