502 lines
18 KiB
EmacsLisp
502 lines
18 KiB
EmacsLisp
;;; 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
|