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

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;;
   3 ;; Obtain movements and other information from an engine
   4 ;;
   5 ;; $Revision$
   6
   7 ;;; Commentary:
   8
   9 (require 'chess-game)
  10 (require 'chess-algebraic)
  11 (require 'chess-fen)
  12
  13 (defgroup chess-engine nil
  14   "Code for reading movements and other commands from an engine."
  15   :group 'chess)
  16
  17 (defvar chess-engine-regexp-alist nil)
  18 (defvar chess-engine-event-handler nil)
  19 (defvar chess-engine-response-handler nil)
  20 (defvar chess-engine-current-marker nil)
  21 (defvar chess-engine-position nil)
  22 (defvar chess-engine-game nil)
  23
  24 (make-variable-buffer-local 'chess-engine-regexp-alist)
  25 (make-variable-buffer-local 'chess-engine-event-handler)
  26 (make-variable-buffer-local 'chess-engine-response-handler)
  27 (make-variable-buffer-local 'chess-engine-current-marker)
  28 (make-variable-buffer-local 'chess-engine-position)
  29 (make-variable-buffer-local 'chess-engine-game)
  30
  31 (defvar chess-engine-process nil)
  32 (defvar chess-engine-last-pos nil)
  33 (defvar chess-engine-working nil)
  34 (defvar chess-engine-handling-event nil)
  35
  36 (make-variable-buffer-local 'chess-engine-process)
  37 (make-variable-buffer-local 'chess-engine-last-pos)
  38 (make-variable-buffer-local 'chess-engine-working)
  39
  40 ;;; Code:
  41
  42 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  43 ;;
  44 ;; User interface
  45 ;;
  46
  47 (defmacro chess-with-current-buffer (buffer &rest body)
  48   `(let ((buf ,buffer))
  49      (if buf
  50          (with-current-buffer buf
  51            ,@body)
  52        ,@body)))
  53
  54 (defun chess-engine-do-move (ply)
  55   (cond
  56    (chess-engine-game
  57     (chess-game-move chess-engine-game ply))
  58    (chess-engine-position
  59     (setq chess-engine-position (chess-ply-next-pos ply)))))
  60
  61 (defun chess-engine-default-handler (event &rest args)
  62   (let ((chess-engine-handling-event t))
  63     (cond
  64      ((eq event 'move)
  65       (let ((ply (chess-algebraic-to-ply (chess-engine-position nil)
  66                                          (car args))))
  67         (if (null ply)
  68             (message "Received invalid move from engine: %s" (car args))
  69           ;; if the game index is still 0, then our opponent is white,
  70           ;; and we need to pass over the move
  71           (let ((game (chess-engine-game nil)))
  72             (when (and game (chess-game-get-data game 'my-color)
  73                        (= (chess-game-index game) 0))
  74               (message "Your opponent played the first move, you are now black")
  75               (chess-game-run-hooks game 'pass)
  76               ;; if no one else flipped my-color, we'll do it
  77               (if (chess-game-get-data game 'my-color)
  78                   (chess-game-set-data game 'my-color nil))))
  79           (chess-engine-do-move ply)))
  80       t)
  81
  82      ((eq event 'pass)
  83       (if (and (chess-game-get-data (chess-engine-game nil) 'active)
  84                (= (chess-game-index game) 0))
  85           (message "Your opponent has passed the first move to you"))
  86       t)
  87
  88      ((eq event 'connect)
  89       (unless (chess-game-get-data (chess-engine-game nil) 'active)
  90         (if (y-or-n-p
  91              (if (and (car args) (> (length (car args)) 0))
  92                  (format "Do you wish to play a chess game against %s? "
  93                          (car args))
  94                (format "Do you wish to play a chess game against an anonymous opponent? ")))
  95             (progn
  96               (chess-game-set-data (chess-engine-game nil) 'active t)
  97               (chess-engine-send nil (format "accept %s" (user-full-name))))
  98           (chess-engine-send nil "decline"))
  99         t))
 100
 101      ((eq event 'accept)
 102       (unless (chess-game-get-data (chess-engine-game nil) 'active)
 103         (if (and (car args) (> (length (car args)) 0))
 104             (message "Your opponent, %s, is now ready to play" (car args))
 105           (message "Your opponent is now ready to play"))
 106         (chess-game-set-data (chess-engine-game nil) 'active t)
 107         t))
 108
 109      ((eq event 'quit)
 110       (message "Your opponent has quit playing"))
 111
 112      ((eq event 'resign)
 113       (if chess-engine-game
 114           (chess-game-resign chess-engine-game)))
 115
 116      ((eq event 'setup)
 117       (chess-game-set-start-position (chess-engine-game nil)
 118                                      (chess-fen-to-pos (car args)))))))
 119
 120 (defun chess-engine-create (module &optional user-handler &rest args)
 121   (let ((regexp-alist (intern-soft (concat (symbol-name module)
 122                                            "-regexp-alist")))
 123         (handler (intern-soft (concat (symbol-name module) "-handler"))))
 124     (with-current-buffer (generate-new-buffer " *chess-engine*")
 125       (let ((proc (apply handler 'initialize args)))
 126         (setq chess-engine-regexp-alist (symbol-value regexp-alist)
 127               chess-engine-event-handler handler
 128               chess-engine-response-handler
 129               (or user-handler 'chess-engine-default-handler))
 130         (when (processp proc)
 131           (unless (memq (process-status proc) '(run open))
 132             (error "Failed to start chess engine process"))
 133           (setq chess-engine-process proc)
 134           (set-process-buffer proc (current-buffer))
 135           (set-process-filter proc 'chess-engine-filter))
 136         (setq chess-engine-current-marker (point-marker)))
 137       (add-hook 'kill-buffer-hook 'chess-engine-on-kill nil t)
 138       (current-buffer))))
 139
 140 (defun chess-engine-on-kill ()
 141   "Function called when the buffer is killed."
 142   (chess-engine-detach-game nil))
 143
 144 (defun chess-engine-destroy (engine)
 145   (let ((buf (or engine (current-buffer))))
 146     (when (buffer-live-p buf)
 147       (chess-engine-command engine 'destroy)
 148       (kill-buffer buf))))
 149
 150 (defun chess-engine-command (engine event &rest args)
 151   (chess-with-current-buffer engine
 152     (apply chess-engine-event-handler event args)))
 153
 154 ;; 'ponder
 155 ;; 'search-depth
 156 ;; 'wall-clock
 157
 158 (defun chess-engine-set-option (engine option value)
 159   (chess-with-current-buffer engine
 160     ))
 161
 162 (defun chess-engine-option (engine option) 'ponder 'search-depth 'wall-clock
 163   (chess-with-current-buffer engine
 164     ))
 165
 166 (defun chess-engine-set-position (engine position)
 167   (chess-with-current-buffer engine
 168     (if chess-engine-game
 169         (chess-engine-detach-game nil))
 170     (setq chess-engine-game nil
 171           chess-engine-position position)
 172     (chess-engine-command nil 'setup position)))
 173
 174 (defun chess-engine-position (engine)
 175   (chess-with-current-buffer engine
 176     (or (and chess-engine-game
 177              (chess-game-pos chess-engine-game))
 178         chess-engine-position)))
 179
 180 (defun chess-engine-set-game (engine game)
 181   (chess-with-current-buffer engine
 182     (if chess-engine-game
 183         (chess-engine-detach-game nil))
 184     (setq chess-engine-game game
 185           chess-engine-position nil)
 186     (chess-game-add-hook game 'chess-engine-event-handler engine)
 187     (chess-engine-command nil 'setup (chess-game-pos game))))
 188
 189 (defun chess-engine-detach-game (engine)
 190   (chess-with-current-buffer engine
 191     (if chess-engine-game
 192         (chess-game-remove-hook chess-engine-game
 193                                 'chess-engine-event-handler))))
 194
 195 (defun chess-engine-game (engine)
 196   (chess-with-current-buffer engine
 197     chess-engine-game))
 198
 199 (defun chess-engine-index (engine)
 200   (chess-with-current-buffer engine
 201     (if chess-engine-game
 202         (chess-game-index chess-engine-game))))
 203
 204 (defun chess-engine-move (engine ply)
 205   (chess-with-current-buffer engine
 206     (chess-engine-do-move ply)
 207     (chess-engine-command engine 'move ply)))
 208
 209 (defun chess-engine-pass (engine)
 210   (chess-with-current-buffer engine
 211     (chess-engine-command engine 'pass)))
 212
 213 (defun chess-engine-send (engine string)
 214   "Send the given STRING to ENGINE."
 215   (chess-with-current-buffer engine
 216     (let ((proc chess-engine-process))
 217       (if proc
 218           (if (memq (process-status proc) '(run open))
 219               (process-send-string proc string)
 220             (error "The engine you were using is no longer running"))
 221         (chess-engine-command nil 'send string)))))
 222
 223 (defun chess-engine-submit (engine string)
 224   "Submit the given STRING, so ENGINE sees it in its input stream."
 225   (chess-with-current-buffer engine
 226     (let ((proc chess-engine-process))
 227       (if (and (processp proc)
 228                (not (memq (process-status proc) '(run open))))
 229           (error "The engine you were using is no longer running"))
 230       (chess-engine-filter nil string))))
 231
 232 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 233 ;;
 234 ;; Primary event handler
 235 ;;
 236
 237 (defun chess-engine-event-handler (game engine event &rest args)
 238   "Handle any commands being sent to this instance of this module."
 239   (unless chess-engine-handling-event
 240     (if (buffer-live-p engine)
 241         (with-current-buffer engine
 242           (assert (eq game (chess-engine-game nil)))
 243           (apply chess-engine-event-handler event args)))
 244     (cond
 245      ((eq event 'shutdown)
 246       (ignore-errors
 247         (chess-engine-destroy engine))))))
 248
 249 (defun chess-engine-filter (proc string)
 250   "Filter for receiving text for an engine from an outside source."
 251   (let ((buf (if (processp proc)
 252                  (process-buffer proc)
 253                (current-buffer))))
 254     (when (buffer-live-p buf)
 255       (with-current-buffer buf
 256         (let ((moving (= (point) chess-engine-current-marker)))
 257           (save-excursion
 258             ;; Insert the text, advancing the marker.
 259             (goto-char chess-engine-current-marker)
 260             (insert string)
 261             (set-marker chess-engine-current-marker (point)))
 262           (if moving (goto-char chess-engine-current-marker)))
 263         (unless chess-engine-working
 264           (setq chess-engine-working t)
 265           (unwind-protect
 266               (save-excursion
 267                 (if chess-engine-last-pos
 268                     (goto-char chess-engine-last-pos)
 269                   (goto-char (point-min)))
 270                 (beginning-of-line)
 271                 (while (not (eobp))
 272                   (let ((triggers chess-engine-regexp-alist))
 273                     (while triggers
 274                       ;; this could be accelerated by joining
 275                       ;; together the regexps
 276                       (if (and (looking-at (caar triggers))
 277                                (funcall (cdar triggers)))
 278                           (setq triggers nil)
 279                         (setq triggers (cdr triggers)))))
 280                   (forward-line)))
 281             (setq chess-engine-last-pos (point)
 282                   chess-engine-working nil)))))))
 283
 284 (provide 'chess-engine)
 285
 286 ;;; chess-engine.el ends here