eschulte pushed a commit to branch go
in repository elpa.
commit 125f3f1a558064860810ed7893c3099fc1976edb
Author: Eric Schulte <eric.schu...@gmx.com>
Date: Sun May 27 10:55:15 2012 -0600
new setf'able generic interface
---
go-board.el | 24 +++++++++++---------
go-gtp.el | 68 ++++++++++++++++++++++++++++++++++++++++++++++------------
go-sgf.el | 22 +++++++-----------
go-tests.el | 2 +-
go-trans.el | 41 +++++++++++++++++++++++++----------
5 files changed, 106 insertions(+), 51 deletions(-)
diff --git a/go-board.el b/go-board.el
index 7ee4a93..cbfd99f 100644
--- a/go-board.el
+++ b/go-board.el
@@ -213,7 +213,7 @@
(board-to-string
(pieces-to-board (car *history*) *size*))
"\n\n")
- (let ((comment (go<-comment *back-end*)))
+ (let ((comment (ignoring-unsupported (go-comment *back-end*))))
(when comment
(insert (make-string (+ 6 (* 2 *size*)) ?=)
"\n\n"
@@ -225,14 +225,14 @@
(let ((buffer (generate-new-buffer "*GO*")))
(with-current-buffer buffer
(go-board-mode)
- (let ((name (go<-name back-end)))
+ (let ((name (go-name back-end)))
(when name
(rename-buffer (ear-muffs name) 'unique)
- (mapcar (lambda (tr) (go->name tr name)) trackers)))
+ (mapcar (lambda (tr) (go-name tr name)) trackers)))
(set (make-local-variable '*back-end*) back-end)
(set (make-local-variable '*turn*) :B)
- (set (make-local-variable '*size*) (go<-size back-end))
- (mapcar (lambda (tr) (go->size tr *size*)) trackers)
+ (set (make-local-variable '*size*) (go-size back-end))
+ (mapcar (lambda (tr) (go-size tr *size*)) trackers)
(set (make-local-variable '*history*)
(list (board-to-pieces (make-board *size*))))
(set (make-local-variable '*trackers*) trackers)
@@ -243,8 +243,9 @@
;;; User input
(defmacro with-backends (sym &rest body)
(declare (indent 1))
- `(prog1 (let ((,sym *back-end*)) ,@body)
- (mapcar (lambda (tr) (let ((,sym tr)) ,@body)) *trackers*)))
+ `(ignoring-unsupported
+ (prog1 (let ((,sym *back-end*)) ,@body)
+ (mapcar (lambda (tr) (let ((,sym tr)) ,@body)) *trackers*))))
(defvar go-board-actions '(move resign undo comment)
"List of actions which may be taken on an GO board.")
@@ -278,18 +279,18 @@
(range 1 *size*))))))))
(move (cons *turn* (cons :pos pos))))
(with-backends back
- (go->move back move))
+ (setf (go-move back) move))
(apply-turn-to-board (list move))
(setf *turn* (other-color *turn*)))
(when *autoplay* (go-board-next)))
(defun go-board-act-resign ()
(interactive)
- (with-backends back (go->reset back)))
+ (with-backends back (go-reset back)))
(defun go-board-act-undo (&optional num)
(interactive "p")
- (with-backends back (go->undo back))
+ (with-backends back (go-undo back))
(pop *history*)
(update-display (current-buffer))
(setf *turn* (other-color *turn*)))
@@ -301,7 +302,8 @@
(defun go-board-next (&optional count)
(interactive "p")
(dotimes (n (or count 1) (or count 1))
- (apply-turn-to-board (go<-turn *back-end* *turn*))
+ (apply-turn-to-board
+ (cons (go-move *back-end*) (ignoring-unsupported (go-labels *back-end*))))
(setf *turn* (other-color *turn*))))
(defun go-board-mouse-move (ev)
diff --git a/go-gtp.el b/go-gtp.el
index aead8c4..68d774f 100644
--- a/go-gtp.el
+++ b/go-gtp.el
@@ -35,6 +35,12 @@
(require 'go-util)
(require 'go-trans)
+(defun go-gtp-expand-color (turn)
+ (case turn
+ (:B "black")
+ (:W "white")
+ (t (error "gtp: unknown turn %S" turn))))
+
(defun go-gtp-char-to-num (char)
(flet ((err () (error "go-gtp: invalid char %s" char)))
(cond
@@ -78,28 +84,62 @@
(defgeneric gtp-command (back-end command)
"Send gtp COMMAND to OBJECT and return any output.")
-(defmethod go->move ((gtp gtp) move)
- (gtp-command gtp (go-to-gtp-command move)))
-
-(defmethod go<-size ((gtp gtp))
+(defmethod go-size ((gtp gtp))
(parse-integer (gtp-command gtp "query_boardsize")))
-(defmethod go<-name ((gtp gtp))
+(defmethod set-go-size ((gtp gtp) size)
+ (gtp-command gtp (format "boardsize %d" size)))
+
+(defmethod go-name ((gtp gtp))
(gtp-command gtp "name"))
-(defmethod go<-comment ((gtp gtp)) nil)
+(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)))
+ (go-gtp-to-pos color
+ (case color
+ (:B (gtp-command gtp "genmove_black"))
+ (:W (gtp-command gtp "genmove_white"))))))
+
+(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))
+ (let ((last (split-string (gtp-command gtp "last_move"))))
+ (case (intern (car last)) ('white :B) ('black :W))))
-(defmethod go<-move ((gtp gtp) color)
- (go-gtp-to-pos color
- (case color
- (:B (gtp-command gtp "genmove_black"))
- (:W (gtp-command gtp "genmove_white")))))
+(defmethod set-go-color ((gtp gtp) color)
+ (signal 'unsupported-back-end-command (list gtp :set-color color)))
-(defmethod go<-turn ((gtp gtp) color) (list (go<-move gtp color)))
+;; non setf'able generic functions
+(defmethod go-undo ((gtp gtp)) (gtp-command gtp "undo"))
-(defmethod go->reset ((gtp gtp)) (gtp-command gtp "clear_board"))
+(defmethod go-pass ((gtp gtp))
+ (gtp-command gtp (format "%s pass" (go-gtp-expand-color (go-color gtp)))))
-(defmethod go->undo ((gtp gtp)) (gtp-command gtp "undo"))
+(defmethod go-resign ((gtp gtp))
+ (gtp-command gtp (format "%s resign" (go-gtp-expand-color (go-color gtp)))))
+(defmethod go-reset ((gtp gtp)) (gtp-command gtp "clear_board"))
(provide 'go-gtp)
diff --git a/go-sgf.el b/go-sgf.el
index 6a2b98d..e7739a2 100644
--- a/go-sgf.el
+++ b/go-sgf.el
@@ -80,44 +80,40 @@
(defsetf root set-root)
-(defmethod go->move ((sgf sgf) move)
+(defmethod go-move ((sgf sgf) move)
(if (current sgf)
;; TODO: this overwrites rather than saving alternatives
(setf (current sgf) (list move))
(rpush (list move) (go-sgf-ref (self sgf) (butlast (index sgf))))))
-(defmethod go->size ((sgf sgf) size)
+(defmethod 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->resign ((sgf sgf) resign))
+(defmethod go-resign ((sgf sgf) resign))
-(defmethod go->undo ((sgf sgf))
+(defmethod go-undo ((sgf sgf))
(decf (car (last (index sgf))))
(alistp (current sgf)))
-(defmethod go->comment ((sgf sgf) comment)
+(defmethod 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<-size ((sgf sgf))
+(defmethod go-size ((sgf sgf))
(or (aget (root sgf) :S)
(aget (root sgf) :SZ)))
-(defmethod go<-name ((sgf sgf))
+(defmethod go-name ((sgf sgf))
(or (aget (root sgf) :GN)
(aget (root sgf) :EV)))
-(defmethod go<-alt ((sgf sgf)))
+(defmethod go-alt ((sgf sgf)))
-(defmethod go<-turn ((sgf sgf) color)
- (incf (car (last (index sgf))))
- (current sgf))
-
-(defmethod go<-comment ((sgf sgf))
+(defmethod go-comment ((sgf sgf))
(aget (current sgf) :C))
(defun go-from-file (file)
diff --git a/go-tests.el b/go-tests.el
index c43ff31..a5d3e6c 100644
--- a/go-tests.el
+++ b/go-tests.el
@@ -227,7 +227,7 @@
(with-gnugo
(should (string= b1 (gtp-command *gnugo* "showboard")))
(should (string= "" (gtp-command *gnugo* "black A1")))
- (should (string= "" (go->move *gnugo* '(:B :pos . (0 . 1)))))
+ (should (string= "" (go-move *gnugo* '(:B :pos . (0 . 1)))))
(should (string= b2 (gtp-command *gnugo* "showboard"))))))
diff --git a/go-trans.el b/go-trans.el
index f6615d4..37394af 100644
--- a/go-trans.el
+++ b/go-trans.el
@@ -37,17 +37,34 @@
(require 'go-util)
(require 'eieio)
-(defgeneric go->move (back-end move) "Send MOVE to BACK-END.")
-(defgeneric go->size (back-end size) "Send SIZE to BACK-END.")
-(defgeneric go->resign (back-end resign) "Send RESIGN to BACK-END.")
-(defgeneric go->undo (back-end) "Tell BACK-END undo the last move.")
-(defgeneric go->comment (back-end comment) "Send COMMENT to BACK-END.")
-(defgeneric go->reset (back-end) "Reset the current BACK-END.")
-(defgeneric go<-size (back-end) "Get size from BACK-END")
-(defgeneric go<-name (back-end) "Get a game name from BACK-END.")
-(defgeneric go<-alt (back-end) "Get an alternative from BACK-END.")
-(defgeneric go<-move (back-end color) "Get a pos from BACK-END.")
-(defgeneric go<-turn (back-end color) "Get a full turn from BACK-END.")
-(defgeneric go<-comment (back-end) "Get COMMENT from BACK-END.")
+(put 'unsupported-back-end-command
+ 'error-conditions
+ '(error unsupported-back-end-command))
+
+(defmacro ignoring-unsupported (&rest body)
+ `(condition-case err ,@body
+ (unsupported-back-end-command nil)))
+
+(defmacro defgeneric-w-setf (name doc)
+ (let ((set-name (intern (concat "set-" (symbol-name name)))))
+ `(progn
+ (defgeneric ,name (back-end) ,doc)
+ (defgeneric ,set-name (back-end new))
+ (defsetf ,name ,set-name))))
+
+;; setf'able back-end access
+(defgeneric-w-setf go-size "Access BACK-END size.")
+(defgeneric-w-setf go-name "Access BACK-END name.")
+(defgeneric-w-setf go-move "Access current BACK-END move.")
+(defgeneric-w-setf go-labels "Access current BACK-END labels.")
+(defgeneric-w-setf go-comment "Access current BACK-END comment.")
+(defgeneric-w-setf go-alt "Access current BACK-END alternative move.")
+(defgeneric-w-setf go-color "Access current BACK-END turn color.")
+
+;; sending messages to the back-end
+(defgeneric go-undo (back-end) "Send undo to BACK-END.")
+(defgeneric go-pass (back-end) "Send pass to BACK-END.")
+(defgeneric go-resign (back-end) "Send resign to BACK-END.")
+(defgeneric go-reset (back-end) "Send reset to BACK-END.")
(provide 'go-trans)
