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

   1 ;;; chess-engine.el --- Obtain movements and other information from an engine
   2
   3 ;; Copyright (C) 2014 Free Software Foundation, Inc.
   4
   5 ;; This is free software; you can redistribute it and/or modify it under
   6 ;; the terms of the GNU General Public License as published by the Free
   7 ;; Software Foundation; either version 3, or (at your option) any later
   8 ;; version.
   9 ;;
  10 ;; This is distributed in the hope that it will be useful, but WITHOUT
  11 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  12 ;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  13 ;; for more details.
  14 ;;
  15 ;; You should have received a copy of the GNU General Public License
  16 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  17
  18 ;;; Commentary:
  19
  20 ;;; Code:
  21
  22 (require 'chess-module)
  23
  24 (defgroup chess-engine nil
  25   "Code for reading movements and other commands from an engine."
  26   :group 'chess)
  27
  28 (defvar chess-engine-regexp-alist nil)
  29 (defvar chess-engine-response-handler nil)
  30 (defvar chess-engine-current-marker nil)
  31 (defvar chess-engine-pending-offer nil)
  32 (defvar chess-engine-pending-arg nil)
  33 (defvar chess-engine-opponent-name nil)
  34
  35 (make-variable-buffer-local 'chess-engine-regexp-alist)
  36 (make-variable-buffer-local 'chess-engine-response-handler)
  37 (make-variable-buffer-local 'chess-engine-current-marker)
  38 (make-variable-buffer-local 'chess-engine-pending-offer)
  39 (make-variable-buffer-local 'chess-engine-pending-arg)
  40 (make-variable-buffer-local 'chess-engine-opponent-name)
  41
  42 (defvar chess-engine-process nil)
  43 (defvar chess-engine-last-pos nil)
  44 (defvar chess-engine-working nil)
  45 (defvar chess-engine-handling-event nil)
  46
  47 (make-variable-buffer-local 'chess-engine-process)
  48 (make-variable-buffer-local 'chess-engine-last-pos)
  49 (make-variable-buffer-local 'chess-engine-working)
  50
  51 (defvar chess-engine-inhibit-auto-pass nil)
  52
  53 ;;; Code:
  54
  55 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  56 ;;
  57 ;; User interface
  58 ;;
  59
  60 (chess-message-catalog 'english
  61   '((invalid-fen    . "Received invalid FEN string: %s")
  62     (invalid-pgn    . "Received invalid PGN text")
  63     (now-black      . "Your opponent played the first move, you are now black")
  64     (move-passed    . "Your opponent has passed the move to you")
  65     (want-to-play   . "Do you wish to play a chess game against %s? ")
  66     (want-to-play-a . "Do you wish to play a chess game against an anonymous opponent? ")
  67     (opp-quit       . "Your opponent has quit playing")
  68     (opp-resigned   . "Your opponent has resigned")
  69     (opp-draw       . "Your opponent offers a draw, accept? ")
  70     (opp-abort      . "Your opponent wants to abort this game, accept? ")
  71     (opp-undo       . "Your opponent wants to take back %d moves, accept? ")
  72     (opp-ready      . "Your opponent, %s, is now ready to play")
  73     (opp-ready-a    . "Your opponent is ready to play; pass or make your move")
  74     (opp-draw-acc   . "Your draw offer was accepted")
  75     (opp-abort-acc  . "Your offer to abort was accepted")
  76     (opp-undo-acc   . "Request to undo %d moves was accepted")
  77     (opp-draw-dec   . "Your draw offer was declined")
  78     (opp-abort-dec  . "Your offer to abort was declined")
  79     (opp-undo-dec   . "Your request to undo %d moves was decline")
  80     (opp-draw-ret   . "Your opponent has retracted their draw offer")
  81     (opp-abort-ret  . "Your opponent has retracted their offer to abort")
  82     (opp-undo-ret   . "Your opponent has retracted their request to undo %d moves")
  83     (opp-illegal    . "Your opponent states your last command was illegal")
  84     (opp-call-flag  . "Your flag fell, and your opponent has called time")
  85     (opp-flag-fell  . "Your opponent has forfeited the game on time")
  86     (failed-start   . "Failed to start chess engine process")))
  87
  88 (defsubst chess-engine-convert-algebraic (move &optional trust-check)
  89   "Convert algebraic move to a ply in reference to the engine position.
  90 If conversion fails, this function fired an 'illegal event."
  91   (or (chess-algebraic-to-ply (chess-engine-position nil) move trust-check)
  92       (chess-engine-command nil 'illegal)))
  93
  94 (defsubst chess-engine-convert-fen (fen)
  95   (or (chess-fen-to-pos fen)
  96       (ignore (chess-message 'invalid-fen fen))))
  97
  98 (defsubst chess-engine-convert-pgn (pgn)
  99   (or (chess-pgn-to-game pgn)
 100       (ignore (chess-message 'invalid-pgn))))
 101
 102 (defvar chess-full-name)
 103
 104 (defun chess-engine-default-handler (event &rest args)
 105   "Default engine response handler."
 106   (let ((game (chess-engine-game nil)))
 107     (cond
 108      ((eq event 'move)
 109       (let ((chess-engine-handling-event t))
 110         (when (and (car args)
 111                    (chess-game-data game 'active))
 112           ;; if the game index is still 0, then our opponent
 113           ;; is white, and we need to pass over the move
 114           (when (and (not chess-engine-inhibit-auto-pass)
 115                      (chess-game-data game 'my-color)
 116                      (zerop (chess-game-index game)))
 117             (chess-game-set-tag game "White" chess-engine-opponent-name)
 118             (chess-game-set-tag game "Black" chess-full-name)
 119             (chess-message 'now-black)
 120             (chess-game-run-hooks game 'pass)
 121             ;; if no one else flipped my-color, we'll do it
 122             (if (chess-game-data game 'my-color)
 123                 (chess-game-set-data game 'my-color nil)))
 124
 125           (chess-game-move game (car args))
 126
 127           (if (chess-game-over-p game)
 128               (chess-game-set-data game 'active nil))
 129           t)))
 130
 131      ((eq event 'pass)
 132       (when (chess-game-data game 'active)
 133         (chess-message 'move-passed)
 134         t))
 135
 136      ((eq event 'match)
 137       (if (chess-game-data game 'active)
 138           (chess-engine-command nil 'busy)
 139         (let ((name (and (> (length (car args)) 0) (car args))))
 140           (if (y-or-n-p (if name
 141                             (chess-string 'want-to-play (car args))
 142                           (chess-string 'want-to-play-a)))
 143               (progn
 144                 (setq chess-engine-opponent-name (or name "Anonymous"))
 145                 (let ((chess-engine-handling-event t))
 146                   (chess-engine-set-position nil))
 147                 (chess-engine-command nil 'accept name))
 148             (chess-engine-command nil 'decline))))
 149       t)
 150
 151      ((eq event 'setup-pos)
 152       (when (car args)
 153         ;; we don't want the `setup-game' event coming back to us
 154         (let ((chess-engine-handling-event t))
 155           (chess-engine-set-position nil (car args) t))
 156         t))
 157
 158      ((eq event 'setup-game)
 159       (when (car args)
 160         ;; we don't want the `setup-game' event coming back to us
 161         (let ((chess-engine-handling-event t)
 162               (chess-game-inhibit-events t))
 163           (chess-engine-set-game nil (car args))
 164           (chess-game-set-data game 'active t)
 165           (if (string= chess-full-name
 166                        (chess-game-tag game "White"))
 167               (chess-game-set-data game 'my-color t)
 168             (chess-game-set-data game 'my-color nil)))
 169         t))
 170
 171      ((eq event 'quit)
 172       (chess-message 'opp-quit)
 173       (let ((chess-engine-handling-event t))
 174         (chess-game-set-data game 'active nil))
 175       t)
 176
 177      ((eq event 'resign)
 178       (let ((chess-engine-handling-event t))
 179         (chess-message 'opp-resigned)
 180         (chess-game-end game :resign)
 181         t))
 182
 183      ((eq event 'draw)
 184       (if (y-or-n-p (chess-string 'opp-draw))
 185           (progn
 186             (let ((chess-engine-handling-event t))
 187               (chess-game-end game :drawn)
 188               (chess-game-set-data game 'active nil))
 189             (chess-engine-command nil 'accept))
 190         (chess-engine-command nil 'decline))
 191       t)
 192
 193      ((eq event 'abort)
 194       (if (y-or-n-p (chess-string 'opp-abort))
 195           (progn
 196             (let ((chess-engine-handling-event t))
 197               (chess-game-end game :aborted)
 198               (chess-game-set-data game 'active nil))
 199             (chess-engine-command nil 'accept))
 200         (chess-engine-command nil 'decline))
 201       t)
 202
 203      ((eq event 'undo)
 204       (if (y-or-n-p (chess-string 'opp-undo (car args)))
 205           (progn
 206             (let ((chess-engine-handling-event t))
 207               (chess-game-undo game (car args)))
 208             (chess-engine-command nil 'accept))
 209         (chess-engine-command nil 'decline))
 210       t)
 211
 212      ((eq event 'accept)
 213       (when chess-engine-pending-offer
 214         (if (eq chess-engine-pending-offer 'match)
 215             (unless (chess-game-data game 'active)
 216               (let ((name (and (> (length (car args)) 0)
 217                                (car args))))
 218                 (if name
 219                     (chess-message 'opp-ready (car args))
 220                   (chess-message 'opp-ready-a))
 221                 (setq chess-engine-opponent-name (or name "Anonymous"))
 222                 (let ((chess-engine-handling-event t))
 223                   (chess-engine-set-position nil))))
 224           (let ((chess-engine-handling-event t))
 225             (cond
 226              ((eq chess-engine-pending-offer 'draw)
 227               (chess-message 'opp-draw-acc)
 228               (chess-game-end game :drawn)
 229               (chess-game-set-data game 'active nil))
 230
 231              ((eq chess-engine-pending-offer 'abort)
 232               (chess-message 'opp-abort-acc)
 233               (chess-game-end game :aborted)
 234               (chess-game-set-data game 'active nil))
 235
 236              ((eq chess-engine-pending-offer 'undo)
 237               (chess-message 'opp-undo-acc chess-engine-pending-arg)
 238               (chess-game-undo game chess-engine-pending-arg))
 239              ((eq chess-engine-pending-offer 'my-undo)
 240               (chess-game-undo game (car args))))))
 241         (setq chess-engine-pending-offer nil
 242               chess-engine-pending-arg nil)
 243         t))
 244
 245      ((eq event 'decline)
 246       (when chess-engine-pending-offer
 247         (cond
 248          ((eq chess-engine-pending-offer 'draw)
 249           (chess-message 'opp-draw-dec))
 250
 251          ((eq chess-engine-pending-offer 'abort)
 252           (chess-message 'opp-abort-dec))
 253
 254          ((eq chess-engine-pending-offer 'undo)
 255           (chess-message 'opp-undo-dec chess-engine-pending-arg)))
 256
 257         (setq chess-engine-pending-offer nil
 258               chess-engine-pending-arg nil)
 259         t))
 260
 261      ((eq event 'retract)
 262       (when chess-engine-pending-offer
 263         (cond
 264          ((eq chess-engine-pending-offer 'draw)
 265           (chess-message 'opp-draw-ret))
 266
 267          ((eq chess-engine-pending-offer 'abort)
 268           (chess-message 'opp-abort-ret))
 269
 270          ((eq chess-engine-pending-offer 'undo)
 271           (chess-message 'opp-undo-ret chess-engine-pending-arg)))
 272
 273         (setq chess-engine-pending-offer nil
 274               chess-engine-pending-arg nil)
 275         t))
 276
 277      ((eq event 'illegal)
 278       (chess-message 'opp-illegal)
 279       (let ((chess-engine-handling-event t))
 280         (chess-game-undo game 1)))
 281
 282      ((eq event 'call-flag)
 283       (let ((remaining
 284              (if (car args)
 285                  -1
 286                (chess-game-data game (if (chess-game-data game 'my-color)
 287                                          'white-remaining
 288                                        'black-remaining)))))
 289         (when (< remaining 0)
 290           (chess-message 'opp-call-flag)
 291           (chess-game-run-hooks game 'flag-fell))))
 292
 293      ((eq event 'flag-fell)
 294       (chess-message 'opp-flag-fell)
 295       (chess-game-end game :flag-fell)
 296       (chess-game-set-data game 'active nil))
 297
 298      ((eq event 'kibitz)
 299       (let ((chess-engine-handling-event t))
 300         (chess-game-run-hooks game 'kibitz (car args))))
 301
 302      ((eq event 'chat)
 303       (let ((chess-engine-handling-event t))
 304         (chess-game-run-hooks game 'chat (car args)))))))
 305
 306 (defun chess-engine-create (module game &optional response-handler
 307                                  &rest handler-ctor-args)
 308   "Create a new chess engine MODULE (a symbol) associated with GAME.
 309 Optionally supply a new RESPONSE-HANDLER."
 310   (let* ((engine (apply 'chess-module-create module game nil
 311                         handler-ctor-args)))
 312     (when engine
 313       (with-current-buffer engine
 314         (setq chess-engine-regexp-alist
 315               (copy-alist
 316                (symbol-value
 317                 (let ((sym (intern-soft (concat (symbol-name module) "-regexp-alist"))))
 318                   (when (boundp sym) sym))))
 319               chess-engine-response-handler
 320               (or response-handler 'chess-engine-default-handler))
 321         (let ((proc chess-engine-process))
 322           (when (and proc (processp proc))
 323             (unless (memq (process-status proc) '(run open listen))
 324               (chess-error 'failed-start))
 325             (if (or (not (process-filter proc))
 326                     (eq (process-filter proc) 'internal-default-process-filter))
 327               (set-process-filter proc 'chess-engine-filter)))
 328           (setq chess-engine-current-marker (point-marker))
 329           (chess-game-set-data game 'engine (current-buffer)))))))
 330
 331 (defalias 'chess-engine-destroy 'chess-module-destroy)
 332
 333 (defun chess-engine-command (engine event &rest args)
 334   "Call the handler of ENGINE with EVENT (a symbol) and ARGS."
 335   (chess-with-current-buffer engine
 336     (apply chess-module-event-handler chess-module-game event args)))
 337
 338 ;; 'ponder
 339 ;; 'search-depth
 340 ;; 'wall-clock
 341
 342 (defun chess-engine-set-option (engine option value)
 343   "Set ENGINE OPTION to VALUE by invoking its handler with the 'set-option
 344 event."
 345   (chess-with-current-buffer engine
 346     (chess-engine-command engine 'set-option option value)))
 347
 348 (defun chess-engine-set-response-handler (engine &optional response-handler)
 349   "Set a new RESPONSE-HANDLER for ENGINE."
 350   (chess-with-current-buffer engine
 351     (setq chess-engine-response-handler
 352           (or response-handler 'chess-engine-default-handler))))
 353
 354 (defun chess-engine-response-handler (engine)
 355   "Return the function currently defined as the response-handler for ENGINE."
 356   (chess-with-current-buffer engine
 357     chess-engine-response-handler))
 358
 359 (defun chess-engine-set-position (engine &optional position my-color)
 360   (chess-with-current-buffer engine
 361     (let ((chess-game-inhibit-events t))
 362       (if position
 363           (progn
 364             (chess-game-set-start-position chess-module-game position)
 365             (chess-game-set-data chess-module-game 'my-color my-color))
 366         (chess-game-set-start-position chess-module-game
 367                                        chess-starting-position)
 368         (chess-game-set-data chess-module-game 'my-color t))
 369       (chess-game-set-data chess-module-game 'active t))
 370     (chess-game-run-hooks chess-module-game 'orient)))
 371
 372 (defun chess-engine-position (engine)
 373   "Return the current position of the game associated with ENGINE."
 374   (chess-with-current-buffer engine
 375     (chess-game-pos chess-module-game)))
 376
 377 (defalias 'chess-engine-game 'chess-module-game)
 378 (defalias 'chess-engine-set-game 'chess-module-set-game)
 379 (defalias 'chess-engine-set-game* 'chess-module-set-game*)
 380 (defalias 'chess-engine-index 'chess-module-game-index)
 381
 382 (defun chess-engine-move (engine ply)
 383   (chess-with-current-buffer engine
 384     (chess-game-move chess-module-game ply)
 385     (chess-engine-command engine 'move ply)))
 386
 387 (chess-message-catalog 'english
 388   '((engine-not-running . "The engine you were using is no longer running")))
 389
 390 (defun chess-engine-send (engine string)
 391   "Send the given STRING to ENGINE.
 392 If `chess-engine-process' is a valid process object, use `process-send-string'
 393 to submit the data.  Otherwise, the 'send event is triggered and the engine
 394 event handler can take care of the data."
 395   (chess-with-current-buffer engine
 396     (let ((proc chess-engine-process))
 397       (if proc
 398           (if (memq (process-status proc) '(run open))
 399               (process-send-string proc string)
 400             (chess-message 'engine-not-running)
 401             (chess-engine-command nil 'destroy))
 402         (chess-engine-command nil 'send string)))))
 403
 404 (defun chess-engine-submit (engine string)
 405   "Submit the given STRING, so ENGINE sees it in its input stream."
 406   (chess-with-current-buffer engine
 407     (let ((proc chess-engine-process))
 408       (when (and proc (processp proc)
 409                  (not (memq (process-status proc) '(run open))))
 410         (chess-message 'engine-not-running)
 411         (chess-engine-command nil 'destroy))
 412       (chess-engine-filter nil string))))
 413
 414 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 415 ;;
 416 ;; Primary event handler
 417 ;;
 418
 419 (defun chess-engine-sentinel (proc _event)
 420   (chess-engine-destroy (process-buffer proc)))
 421
 422 (defun chess-engine-filter (proc &optional string)
 423   "Filter for receiving text for an engine from an outside source."
 424   (let ((buf (if (and proc (processp proc))
 425                  (process-buffer proc)
 426                (current-buffer)))
 427         (inhibit-redisplay t)
 428         last-line-no-newline)
 429     (when (buffer-live-p buf)
 430       (with-current-buffer buf
 431         (if (stringp proc)
 432             (setq string proc)
 433           (let ((moving (= (point) chess-engine-current-marker)))
 434             (save-excursion
 435               ;; Insert the text, advancing the marker.
 436               (goto-char chess-engine-current-marker)
 437               (insert string)
 438               (set-marker chess-engine-current-marker (point)))
 439             (if moving (goto-char chess-engine-current-marker))))
 440         (unless chess-engine-working
 441           (setq chess-engine-working t)
 442           (save-excursion
 443             (if chess-engine-last-pos
 444                 (goto-char chess-engine-last-pos)
 445               (goto-char (point-min)))
 446             (unwind-protect
 447                 (while (and (not (eobp)) (not last-line-no-newline))
 448                   (let ((case-fold-search nil)
 449                         (triggers chess-engine-regexp-alist)
 450                         last-trigger result)
 451                     (while triggers
 452                       ;; this could be accelerated by joining
 453                       ;; together the regexps
 454                       (if (and (re-search-forward (caar triggers)
 455                                                   (line-end-position) t)
 456                                (setq result (funcall (cdar triggers))))
 457                           (progn
 458                             (when (eq result 'once)
 459                               (if last-trigger
 460                                   (setcdr last-trigger (cdr triggers))
 461                                 (setq chess-engine-regexp-alist
 462                                       (cdr triggers))))
 463                             (setq triggers nil))
 464                         (setq last-trigger triggers
 465                               triggers (cdr triggers)))))
 466                   (if (= (line-end-position) (point-max))
 467                       (setq last-line-no-newline t)
 468                     (forward-line)))
 469               (setq chess-engine-last-pos (point)
 470                     chess-engine-working nil))))))))
 471
 472 (provide 'chess-engine)
 473
 474 ;;; chess-engine.el ends here