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

165 lines
5.1 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.

;;; 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