my-emacs-d/elpa/go-20160430.1739/back-ends/igs.el
2016-09-15 13:54:46 +02:00

502 lines
18 KiB
EmacsLisp
Raw Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

;;; igs.el --- IGS GO back-end
;; Copyright (C) 2012-2013 Free Software Foundation, Inc.
;; Author: Eric Schulte <schulte.eric@gmail.com>
;; Created: 2012-05-15
;; Version: 0.1
;; Keywords: game go sgf igs
;; This software is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This software is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;; Commentary:
;; http://www.pandanet.co.jp/English/commands/term/Summary.html
;; Code:
(require 'go-api)
(require 'list-buffer)
(defvar igs-ignore-shouts t
"Ignore shouts on the IGS server.")
(defvar igs-telnet-command "telnet"
"Telnet command used by igs.")
(defvar igs-server "igs.joyjoy.net"
"Address of the IGS server.")
(defvar igs-port 6969
"Port to use when connecting to an IGS server.")
(defvar igs-username "guest"
"User name to use when connecting to an IGS server.")
(defvar igs-process-name "igs"
"Name for the igs process.")
(defvar igs-server-ping-delay 300
"Minimum time between pings to remind the IGS server we're still listening.")
(defvar igs-message-types
'((:unknown . 0)
(:automat . 35) ;; Automatch announcement
(:autoask . 36) ;; Automatch accept
(:choices . 38) ;; game choices
(:clivrfy . 41) ;; Client verify message
(:beep . 2) ;; \7 telnet
(:board . 3) ;; Board being drawn
(:down . 4) ;; The server is going down
(:error . 5) ;; An error reported
(:fil . 6) ;; File being sent
(:games . 7) ;; Games listing
(:help . 8) ;; Help file
(:info . 9) ;; Generic info
(:last . 10) ;; Last command
(:kibitz . 11) ;; Kibitz strings
(:load . 12) ;; Loading a game
(:look_m . 13) ;; Look
(:message . 14) ;; Message listing
(:move . 15) ;; Move #:(B) A1
(:observe . 16) ;; Observe report
(:prompt . 1) ;; A Prompt (never)
(:refresh . 17) ;; Refresh of a board
(:saved . 18) ;; Stored command
(:say . 19) ;; Say string
(:score_m . 20) ;; Score report
(:sgf_m . 34) ;; SGF variation
(:shout . 21) ;; Shout string
(:show . 29) ;; Shout string
(:status . 22) ;; Current Game status
(:stored . 23) ;; Stored games
(:teach . 33) ;; teaching game
(:tell . 24) ;; Tell string
(:dot . 40) ;; your . string
(:thist . 25) ;; Thist report
(:tim . 26) ;; times command
(:trans . 30) ;; Translation info
(:ttt_board . 37) ;; tic tac toe
(:who . 27) ;; who command
(:undo . 28) ;; Undo report
(:user . 42) ;; Long user report
(:version . 39) ;; IGS Version
(:yell . 32))) ;; Channel yelling
(defvar *igs-instance* nil
"IGS instance associated with the current buffer.")
(defvar *igs-time-last-sent* nil
"Time stamp of the last command sent.
This is used to re-send messages to keep the IGS server from timing out.")
(defvar *igs-last-command* nil
"Last command sent to the IGS process.")
(defvar *igs-games* nil
"List holding the current games on the IGS server.")
(defvar *igs-current-game* nil
"Number of the current IGS game (may change frequently).")
;;; Class and interface
(defclass igs ()
((buffer :initarg :buffer :accessor buffer :initform nil)
;; number of an observed IGS game
(number :initarg :number :accessor number :initform nil)
(active :initarg :active :accessor active :initform t)))
(defmethod go-connect ((igs igs)) (igs-connect igs))
(defmacro with-igs (igs &rest body)
(declare (indent 1))
`(with-current-buffer (buffer ,igs) ,@body))
(defmethod go-level ((igs igs))
(signal 'unsupported-back-end-command (list igs :level)))
(defmethod set-go-level ((igs igs) level)
(signal 'unsupported-back-end-command (list igs :set-level level)))
(defmethod go-size ((igs igs))
(with-igs igs (aget (igs-current-game) :size)))
(defmethod set-go-size ((igs igs) size)
(signal 'unsupported-back-end-command (list igs :set-size size)))
(defmethod go-name ((igs igs))
(with-igs igs (let ((game (igs-current-game)))
(format "%s(%s) vs %s(%s)"
(aget game :white-name)
(aget game :white-rank)
(aget game :black-name)
(aget game :black-rank)))))
(defmethod set-go-name ((igs igs) name)
(signal 'unsupported-back-end-command (list igs :set-name name)))
(defmethod go-move ((igs igs))
(signal 'unsupported-back-end-command (list igs :move)))
(defmethod set-go-move ((igs igs) move)
(signal 'unsupported-back-end-command (list igs :set-move move)))
(defmethod go-labels ((igs igs))
(signal 'unsupported-back-end-command (list igs :labels)))
(defmethod set-go-labels ((igs igs) labels)
(signal 'unsupported-back-end-command (list igs :set-labels labels)))
(defmethod go-comment ((igs igs))
(signal 'unsupported-back-end-command (list igs :comment)))
(defmethod set-go-comment ((igs igs) comment)
(signal 'unsupported-back-end-command (list igs :set-comment comment)))
(defmethod go-alt ((igs igs))
(signal 'unsupported-back-end-command (list igs :alt)))
(defmethod set-go-alt ((igs igs) alt)
(signal 'unsupported-back-end-command (list igs :set-alt alt)))
(defmethod go-color ((igs igs))
(signal 'unsupported-back-end-command (list igs :color)))
(defmethod set-go-color ((igs igs) color)
(signal 'unsupported-back-end-command (list igs :set-color color)))
(defmethod go-player-name ((igs igs) color)
(with-igs igs (aget (igs-current-game)
(case color
(:W :white-name)
(:B :black-name)))))
(defmethod set-go-player-name ((igs igs) color name)
(signal 'unsupported-back-end-command (list igs :set-player-name color name)))
(defmethod go-player-time ((igs igs) color)
(signal 'unsupported-back-end-command (list igs :player-time color)))
(defmethod set-go-player-time ((igs igs) color time)
(signal 'unsupported-back-end-command (list igs :set-player-time color time)))
;; non setf'able generic functions
(defmethod go-undo ((igs igs))
(signal 'unsupported-back-end-command (list igs :undo)))
(defmethod go-pass ((igs igs))
(signal 'unsupported-back-end-command (list igs :pass)))
(defmethod go-resign ((igs igs))
(signal 'unsupported-back-end-command (list igs :resign)))
(defmethod go-reset ((igs igs))
(signal 'unsupported-back-end-command (list igs :reset)))
(defmethod go-quit ((igs igs))
(with-igs igs
(if (number igs)
(progn
;; TOOD: ensure still on our server-side observation list
;; (e.g., hasn't been removed after a resignation)
(when (active igs)
(igs-send (format "observe %d" (number igs))))
(setf (number igs) nil))
(igs-send "quit"))))
(defmethod go-score ((igs igs))
(signal 'unsupported-back-end-command (list igs :score)))
(defmethod go-territory ((igs igs))
(signal 'unsupported-back-end-command (list igs :territory)))
(defmethod go-dead ((igs igs))
(signal 'unsupported-back-end-command (list igs :dead)))
(defmacro igs-w-proc (proc &rest body)
(declare (indent 1))
`(with-current-buffer (process-buffer proc) ,@body))
(def-edebug-spec igs-w-proc (form body))
(defun igs-send (command)
"Send string COMMAND to the IGS process in the current buffer."
(goto-char (process-mark (get-buffer-process (current-buffer))))
(insert command)
(setq *igs-time-last-sent* (current-time))
(setq *igs-last-command* (and (string-match "^\\([^ ]*\\)" command)
(match-string 1 command)))
(comint-send-input))
(defun igs-process-filter (proc string)
(when (string-match "^\\([[:digit:]]+\\) \\(.+\\)$" string)
(let* ((number (read (match-string 1 string)))
(type (car (rassoc number igs-message-types)))
(content (match-string 2 string)))
(case type
(:prompt
(go-re-cond (or *igs-last-command* "")
("^games" (igs-list-games *igs-instance* *igs-games*))
(t nil))
(setq *igs-last-command* nil))
(:info
(go-re-cond content
;; Game NN: name1 vs name2 has adjourned.
("^Game \\([0-9]*\\): .*adjourned.$"
(igs-handle-adjournment (match-string 1 content)))
;; {Game NN: name1 vs name2 : color resigns.}
("^{Game \\([0-9]*\\): \\(Black\\|White\\) resigns.}$"
(igs-handle-resignation (go-re-cond (match-string 2 content)
("black" :black)
("white" :white))))
(t (unless (string= content "yes")
(message "igs-info: %s" content)))))
(:games (igs-w-proc proc (igs-handle-game content)))
(:move (igs-w-proc proc (igs-handle-move content)))
(:kibitz (message "igs-kibitz: %s" content))
(:tell (igs-handle-tell content))
(:beep nil)
(:shout (unless igs-ignore-shouts (igs-handle-shout content)))
(t (message "igs-unknown: [%s]%s" type content)))
(when (and *igs-time-last-sent*
(> (time-to-seconds (time-since *igs-time-last-sent*))
igs-server-ping-delay))
(igs-send "ayt")))))
(defun igs-connect (igs)
"Open a connection to `igs-server'."
(cl-flet ((wait (prompt)
(message "IGS waiting for %S..." prompt)
(while (and (goto-char (or comint-last-input-end (point-min)))
(not (re-search-forward prompt nil t)))
(accept-process-output proc))))
(let ((buffer (apply 'make-comint
igs-process-name
igs-telnet-command nil
(list igs-server (number-to-string igs-port)))))
(setf (buffer igs) buffer)
(with-current-buffer buffer
(comint-mode)
(set (make-local-variable '*igs-instance*) igs)
(set (make-local-variable '*igs-last-command*) "")
(set (make-local-variable '*igs-games*) nil)
(set (make-local-variable '*igs-current-game*) nil)
(set (make-local-variable '*go-partial-line*) nil)
(set (make-local-variable '*igs-time-last-sent*) (current-time))
(let ((proc (get-buffer-process (current-buffer))))
(wait "^Login:")
(goto-char (process-mark proc))
(igs-send igs-username)
(wait "^\#> ")
(igs-toggle "client" t)
(set-process-filter
proc (make-go-insertion-filter #'igs-process-filter))))
buffer)))
(defun igs-toggle (setting value)
(igs-send (format "toggle %s %s" setting (if value "true" "false"))))
(defun igs-observe (game) (igs-send (format "observe %s" game)))
(defun igs-list-games (instance games)
(lexical-let ((instance instance))
(list-buffer-create
"*igs-game-list*"
(cl-mapcar #'cons
(mapcar #'car games)
(mapcar (curry #'mapcar #'cdr) (mapcar #'cdr games)))
'("#" "white" "rk" "black" "rk" "move" "size" "H" "Komi" "by" "fr" "#")
(lambda (row col)
(let ((id (car (nth row *buffer-list*))))
(with-igs instance (igs-observe id))))
(lambda (row col)
(message "refreshing games list...")
(igs-get-games instance)))))
;;; Specific handlers
(defvar igs-player-name-re
"[[:alpha:][:digit:]]+"
"Regular expression used to match igs player name.")
(defvar igs-player-rating-re
"[[:digit:]]+[kd]\\*?"
"Regular expression used to match igs player rating.")
(defvar igs-player-game-info-re "([-[:digit:]]+ [-[:digit:]]+ [-[:digit:]]+)"
"Regular expression used to match igs player game info.")
(defvar igs-player-re
(format "\\(%s\\) +\\[ *\\(%s\\)\\]" igs-player-name-re igs-player-rating-re)
"Regular expression used to parse igs player name and rating.")
(defvar igs-game-re
(format
"\\[\\([[:digit:]]+\\)\\] +%s +vs. +%s +\\((.+)\\) \\((.+)\\)[[:space:]]*$"
igs-player-re igs-player-re)
"Regular expression used to parse igs game listings.")
(defvar igs-move-piece-re
"[[:digit:]]+(\\([WB]\\)): \\([[:alpha:]][[:digit:]]+\\)"
"Regular expression used to match an IGS move.")
(defvar igs-move-time-re "TIME")
(defvar igs-move-props-re "GAMEPROPS")
(defvar igs-move-game-re
(format "Game \\([[:digit:]]+\\) I: \\(%s\\) \\(%s\\) vs \\(%s\\) \\(%s\\)"
igs-player-name-re igs-player-game-info-re
igs-player-name-re igs-player-game-info-re)
"Regular expression used to match Game updates.")
(defun igs-handle-game (game-string)
;; [##] white name [ rk ] black name [ rk ] (Move size H Komi BY FR) (###)
(when (string-match igs-game-re game-string)
(let* ((num (match-string 1 game-string))
(white-name (match-string 2 game-string))
(white-rank (match-string 3 game-string))
(black-name (match-string 4 game-string))
(black-rank (match-string 5 game-string))
(other1 (read (match-string 6 game-string)))
(other2 (read (match-string 7 game-string))))
(push `(,(read num)
(:white-name . ,white-name)
(:white-rank . ,white-rank)
(:black-name . ,black-name)
(:black-rank . ,black-rank)
(:move . ,(nth 0 other1))
(:size . ,(nth 1 other1))
(:h . ,(nth 2 other1))
(:komi . ,(nth 3 other1))
(:by . ,(nth 4 other1))
(:fr . ,(nth 5 other1))
(:other . ,(car other2)))
*igs-games*)
;; update the game list buffer
(when (get-buffer "*igs-game-list*")
(save-excursion
(set-buffer (get-buffer "*igs-game-list*"))
(list-buffer-refresh))))))
(defun igs-handle-adjournment (number-string)
(if (aget (igs-current-game) :board)
(with-current-buffer (buffer (aget (igs-current-game) :board))
(with-backends backend
(when (equal (class-of backend) 'igs)
(setf (active backend) nil))))
(error "igs-handle-adjournment: no board!")))
(defun igs-handle-resignation (color)
(if (aget (igs-current-game) :board)
(progn
(go-resign (aget (igs-current-game) :board))
(with-current-buffer (buffer (aget (igs-current-game) :board))
(with-backends backend
(when (equal (class-of backend) 'igs)
(setf (active backend) nil)))))
(error "igs-handle-adjournment: no board!")))
(defun igs-to-pos (color igs)
(cons (make-keyword color)
(cons :pos
(cons (char-to-num (aref igs 0))
(1- (read (substring igs 1)))))))
(defun igs-current-game ()
(aget *igs-games* *igs-current-game*))
(defun set-igs-current-game (new)
(setf (aget *igs-games* *igs-current-game*) new))
(defsetf igs-current-game set-igs-current-game)
(defun igs-handle-tell (string)
(unless (string-match (format "\\*\\(%s\\)\\*: \\(.*\\)$" igs-player-name-re)
string)
(error "igs: malformed tell string %S" string))
;; TODO: keep a message buffer for each user in which conversations
;; may be saved... during games store messages as SGF comments.
(message "igs[%s]: %s" (match-string 1 string) (match-string 2 string)))
(defun igs-handle-shout (string)
(unless (string-match "^\\([^:]*\\): \\(.*\\)$" string)
(error "igs: malformed shout string %S" string))
(message "IGS[%s]: %s" (match-string 1 string) (match-string 2 string)))
(defun igs-apply-move (move)
(if (aget (igs-current-game) :board)
(setf (go-move (aget (igs-current-game) :board)) move)
(message "igs-apply-move: no board!")))
(defun igs-register-game (number)
(setq *igs-current-game* number)
(unless (aget (igs-current-game) :board)
(setf (aget (igs-current-game) :board)
(save-excursion
(setf (number *igs-instance*) number)
(make-instance 'board
:buffer (go-board *igs-instance*
(make-instance 'sgf)))))
(when (aget (igs-current-game) :board)
(igs-send (format "moves %s" number)))))
(defun igs-update-game-info (info)
(let ((color (car info))
(name (cadr info))
(other (cddr info)))
;; (message "[%s] %s: %s" color name other)
))
(defun igs-handle-move (move-string)
(go-re-cond move-string
(igs-move-piece-re (igs-apply-move
(igs-to-pos (match-string 1 move-string)
(match-string 2 move-string))))
(igs-move-time-re nil)
(igs-move-props-re nil)
(igs-move-game-re
(let ((number (read (match-string 1 move-string)))
(white-info (cons (match-string 2 move-string)
(read (match-string 3 move-string))))
(black-info (cons (match-string 4 move-string)
(read (match-string 5 move-string)))))
(igs-register-game number)
(igs-update-game-info (cons :W white-info))
(igs-update-game-info (cons :B black-info))))))
;;; Interface
;;
;; If we find another backend providing game lists and observations
;; then this could be generalized to an interface.
(defun igs-start (&optional name)
"Connect to an IGS server and return the `igs' instance."
(interactive)
(set-buffer (get-buffer-create (or name "*igs*")))
(if (get-buffer-process (current-buffer))
*igs-instance*
(let ((*igs* (make-instance 'igs)))
(igs-connect *igs*)
*igs*)))
(defun igs-get-games (&optional instance)
"List the games of the igs instance."
(interactive)
(set-buffer (buffer (or instance (igs-start))))
(setf *igs-games* nil)
(igs-send "games"))
(provide 'igs)
;;; igs.el ends here