[elpa] 105/255: fleshing out the sgf interface

[Eric Schulte]

eschulte pushed a commit to branch go
in repository elpa.

commit 55e02f9869be66c251268fae76c9cfe05d655571
Author: Eric Schulte <address@hidden>
Date:   Sun May 27 11:11:38 2012 -0600

    fleshing out the sgf interface
---
 go-sgf.el |   98 ++++++++++++++++++++++++++++++++++++++++++++++---------------
 1 files changed, 74 insertions(+), 24 deletions(-)

diff --git a/go-sgf.el b/go-sgf.el
index e7739a2..db13ad5 100644
--- a/go-sgf.el
+++ b/go-sgf.el
@@ -56,12 +56,16 @@
 (defsetf go-sgf-ref set-go-sgf-ref)
 
 
-;;; Class and interface
+;;; Class
 (defclass sgf nil
   ((self  :initarg :self  :accessor self  :initform nil)
    (index :initarg :index :accessor index :initform '(0)))
   "Class for the SGF back end.")
 
+(defun sgf-from-file (file)
+  (interactive "f")
+  (make-instance 'sgf :self (sgf2el-file-to-el file)))
+
 (defmethod current ((sgf sgf))
   (go-sgf-ref (self sgf) (index sgf)))
 
@@ -80,44 +84,90 @@
 
 (defsetf root set-root)
 
-(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 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 go-size ((sgf sgf) size)
+(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-resign ((sgf sgf) resign))
+(defmethod go-name ((sgf sgf))
+  (or (aget (root sgf) :GN)
+      (aget (root sgf) :EV)))
 
-(defmethod go-undo ((sgf sgf))
-  (decf (car (last (index sgf))))
-  (alistp (current sgf)))
+(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"))))
+
+(defmethod set-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-labels ((sgf sgf))
+  (next sgf)
+  (let ((turn (current sgf)))
+    (if turn
+        (remove-if (lambda (pair) (member (car pair) '(:B :W))) 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 (go-sgf-ref (self sgf) (butlast (index sgf))))))
+
+(defmethod go-comment ((sgf sgf))
+  (aget (current sgf) :C))
 
-(defmethod go-comment ((sgf sgf) comment)
+(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-size ((sgf sgf))
-  (or (aget (root sgf) :S)
-      (aget (root sgf) :SZ)))
+(defmethod go-alt ((sgf sgf))
+  (error "sgf: go-alt not yet supported"))
 
-(defmethod go-name ((sgf sgf))
-  (or (aget (root sgf) :GN)
-      (aget (root sgf) :EV)))
+(defmethod set-go-alt ((sgf sgf) alt)
+  (error "sgf: set-go-alt not yet supported"))
 
-(defmethod go-alt ((sgf sgf)))
+(defmethod go-color ((sgf sgf))
+  (signal 'unsupported-back-end-command (list sgf :move)))
 
-(defmethod go-comment ((sgf sgf))
-  (aget (current sgf) :C))
+(defmethod set-go-color ((sgf sgf) color)
+  (signal 'unsupported-back-end-command (list sgf :set-color color)))
 
-(defun go-from-file (file)
-  (interactive "f")
-  (make-instance 'sgf :self (sgf2el-file-to-el file)))
+;; 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)))
 
 (provide 'go-sgf)