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

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;;
   3 ;; An engine for interacting with Internet Chess Servers
   4 ;;
   5 ;; $Revision$
   6
   7 (require 'chess-network)
   8 (require 'ics)
   9
  10 (defgroup chess-ics nil
  11   "Engine for interacting with Internet Chess Servers."
  12   :group 'chess-engine)
  13
  14 (defvar chess-ics-ensure-ics12 nil)
  15 (make-variable-buffer-local 'chess-ics-ensure-ics12)
  16
  17 ;; ICS12 format (with artificial line breaks):
  18 ;;
  19 ;; <12> rnbqkbnr pppppppp -------- -------- \
  20 ;;      -------- -------- PPPPPPPP RNBQKBNR W \
  21 ;;      -1 1 1 1 1 0 65 jwiegley GuestZYNJ \
  22 ;;      1 5 0 39 39 300 300 1 P/e2-e4 (0:00) e4 0 0 0
  23
  24 (defun chess-ics12-parse (string)
  25   "Parse an ICS12 format string, and return a list of its info.
  26 The list is comprised of: the ply the string represents, who is white,
  27 who is black."
  28   (let ((parts (split-string string " "))
  29         (position (chess-pos-create t))
  30         white black ply)
  31
  32     (assert (= (length parts) 31))
  33
  34     ;; first, handle the layout of the position
  35     (dotimes (i 8)
  36       (dotimes (j 8)
  37         (let ((piece (aref (car parts) j)))
  38           (unless (= piece ?-)
  39             (chess-pos-set-piece position (chess-rf-to-index i j)
  40                                  piece))))
  41       (setq parts (cdr parts)))
  42
  43     ;; next, the "side to move
  44     (chess-pos-set-side-to-move position (string= (car parts) "W"))
  45     (setq parts (cdr parts))
  46
  47     ;; unknown
  48     (setq parts (cdr parts))
  49
  50     ;; castling rights?
  51     (if (string= (car parts) "1")
  52         (chess-pos-set-can-castle position ?K t))
  53     (setq parts (cdr parts))
  54     (if (string= (car parts) "1")
  55         (chess-pos-set-can-castle position ?Q t))
  56     (setq parts (cdr parts))
  57     (if (string= (car parts) "1")
  58         (chess-pos-set-can-castle position ?k t))
  59     (setq parts (cdr parts))
  60     (if (string= (car parts) "1")
  61         (chess-pos-set-can-castle position ?q t))
  62     (setq parts (cdr parts))
  63
  64     ;; unknown
  65     (setq parts (cdr parts))
  66     (setq parts (cdr parts))
  67
  68     ;; white player, black player
  69     (setq white (car parts))
  70     (setq parts (cdr parts))
  71     (setq black (car parts))
  72     (setq parts (cdr parts))
  73
  74     ;; unknown
  75     (setq parts (cdr parts))
  76     (setq parts (cdr parts))
  77     (setq parts (cdr parts))
  78
  79     ;; material values for each side
  80     (setq parts (cdr parts))
  81     (setq parts (cdr parts))
  82
  83     ;; starting time each side
  84     (setq parts (cdr parts))
  85     (setq parts (cdr parts))
  86
  87     ;; unknown
  88     (setq parts (cdr parts))
  89
  90     ;; move in elaborated notation
  91     (setq parts (cdr parts))
  92
  93     ;; time elapsed
  94     (setq parts (cdr parts))
  95
  96     ;; move in algebraic notation
  97     (setq ply (if (string= (car parts) "none")
  98                   (chess-ply-create position)
  99                 (chess-algebraic-to-ply position (car parts))))
 100     (setq parts (cdr parts))
 101
 102     ;; unknown
 103     (setq parts (cdr parts))
 104     (setq parts (cdr parts))
 105     (setq parts (cdr parts))
 106
 107     (list ply white black)))
 108
 109 (defun chess-ics-handle-move ()
 110   (let ((begin (match-beginning 1))
 111         (end (match-end 1))
 112         (info (chess-ics12-parse (match-string 2))))
 113     (if (> (chess-game-index (chess-engine-game nil)) 0)
 114         (if (eq (chess-pos-side-to-move (chess-ply-pos (car info)))
 115                 (chess-pos-side-to-move (chess-engine-position nil)))
 116             (chess-engine-do-move (car info)))
 117       (chess-game-set-plies (chess-engine-game nil)
 118                             (list (car info)))
 119       (unless (string= (cadr info) ics-handle)
 120         (chess-game-run-hooks (chess-engine-game nil) 'pass)))
 121     (delete-region begin end)
 122     t))
 123
 124 (defvar chess-ics-regexp-alist
 125   (list (cons "\\(<12> \\(.+\\)\\)" 'chess-ics-handle-move)
 126         (cons "You accept the match offer from \\([^\\.]+\\)."
 127               (function
 128                (lambda ()
 129                  (funcall chess-engine-response-handler 'connect
 130                           (match-string 1)))))))
 131
 132 (defun chess-ics-handler (event &rest args)
 133   (cond
 134    ((eq event 'initialize)
 135     (let* ((old-buffer (current-buffer))
 136            (address-or-alias (read-from-minibuffer
 137                               "ICS Server address or alias: "))
 138            (server-info-list (cdr (assoc address-or-alias
 139                                          ics-servers-alist)))
 140            (ics-address (or (car (cdr server-info-list))
 141                             address-or-alias))
 142            (ics-connect-method (or (car (nthcdr 3 server-info-list))
 143                                    ics-default-connect-method))
 144            (server-name (or (car server-info-list)
 145                             address-or-alias))
 146            (ics-port (or (car (nthcdr 2 server-info-list))
 147                          (read-from-minibuffer "ICS port: "
 148                                                ics-default-port)))
 149            (handle (read-from-minibuffer "ICS Handle: "
 150                                          ics-default-handle))
 151            (proc (concat server-name ":" handle))
 152            (buffer (concat "*" proc "*")))
 153
 154       (setq ics-handle handle)
 155
 156       (if (comint-check-proc buffer)
 157           (set-buffer buffer)
 158         (run-hooks 'ics-pre-connect-hook)
 159         (set-buffer (make-comint proc (cons ics-address ics-port)))
 160         (run-hooks 'ics-post-connect-hook)
 161         (ics-mode))
 162
 163       (set (make-variable-buffer-local 'ics-last-command-time)
 164            (ics-current-time))
 165       (set (make-variable-buffer-local 'ics-idle-p) nil)
 166       (set (make-variable-buffer-local 'ics-interface-variable-set) nil)
 167       (set (make-variable-buffer-local 'ics-wakeup-last-alarm-time)
 168            (ics-current-time))
 169       (set (make-variable-buffer-local 'ics-last-highlight-end) nil)
 170       (set (make-variable-buffer-local 'ics-last-add-buttons-end) nil)
 171
 172       (add-hook 'comint-output-filter-functions 'chess-ics-filter t t)
 173       (set (make-local-variable 'comint-preoutput-filter-functions)
 174            '(chess-ics-strip-cr))
 175
 176       (display-buffer buffer)
 177       (kill-buffer old-buffer)
 178
 179       nil))
 180
 181    ((eq event 'shutdown)
 182     (ignore-errors
 183       (chess-engine-send nil "quit\n")))
 184
 185    ((eq event 'move)
 186     (unless chess-ics-ensure-ics12
 187       (comint-send-string (get-buffer-process (current-buffer))
 188                           "set style 12\n")
 189       (setq chess-ics-ensure-ics12 t))
 190     (chess-engine-send nil (concat (chess-ply-to-algebraic (car args))
 191                                    "\n")))
 192
 193    ((eq event 'send)
 194     (comint-send-string (get-buffer-process (current-buffer)) (car args)))))
 195
 196 (defun chess-ics-filter (string)
 197   (save-excursion
 198     (if chess-engine-last-pos
 199         (goto-char chess-engine-last-pos)
 200       (goto-char (point-min)))
 201     (beginning-of-line)
 202     (while (not (eobp))
 203       (let ((triggers chess-ics-regexp-alist))
 204         (while triggers
 205           ;; this could be accelerated by joining together the
 206           ;; regexps
 207           (if (and (looking-at (concat "[^\n\r]*" (caar triggers)))
 208                    (funcall (cdar triggers)))
 209               (setq triggers nil)
 210             (setq triggers (cdr triggers)))))
 211       (forward-line))
 212     (setq chess-engine-last-pos (point))))
 213
 214 (defun chess-ics-strip-cr (string)
 215   (while (string-match "\r" string)
 216     (setq string (replace-match "" t t string)))
 217   string)
 218
 219 (provide 'chess-ics)
 220
 221 ;;; chess-ics.el ends here