gergely/my-emacs-d
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Add new packages

Browse Source
This commit is contained in:
Gergely Polonkai
2016-09-15 13:54:46 +02:00
parent 697f492aba
commit b4f2fb14c0
86 changed files with 21872 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

122
elpa/go-20160430.1739/back-ends/gtp-pipe.el Normal file
View File

@@ -0,0 +1,122 @@
;;; gtp-pipe.el --- GTP backend through a pipe
;; Copyright (C) 2013 Free Software Foundation, Inc.
;; Author: Eric Schulte <schulte.eric@gmail.com>
;; Created: 2012-05-15
;; Version: 0.1
;; Keywords: game go sgf
;; 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/>.
;;; Code:
(require 'go-api)
(require 'gtp)
(require 'comint)
(defvar *gtp-pipe-board* nil
"Board associated with the current gtp pipe process.")
(defvar *gtp-pipe-last* nil
"Last move of the current game.")
(defvar *gtp-pipe-inhibit* nil
"Prevent infinite loops of commands.")
(defun gtp-pipe-start (command)
"Connect a `gtp-pipe' instance to the process created by COMMAND.
Pass \"netcat -lp 6666\" as COMMAND to listen on a local port, or
pass \"netcat localhost 6666\" to connect to a listening local
port."
(interactive "sgtp-pipe command: ")
(pop-to-buffer (go-connect (make-instance 'gtp-pipe :command command))))
(defun gtp-pipe-process-filter (proc string)
(go-re-cond string
("^\\(black\\|white\\) \\(.*\\)$"
(let ((color (go-re-cond (match-string 1 string)
("black" :B)
("white" :W)))
(action (match-string 2 string)))
(go-re-cond action
("^pass" (let ((*gtp-pipe-inhibit* t)) (go-pass *gtp-pipe-board*)))
("^resign" (let ((*gtp-pipe-inhibit* t)) (go-resign *gtp-pipe-board*)))
(t (let ((move (gtp-to-pos color action)))
(setf *gtp-pipe-last* move)
(setf (go-move *gtp-pipe-board*) move))))))
("^genmove_\\(black\\|white\\)"
(message "gtp-pipe: %s's turn" (match-string 1 string)))
("^last_move" (go-to-gtp-command *gtp-pipe-last*))
("^quit" (let ((*gtp-pipe-inhibit* t)) (go-quit *gtp-pipe-board*)))
("^undo" (let ((*gtp-pipe-inhibit* t)) (go-undo *gtp-pipe-board*)))
("^string \\(.*\\)$" (message "gtp-pipe: %S" (match-string 1 string)))
(t (message "gtp-pipe unknown command: %S" string))))
;;; Class and interface
(defclass gtp-pipe (gtp)
((buffer :initarg :buffer :accessor buffer)
(command :initarg :command :accessor command)))
(defmethod go-connect ((gtp-pipe gtp-pipe))
(setf (buffer gtp-pipe)
(let* ((cmd-&-args (split-string (command gtp-pipe) " " 'omit-nulls))
(buf (apply #'make-comint "gtp-pipe"
(car cmd-&-args) nil (cdr cmd-&-args))))
(with-current-buffer buf
(comint-mode)
(set (make-local-variable '*gtp-pipe-last*) nil)
(set (make-local-variable '*gtp-pipe-inhibit*) nil)
(set (make-local-variable '*gtp-pipe-board*)
(save-excursion
(make-instance 'board
:buffer (go-board gtp-pipe (make-instance 'sgf)))))
(set-process-filter (get-buffer-process (current-buffer))
(make-go-insertion-filter
#'gtp-pipe-process-filter)))
buf)))
(defmethod gtp-command ((gtp-pipe gtp-pipe) command)
(with-current-buffer (buffer gtp-pipe)
(unless *gtp-pipe-inhibit*
(goto-char (process-mark (get-buffer-process (current-buffer))))
(insert command)
(comint-send-input))))
(defmethod go-comment ((gtp-pipe gtp-pipe))
(signal 'unsupported-back-end-command (list gtp-pipe :comment)))
(defmethod set-go-comment ((gtp-pipe gtp-pipe) comment)
(gtp-command gtp-pipe (format "string %s" comment)))
(defmethod go-color ((gtp-pipe gtp-pipe))
(with-current-buffer (buffer gtp-pipe)
(go-color *gtp-pipe-board*)))
(defmethod go-name ((gtp-pipe gtp-pipe)) "GTP pipe")
(defmethod go-size ((gtp-pipe gtp-pipe))
(read-from-minibuffer "GTP board size: " nil nil 'read))
(defmethod go-quit ((gtp-pipe gtp-pipe))
(gtp-command gtp-pipe "quit")
(with-current-buffer (buffer gtp-pipe)
(signal-process (get-buffer-process) 'KILL)))
(defmethod go-player-name ((gtp-pipe gtp-pipe) color) "GTP pipe")
(defmethod set-player-name ((gtp-pipe gtp-pipe) color name)
(signal 'unsupported-back-end-command (list gtp-pipe :set-player-name name)))
(provide 'gtp-pipe)
;;; gtp-pipe.el ends here

164
elpa/go-20160430.1739/back-ends/gtp.el Normal file
View File

@@ -0,0 +1,164 @@
;;; gtp.el --- GTP GO back-end
;; Copyright (C) 2008 2012 Free Software Foundation, Inc.
;; Author: Eric Schulte <schulte.eric@gmail.com>
;; Created: 2012-05-15
;; Version: 0.1
;; Keywords: game go sgf gtp gnugo
;; 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:
;; This file should be useful for translating between sgf and the GO
;; text protocol (GTP) see http://www.lysator.liu.se/~gunnar/gtp/.
;; The GMP command set may be implemented as an extension.
;;
;; see http://www.lysator.liu.se/~gunnar/gtp/gtp2-spec-draft2/gtp2-spec.html
;;
;; The following commands are required by GTP
;; - protocol_version
;; - name
;; - version
;; - known_command
;; - list_commands
;; - quit
;; - boardsize
;; - clear_board
;; - komi
;; - play
;; - genmove
;; Code:
(require 'go-api)
(defun gtp-expand-color (turn)
(case turn
(:B "black")
(:W "white")
(t (error "gtp: unknown turn %S" turn))))
(defun go-pos-to-gtp (pos)
(format "%c%d" (num-to-char (1+ (car pos))) (1+ (cdr pos))))
(defun gtp-to-pos (color gtp)
(cons color (cons :pos (cons (char-to-num (aref gtp 0))
(1- (read (substring gtp 1)))))))
(defun go-to-gtp-command (element)
"Convert an go ELEMENT to a gtp command."
(let ((key (car element))
(val (cdr element)))
(case key
(:B (format "black %s" (go-pos-to-gtp (aget (list val) :pos))))
(:W (format "white %s" (go-pos-to-gtp (aget (list val) :pos))))
((:SZ :S) (format "boardsize %s" val))
(:KM (format "komi %s" val))
(t nil))))
(defun gtp-territory (gtp color)
(let ((output (ecase color
(:B (gtp-command gtp "final_status_list black_territory"))
(:W (gtp-command gtp "final_status_list white_territory")))))
(mapcar (lambda (gtp-point) (gtp-to-pos color gtp-point))
(mapcar #'symbol-name
(read (format "(%s)" output))))))
;;; Class and interface
(defclass gtp nil nil "Class for the GTP GO GO back end.")
(defgeneric gtp-command (back-end command)
"Send gtp COMMAND to OBJECT and return any output.")
(defmethod go-size ((gtp gtp))
(read (gtp-command gtp "query_boardsize")))
(defmethod set-go-size ((gtp gtp) size)
(gtp-command gtp (format "boardsize %d" size)))
(defmethod go-level ((gtp gtp))
(signal 'unsupported-back-end-command (list gtp :go-level)))
(defmethod set-go-level ((gtp gtp) level)
(gtp-command gtp (format "level %d" level)))
(defmethod go-name ((gtp gtp))
(gtp-command gtp "name"))
(defmethod set-go-name ((gtp gtp) name)
(signal 'unsupported-back-end-command (list gtp :set-name name)))
(defmethod go-move ((gtp gtp))
(let* ((color (go-color gtp))
(move (case color
(:B (gtp-command gtp "genmove_black"))
(:W (gtp-command gtp "genmove_white")))))
(if (string= move "PASS")
:pass
(gtp-to-pos color move))))
(defmethod set-go-move ((gtp gtp) move)
(gtp-command gtp (go-to-gtp-command move)))
(defmethod go-labels ((gtp gtp))
(signal 'unsupported-back-end-command (list gtp :labels)))
(defmethod set-go-labels ((gtp gtp) labels)
(signal 'unsupported-back-end-command (list gtp :set-labels labels)))
(defmethod go-comment ((gtp gtp))
(signal 'unsupported-back-end-command (list gtp :comment)))
(defmethod set-go-comment ((gtp gtp) comment)
(signal 'unsupported-back-end-command (list gtp :set-comment comment)))
(defmethod go-alt ((gtp gtp))
(signal 'unsupported-back-end-command (list gtp :alt)))
(defmethod set-go-alt ((gtp gtp) alt)
(signal 'unsupported-back-end-command (list gtp :set-alt alt)))
(defmethod go-color ((gtp gtp))
(case (condition-case err
(intern (car (split-string (gtp-command gtp "last_move"))))
(error 'white)) ('white :B) ('black :W)))
(defmethod set-go-color ((gtp gtp) color)
(signal 'unsupported-back-end-command (list gtp :set-color color)))
;; non setf'able generic functions
(defmethod go-undo ((gtp gtp)) (gtp-command gtp "undo"))
(defmethod go-pass ((gtp gtp))
(gtp-command gtp (format "%s pass" (gtp-expand-color (go-color gtp)))))
(defmethod go-resign ((gtp gtp))
(gtp-command gtp (format "%s resign" (gtp-expand-color (go-color gtp)))))
(defmethod go-reset ((gtp gtp)) (gtp-command gtp "clear_board"))
(defmethod go-quit ((gtp gtp)) (gtp-command gtp "quit"))
(defmethod go-score ((gtp gtp)) (gtp-command gtp "final_score"))
(defmethod go-territory ((gtp gtp))
(append (gtp-territory gtp :B) (gtp-territory gtp :W)))
(defmethod go-dead ((gtp gtp))
(signal 'unsupported-back-end-command (list gtp :dead)))
(provide 'gtp)
;;; gtp.el ends here

501
elpa/go-20160430.1739/back-ends/igs.el Normal file
View File

@@ -0,0 +1,501 @@
;;; 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

196
elpa/go-20160430.1739/back-ends/sgf.el Normal file
View File

@@ -0,0 +1,196 @@
;;; sgf.el --- SGF GO back end
;; Copyright (C) 2012 Free Software Foundation, Inc.
;; Author: Eric Schulte <schulte.eric@gmail.com>
;; Created: 2012-05-15
;; Version: 0.1
;; Keywords: game go sgf
;; 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:
;; This file implements an `go-trans' interface into an SGF file.
;; Code:
(require 'go-api)
(defun sgf-nthcdr (sgf index)
(let ((part sgf))
(while (cdr index)
(setq part (nth (car index) part))
(setq index (cdr index)))
(setq part (nthcdr (car index) part))
part))
(defun sgf-ref (sgf index)
(let ((part sgf))
(while (car index)
(setq part (nth (car index) part))
(setq index (cdr index)))
part))
(defun set-sgf-ref (sgf index new)
(eval `(setf ,(reduce (lambda (acc el) (list 'nth el acc))
index :initial-value 'sgf)
',new)))
(defsetf sgf-ref set-sgf-ref)
;;; Class
(defclass sgf nil
((self :initarg :self :accessor self :initform nil)
(index :initarg :index :accessor index :initform (list 0)))
"Class for the SGF back end.")
(defun sgf-from-file (file)
(interactive "f")
(make-instance 'sgf :self (sgf2el-file-to-el file)))
(defun sgf-to-file (sgf file)
(interactive "F")
(when (and (file-exists-p file)
(not (y-or-n-p (format "overwrite %s? " file))))
(error "aborted"))
(with-temp-file file
(delete-region (point-min) (point-max))
(insert (pp (self sgf)))))
(defmethod current ((sgf sgf))
(sgf-ref (self sgf) (index sgf)))
(defun set-current (sgf new)
(setf (sgf-ref (self sgf) (index sgf)) new))
(defsetf current set-current)
(defmethod root ((sgf sgf))
(sgf-ref (self sgf) '(0)))
(defun set-root (sgf new)
(if (self sgf)
(setf (car (self sgf)) new)
(setf (self sgf) (list new))))
(defsetf root set-root)
(defmethod next ((sgf sgf))
(incf (car (last (index sgf)))))
(defmethod prev ((sgf sgf))
(decf (car (last (index sgf)))))
;;; interface
(defmethod go-size ((sgf sgf))
(or (aget (root sgf) :S)
(aget (root sgf) :SZ)))
(defmethod set-go-size ((sgf sgf) size)
(cond
((aget (root sgf) :S) (setf (cdr (assoc :S (root sgf))) size))
((aget (root sgf) :SZ) (setf (cdr (assoc :SZ (root sgf))) size))
(t (push (cons :S size) (root sgf)))))
(defmethod go-level ((sgf sgf))
(signal 'unsupported-back-end-command (list sgf :go-level)))
(defmethod set-go-level ((sgf sgf) level)
(signal 'unsupported-back-end-command (list sgf :set-go-level level)))
(defmethod go-name ((sgf sgf))
(or (aget (root sgf) :GN)
(aget (root sgf) :EV)))
(defmethod set-go-name ((sgf sgf) name)
(cond
((aget (root sgf) :GN) (setf (cdr (assoc :GN (root sgf))) name))
((aget (root sgf) :EV) (setf (cdr (assoc :EV (root sgf))) name))
(t (push (cons :GN name) (root sgf)))))
(defmethod go-move ((sgf sgf))
(next sgf)
(let ((turn (current sgf)))
(if turn
(or (assoc :B turn) (assoc :W turn))
(prev sgf)
(error "sgf: no more moves"))))
;; TODO: currently this only works with linear sgf files w/o alternatives
(defmethod set-go-move ((sgf sgf) move)
(next sgf)
(if (current sgf)
(setf (current sgf) (list move))
(setf (self sgf) (rcons (list move) (self sgf)))))
(defmethod go-labels ((sgf sgf))
(let ((turn (current sgf)))
(if turn
(remove-if-not (lambda (pair) (member (car pair) '(:LB :LW))) turn)
(prev sgf)
(error "sgf: no more moves"))))
(defmethod set-go-lables ((sgf sgf) labels)
(if (current sgf)
(setf (current sgf) (cons (or (assoc :B (current sgf))
(assoc :W (current sgf)))
labels))
(rpush labels (sgf-ref (self sgf) (butlast (index sgf))))))
(defmethod go-comment ((sgf sgf))
(aget (current sgf) :C))
(defmethod set-go-comment ((sgf sgf) comment)
(if (aget (current sgf) :C)
(setf (cdr (assoc :C (current sgf))) comment)
(push (cons :C comment) (current sgf))))
(defmethod go-alt ((sgf sgf))
(error "sgf: go-alt not yet supported"))
(defmethod set-go-alt ((sgf sgf) alt)
(error "sgf: set-go-alt not yet supported"))
(defmethod go-color ((sgf sgf))
(signal 'unsupported-back-end-command (list sgf :move)))
(defmethod set-go-color ((sgf sgf) color)
(signal 'unsupported-back-end-command (list sgf :set-color color)))
;; non setf'able generic functions
(defmethod go-undo ((sgf sgf)) (prev sgf))
(defmethod go-pass ((sgf sgf))
(signal 'unsupported-back-end-command (list sgf :pass)))
(defmethod go-resign ((sgf sgf))
(signal 'unsupported-back-end-command (list sgf :resign)))
(defmethod go-quit ((sgf sgf))
(when (y-or-n-p "Save game to file: ")
(sgf-to-file sgf (read-file-name "Save game to: "))))
(defmethod go-score ((sgf sgf))
(signal 'unsupported-back-end-command (list sgf :score)))
(defmethod go-territory ((sgf sgf))
(signal 'unsupported-back-end-command (list sgf :territory)))
(defmethod go-dead ((sgf sgf))
(signal 'unsupported-back-end-command (list sgf :dead)))
(provide 'sgf)
;;; sgf.el ends here

188
elpa/go-20160430.1739/back-ends/sgf2el.el Normal file
View File

@@ -0,0 +1,188 @@
;;; sgf2el.el --- conversion between sgf and emacs-lisp
;; Copyright (C) 2012 Free Software Foundation, Inc.
;; Author: Eric Schulte <schulte.eric@gmail.com>
;; Created: 2012-05-15
;; Version: 0.1
;; Keywords: game go sgf
;; 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/>.
;;; Code:
(require 'go-util)
(defvar prop-re
"\\([[:alpha:]]+\\)\\(\\(\\[\\]\\|[[:space:]]*\\[[^\000]*?[^\\]\\]\\)+\\)")
(defvar prop-val-re
"\\(\\[\\]\\|\\[\\([^\000]*?[^\\]\\)\\]\\)")
(defvar sgf2el-special-properties nil
"A-list of properties and functions to specially convert their values.")
(defun make-keyword (string)
(intern (concat ":" (upcase string))))
(defun sgf2el-convert-prop-key (key)
"Convert a keyerty name to elisp."
(save-match-data (make-keyword key)))
(defun sgf2el-read-prop (val)
(when (and (stringp val) (not (equal val "")))
(or (go-number-p val) val)))
(defun sgf2el-convert-prop-vals (key vals)
"Convert a property value to elisp."
(save-match-data
(let ((func (cdr (assoc key sgf2el-special-properties))))
(if func
(funcall func vals)
(delete nil (mapcar #'sgf2el-read-prop vals))))))
(defun sgf2el-all-matches (str re &optional sub-exp)
(save-match-data
(with-temp-buffer
(insert str)
(goto-char (point-min))
(loop while (re-search-forward re nil t)
collect (go-clean-text-properties
(match-string (or sub-exp 0)))))))
(defun sgf2el-region (&optional start end)
(interactive "r")
(let ((start (copy-marker (or start (point-min))))
(end (copy-marker (or end (point-max))))
(re (format "\\(%s\\|%s\\)" prop-re "\\(([[:space:]]*\\)*\\(;\\)"))
last-node)
(save-excursion (goto-char start)
(while (re-search-forward re end t)
(let ((start (marker-position start)))
(message "parsing %.2f%%"
(* 100 (/ (float (- (point) start))
(float (- (marker-position end) start))))))
(if (string= (match-string 6) ";")
(progn
(replace-match "(" nil nil nil 6)
(when last-node
(save-excursion (goto-char (match-beginning 0)) (insert ")")))
(setq last-node t))
(let* ((key (sgf2el-convert-prop-key (match-string 2)))
(val (sgf2el-convert-prop-vals key
(sgf2el-all-matches (match-string 3) prop-val-re 2)))
(rep (format "%S " (cons key (if (= 1 (length val))
(car val) val)))))
(replace-match rep nil 'literal))))
(when last-node (insert ")")))
(message "parsing DONE")))
(defun sgf2el-normalize (&optional buffer)
"Cleanup the formatting of the elisp sgf data in BUFFER."
(interactive)
(let ((buffer (or buffer (current-buffer))) temp)
(sgf2el-set-to-var temp buffer)
(with-current-buffer buffer
(save-excursion
(delete-region (point-min) (point-max))
(insert (pp temp))))
temp))
(defun sgf2el (&optional sgf-buffer)
"Convert the content of SGF-BUFFER to emacs-lisp in a new buffer."
(interactive)
(let* ((sgf-buffer (or sgf-buffer (current-buffer)))
(buffer (generate-new-buffer (concat (buffer-name sgf-buffer) "-el")))
(sgf-str (with-current-buffer sgf-buffer (buffer-string))))
(with-current-buffer buffer
(insert sgf-str)
(goto-char (point-min))
(sgf2el-region)
(emacs-lisp-mode))
(pop-to-buffer buffer)))
(defun sgf2el-read (&optional buf)
(with-current-buffer (or buf (current-buffer))
(goto-char (point-min))
(read (current-buffer))))
(defun sgf2el-buffer-to-el (&optional bufffer)
"Convert the sgf contents of BUFFER to emacs lisp."
(interactive "b")
(with-current-buffer (or bufffer (current-buffer))
(sgf2el-region (point-min) (point-max))
(sgf2el-read)))
(defun sgf2el-str-to-el (str)
"Convert a string of sgf into the equivalent Emacs Lisp."
(interactive)
(with-temp-buffer (insert str) (sgf2el-buffer-to-el)))
(defun sgf2el-file-to-el (file)
"Convert the sgf contents of FILE to emacs lisp."
(interactive "f")
(with-temp-buffer
(insert-file-contents-literally file)
(sgf2el-buffer-to-el)))
;;; Specific property converters
(defun process-date (date-args)
(save-match-data (parse-time-string
(if (> 1 (length date-args))
(mapconcat #'number-to-string date-args " ")
(car date-args)))))
(add-to-list 'sgf2el-special-properties (cons :DT #'process-date))
(defun process-position (position-string)
(cl-flet ((char-to-num (char)
(cond
((or (< char ?A) (< ?z char))
(error "sgf: invalid char %s" char))
((< char ?a) (+ 26 (- char ?A)))
(t (- char ?a)))))
(cons (char-to-num (aref position-string 0))
(char-to-num (aref position-string 1)))))
(defun process-move (move-args)
(list (cons :pos (process-position (car move-args)))))
(add-to-list 'sgf2el-special-properties (cons :B #'process-move))
(add-to-list 'sgf2el-special-properties (cons :W #'process-move))
(defun process-label (label-args)
(let ((res (mapcar (lambda (l-arg)
(if (string-match "\\([[:alpha:]]+\\):\\(.*\\)" l-arg)
(list
(cons :label (match-string 2 l-arg))
(cons :pos (process-position
(match-string 1 l-arg))))
(error "sgf: malformed label %S" l-arg)))
label-args)))
(if (= 1 (length label-args)) (list res) res)))
(add-to-list 'sgf2el-special-properties (cons :LB #'process-label))
(add-to-list 'sgf2el-special-properties (cons :LW #'process-label))
(defun process-comment (comments)
(let ((replacements '(("\\(" . "(")
("\\)" . ")")
("\\[" . "[")
("\\]" . "]"))))
(mapcar (lambda (comment)
(dolist (pair replacements comment)
(setq comment (replace-regexp-in-string
(regexp-quote (car pair)) (cdr pair) comment))))
comments)))
(add-to-list 'sgf2el-special-properties (cons :C #'process-comment))
(provide 'sgf2el)
;;; sgf2el.el ends here