path: root/chess-ics.el

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; An engine for interacting with Internet Chess Servers
;;
;; jww (2002-04-23): This module has only been tested on FICS.
;;

(eval-when-compile (require 'cl))

(require 'comint)
(require 'chess-network)
(require 'chess-pos)

(defgroup chess-ics nil
  "Engine for interacting with Internet Chess Servers."
  :group 'chess-engine)

(defcustom chess-ics-server-list
  '(("freechess.org" 5000)
    ("chess.unix-ag.uni-kl.de" 5000)
    ("chess.mds.mdh.se" 5000)
    ("chessclub.com" 5000))
  "A list of servers to connect to.
The format of each entry is:

  (SERVER PORT [HANDLE] [PASSWORD-OR-FILENAME] [HELPER] [HELPER ARGS...])"
  :type '(repeat (list (string :tag "Server")
		       (integer :tag "Port")
		       (choice (const :tag "Login as guest" nil)
			       (string :tag "Handle"))
		       (choice (const :tag "No password or ask" nil)
			       (string :tag "Password")
			       (file :tag "Filename"))
		       (choice (const :tag "Direct connection" nil)
			       (file :tag "Command"))
		       (choice (const :tag "No arguments" nil)
			       (repeat string))))
  :group 'chess-ics)

(defvar chess-ics-server nil
  "The `chess-ics-server-list' entry used for this connection.")
(make-variable-buffer-local 'chess-ics-server)

(defvar chess-ics-handle nil
  "The ICS handle of this connection.")
(make-variable-buffer-local 'chess-ics-handle)

(defvar chess-ics-password nil
  "Password to use to identify to the server.")
(make-variable-buffer-local 'chess-ics-password)

(defvar chess-ics-regexp-alist
  (list
   (cons "\\(ogin\\|name\\):"
	 (function
	  (lambda ()
	    (chess-engine-send nil (concat chess-ics-handle "\n"))
	    'once)))
   (cons "[Pp]assword:"
	 (function
	  (lambda ()
	    (chess-engine-send nil (concat chess-ics-password "\n"))
	    'once)))
   (cons "%"
	 (function
	  (lambda ()
	    (chess-engine-send nil "set style 12\nset bell 0\n")
	    'once)))
   (cons "\\(Logging you in as\\|Your name for this session will be\\) \"\\([^\"]+\\)\""
	 (function
	  (lambda ()
	    (setq chess-ics-handle (match-string 2))
	    'once)))
   (cons "Press return to enter the server as"
	 (function
	  (lambda ()
	    (chess-engine-send nil "\n")
	    'once)))
   (cons "The game has been aborted on move [^.]+\\."
	 (function
	  (lambda ()
	    (let ((chess-engine-pending-offer 'abort))
	      (funcall chess-engine-response-handler 'accept)))))
   (cons "{Game \\([0-9]+\\) (\\(\\S-+\\) vs\\. \\(\\S-+\\)) Creating [^ ]+ \\([^ ]+\\).*}"
	 (function
	  (lambda ()
	    (let ((game-number (string-to-int (match-string 1)))
		  (white (match-string-no-properties 2))
		  (black (match-string-no-properties 3)))
	      ;(chess-game-set-tag game "White" white)
	      ;(chess-game-set-tag game "Black" black)
	      ;(chess-game-set-tag game "Site" (car chess-ics-server))
	      ))))
   (cons "<12>\\s-+\\(\\([BKNPQRbknpqr-]\\{8\\}\\s-\\)\\{8\\}[BW].+\\)"
	 #'chess-ics-handle-ics12)
   (cons "\\S-+ would like to take back \\([0-9]+\\) half move(s)."
	 (function
	  (lambda ()
	    (funcall chess-engine-response-handler 'undo
		     (string-to-int (match-string 1))))))
   (cons "\\S-+ accepts the takeback request\\."
	 (function
	  (lambda ()
	    (funcall chess-engine-response-handler 'accept))))
   (cons "\\(\\S-+\\) resigns}"
	 (function
	  (lambda ()
	    (if (string= (match-string 1) chess-engine-opponent-name)
		(funcall chess-engine-response-handler 'resign)))))
   (cons "\\(\\S-+\\) forfeits on time}"
	 (function
	  (lambda ()
	    (if (string= (match-string 1) chess-engine-opponent-name)
		(funcall chess-engine-response-handler 'flag-fell)
	      (funcall chess-engine-response-handler 'call-flag t)))))
   (cons "Illegal move (\\([^)]+\\))\\."
	 (function
	  (lambda ()
	    (funcall chess-engine-response-handler 'illegal
		     (match-string 1)))))
   (cons "Challenge: \\(\\S-+\\) \\S-+ \\S-+ \\S-+ .+"
	 (function
	  (lambda ()
	    (funcall chess-engine-response-handler 'match
		     (match-string 1))))))
  "An alist of regular expressions to use to scan ICS server output.
The car of each element is the regexp to try, and the cdr is a function
to run whenever the regexp matches.")

(chess-message-catalog 'english
  '((ics-server-prompt . "Connect to chess server: ")
    (ics-connecting    . "Connecting to Internet Chess Server '%s'...")
    (ics-connected     . "Connecting to Internet Chess Server '%s'...done")
    (challenge-whom    . "Whom would you like challenge? ")
    (failed-ics-parse  . "Failed to parse ICS move string (%s): %s")))

;; ICS12 format (with artificial line breaks):
;;
;; <12> rnbqkbnr pppppppp -------- -------- \
;;      -------- -------- PPPPPPPP RNBQKBNR W \
;;      -1 1 1 1 1 0 65 jwiegley GuestZYNJ \
;;      1 5 0 39 39 300 300 1 P/e2-e4 (0:00) e4 0 0 0

(defun chess-ics-handle-ics12 ()
  "Handle an ICS12 format string."
  (let ((chess-engine-handling-event t)
	(begin (match-beginning 0))
	(end (match-end 0))
	(parts (split-string (match-string 1) " "))
	(position (chess-pos-create t))
	(game (chess-engine-game nil))
	white black move status time-control error)

    (assert (= (length parts) 32))

    ;; first, handle the layout of the position
    (dotimes (r 8)
      (let ((rank (pop parts)))
	(dotimes (f 8)
	  (let ((piece (aref rank f)))
	    (unless (= piece ?-)
	      (chess-pos-set-piece position (chess-rf-to-index r f) piece))))))

    ;; next, the "side to move"
    (chess-pos-set-side-to-move position (string= (pop parts) "W"))

    ;; -1 if the previous move was NOT a double pawn push, otherwise
    ;; the chess board file (numbered 0--7 for a--h) in which the
    ;; double push was made
    (let ((file (string-to-number (pop parts))))
      (when (>= file 0)
	(chess-pos-set-en-passant
	 position (chess-rf-to-index
		   (if (chess-pos-side-to-move position) 3 4) file))))

    ;; can White/Black still castle short/long? (0=no, 1=yes)
    (mapc (lambda (castle)
	    (if (string= (pop parts) "1")
		(chess-pos-set-can-castle position castle t)))
	  '(?K ?Q ?k ?q))

    ;; the number of moves made since the last irreversible move.  (0
    ;; if last move was irreversible.  If the value is >= 100, the
    ;; game can be declared a draw due to the 50 move rule.)
    (setq parts (cdr parts))

    ;; The game number
    (setq parts (cdr parts))

    ;; white player, black player
    (setq white (pop parts)
	  black (pop parts))

    ;; my relation to this game:
    ;; -3 isolated position, such as for "ref 3" or the "sposition"
    ;;    command
    ;; -2 I am observing game being examined
    ;;  2 I am the examiner of this game
    ;; -1 I am playing, it is my opponent's move
    ;;  1 I am playing and it is my move
    ;;  0 I am observing a game being played
    (setq status (string-to-int (pop parts)))
    (cond ((= status 2)
	   (chess-game-set-data game 'my-color (chess-pos-side-to-move position))))

    ;; initial time and increment (in seconds) of the match
    (setq time-control (format "%s/%s" (pop parts) (pop parts)))

    ;; material values for each side
    (let ((centipawn (* 100 (- (string-to-int (pop parts))
			       (string-to-int (pop parts))))))
      (chess-pos-set-epd position 'ce (if (chess-pos-side-to-move position)
					  centipawn
					(- centipawn))))

    ;; White's and Black's remaining time
    (chess-game-set-data game 'white-remaining (string-to-number (pop parts)))
    (chess-game-set-data game 'black-remaining (string-to-number (pop parts)))

    ;; the number of the move about to be made (standard chess
    ;; numbering -- White's and Black's first moves are both 1, etc.)
    (setq parts (cdr parts))

    ;; move in long alegebraic notation
    (setq parts (cdr parts))

    ;; time taken to make previous move "(min:sec)".
    (setq parts (cdr parts))

    ;; move in short algebraic notation (SAN)
    (setq move (unless (string= (car parts) "none")
		 (car parts)))
    (setq parts (cdr parts))

    ;; checkmate, etc., is stated in the SAN text
    (when move
      (cond
       ((= ?+ (aref move (1- (length move))))
	(chess-pos-set-status position :check))
       ((= ?# (aref move (1- (length move))))
	(chess-pos-set-status position :checkmate)
	(chess-pos-set-epd position 'ce 32767))
       (nil
	;; jww (2002-04-30): what about stalemate?  do I need to
	;; calculate this each time?
	(chess-pos-set-status position :stalemate))))

    ;; flip field for board orientation: 1 = Black at bottom, 0 =
    ;; White at bottom.
    (setq parts (cdr parts))

    ;; jww (2002-04-18): what do these two mean?
    (setq parts (cdr parts))
    (setq parts (cdr parts))

    (unwind-protect
	(if move
	    ;; each move gives the _position occurring after the ply_,
	    ;; which means that if the move says W, it is telling us
	    ;; what our opponents move was
	    (if (progn (setq error 'comparing-colors)
		       (eq (chess-pos-side-to-move position)
			   (chess-game-data game 'my-color)))
		(let ((ign (setq error 'converting-ply))
		      (ply (chess-engine-convert-algebraic move t)))
		  (setq error 'applying-move)
		  ;; save us from generating a position we already have
		  (chess-ply-set-keyword ply :next-pos position)
		  (chess-pos-set-preceding-ply position ply)
		  (chess-game-move game ply)
		  (setq error nil))
	      (setq error nil))
	  (let ((chess-game-inhibit-events t)
		(color (chess-pos-side-to-move position))
		plies)
	    (when (or (= 1 status) (= -1 status))
	      (chess-game-set-data game 'my-color (if (= 1 status)
						      color
						    (not color)))
	      (setq chess-engine-opponent-name (if (= 1 status) black white))
	      (chess-game-set-data game 'active t))
	    (chess-game-set-tag game "White" white)
	    (chess-game-set-tag game "Black" black)
	    (chess-game-set-tag game "Site" (car chess-ics-server))
	    (chess-game-set-tag game "TimeControl" time-control)
	    (setq error 'setting-start-position)
	    (chess-game-set-start-position game position))
	  (setq error 'orienting-board)
	  (chess-game-run-hooks game 'orient)
	  (setq error nil))
      (if error
	  (chess-message 'failed-ics-parse error
			 (buffer-substring-no-properties begin end)))
      (when nil
	(goto-char begin)
	(delete-region begin end)
	(save-excursion
	  (while (and (forward-line -1)
		      (or (looking-at "^[ \t]*$")
			  (looking-at "^[^% \t\n\r]+%\\s-*$")))
	    (delete-region (match-beginning 0) (1+ (match-end 0)))))
	;; we need to counter the forward-line in chess-engine-filter
	(unless error
	  (forward-line -1))))
    t))

(defun chess-ics-handler (game event &rest args)
  (unless chess-engine-handling-event
    (cond
     ((eq event 'initialize)
      (kill-buffer (current-buffer))
      (chess-game-run-hooks game 'disable-autosave)
      (let* ((server
	     (if (= (length chess-ics-server-list) 1)
		 (car chess-ics-server-list)
	       (assoc (completing-read (chess-string 'ics-server-prompt)
				       chess-ics-server-list
				       nil t (caar chess-ics-server-list))
		      chess-ics-server-list)))
	     (handle (or (nth 2 server) "guest"))
	     (password (when (nth 2 server)
			 (let ((pass (or (nth 3 server)
					 (read-passwd "Password: "))))
			   (if (file-readable-p pass)
			       (with-temp-buffer
				 (insert-file-contents pass)
				 (buffer-string))
			     pass)))))
	(chess-message 'ics-connecting (nth 0 server))

	(let ((buf (if (nth 4 server)
		       (apply 'make-comint "chess-ics"
			      (nth 4 server) nil (nth 5 server))
		     (make-comint "chess-ics" (cons (nth 0 server)
						    (nth 1 server))))))
	  (chess-message 'ics-connected (nth 0 server))

	  (display-buffer buf)
	  (set-buffer buf)

	  (setq chess-ics-server server
		chess-ics-handle handle
		chess-ics-password password
		comint-prompt-regexp "^[^%\n]*% *"
		comint-scroll-show-maximum-output t)

	  (add-hook 'comint-output-filter-functions 'chess-engine-filter t t)))
      t)

     ((eq event 'ready)
      (chess-game-run-hooks game 'announce-autosave))

     ((eq event 'busy))			; ICS will inform them

     ((eq event 'match)
      (setq chess-engine-pending-offer 'match)
      (chess-engine-send
       nil (format "match %s\n"
		   (read-string (chess-string 'challenge-whom)))))

     ;; this handler is taken from chess-common; we need to send long
     ;; algebraic notation to the ICS server, not short
     ((eq event 'move)
      (when (= 1 (chess-game-index game))
	(chess-game-set-tag game "White" chess-full-name)
	(chess-game-set-tag game "Black" chess-engine-opponent-name))

      (chess-engine-send
       nil
       (concat (if (chess-ply-any-keyword (car args) :castle :long-castle)
		   (chess-ply-to-algebraic (car args))
		 (concat (chess-index-to-coord
			  (car (chess-ply-changes (car args)))) "-"
			 (chess-index-to-coord
			  (cadr (chess-ply-changes (car args))))))
	       "\n"))

      (if (chess-game-over-p game)
	  (chess-game-set-data game 'active nil)))

     ((eq event 'flag-fell)
      (chess-common-handler game 'flag-fell))

     ((eq event 'send)
      (comint-send-string (get-buffer-process (current-buffer))
			  (car args)))

     ((eq event 'set-index))

     ((eq event 'forward)
      (chess-engine-send nil "forward\n"))
     (t
      (apply 'chess-network-handler game event args)))))

(provide 'chess-ics)

;;; chess-ics.el ends here