[elpa] 104/255: new setf'able generic interface

[Eric Schulte]

eschulte pushed a commit to branch go
in repository elpa.

commit 125f3f1a558064860810ed7893c3099fc1976edb
Author: Eric Schulte <address@hidden>
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)