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

197 lines
5.6 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.

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