[elpa] 83/255: starting to transition to generic board interface

[Eric Schulte]

eschulte pushed a commit to branch go
in repository elpa.

commit 1f4a34494e0bf535234bfac3aa7c2977e34a27d5
Author: Eric Schulte <address@hidden>
Date:   Tue May 22 21:56:00 2012 -0400

    starting to transition to generic board interface
---
 sgf-tests.el |  125 +++++++++++++++++++++++++++++++++++-----------------------
 sgf-trans.el |    3 +-
 sgf.el       |   49 ++++++++++++++++++-----
 3 files changed, 115 insertions(+), 62 deletions(-)

diff --git a/sgf-tests.el b/sgf-tests.el
index c174a60..5e91d69 100644
--- a/sgf-tests.el
+++ b/sgf-tests.el
@@ -32,6 +32,8 @@
 (require 'sgf-gtp)
 (require 'ert)
 
+
+;;; sgf2el tests
 (ert-deftest sgf-parse-simple-tree ()
   (let* ((str "(;GM[1]FF[4]
                SZ[19]
@@ -81,6 +83,8 @@
   (let ((sgf (sgf2el-file-to-el "sgf-files/jp-ming-5.sgf")))
     (should (= 247 (length sgf)))))
 
+
+;;; board tests
 (ert-deftest sgf-empty-board-to-string-test ()
   (let ((board (make-vector (* 19 19) nil))
         (string (concat "    A B C D E F G H J K L M N O P Q R S T\n"
@@ -137,29 +141,6 @@
     (board-to-string board)
     (should t)))
 
-(defmacro with-sgf-file (file &rest body)
-  (declare (indent 1))
-  `(let* ((sgf    (sgf2el-file-to-el ,file))
-          (buffer (display-sgf sgf)))
-     (unwind-protect
-         (with-current-buffer buffer ,@body)
-       (set-default 'sgf-index '(0))
-       (should (kill-buffer buffer)))))
-(def-edebug-spec parse-many (file body))
-
-(ert-deftest sgf-display-fresh-sgf-buffer ()
-  (with-sgf-file "sgf-files/3-4-joseki.sgf"
-    (should *board*)
-    (should *sgf*)
-    (should *index*)))
-
-(ert-deftest sgf-independent-points-properties ()
-  (with-sgf-file "sgf-files/3-4-joseki.sgf"
-    (let ((points-length (length (assoc :points (sgf-ref sgf '(0))))))
-      (right 4)
-      (should (= points-length
-                 (length (assoc :points (sgf-ref sgf '(0)))))))))
-
 (ert-deftest sgf-neighbors ()
   (let ((board (make-board 19)))
     (should (= 2 (length (neighbors board 0))))
@@ -171,33 +152,8 @@
   (cons (stones-for *board* :B)
         (stones-for *board* :W)))
 
-(ert-deftest sgf-singl-stone-capture ()
-  (with-sgf-file "sgf-files/1-capture.sgf"
-    (right 3) (should (tree-equal (stone-counts) '(2 . 0)))))
-
-(ert-deftest sgf-remove-dead-stone-ko ()
-  (with-sgf-file "sgf-files/ko.sgf"
-    (should (tree-equal (stone-counts) '(0 . 0))) (right 1)
-    (should (tree-equal (stone-counts) '(1 . 0))) (right 1)
-    (should (tree-equal (stone-counts) '(1 . 1))) (right 1)
-    (should (tree-equal (stone-counts) '(2 . 1))) (right 1)
-    (should (tree-equal (stone-counts) '(2 . 2))) (right 1)
-    (should (tree-equal (stone-counts) '(3 . 2))) (right 1)
-    (should (tree-equal (stone-counts) '(2 . 3))) (right 1)
-    (should (tree-equal (stone-counts) '(3 . 2))) (right 1)
-    (should (tree-equal (stone-counts) '(2 . 3)))))
-
-(ert-deftest sgf-two-stone-capture ()
-  (with-sgf-file "sgf-files/2-capture.sgf"
-    (right 8) (should (tree-equal (stone-counts) '(6 . 0)))))
-
-(ert-deftest sgf-parse-empty-properties ()
-  (with-sgf-file "sgf-files/w-empty-properties.sgf"
-    (should (remove-if-not (lambda (prop)
-                             (let ((val (cdr prop)))
-                               (and (sequencep val) (= 0 (length val)))))
-                           (car sgf)))))
-
+
+;;; GTP and gnugo tests
 (ert-deftest sgf-test-sgf-gtp-char-to-gtp ()
   (should (= 1  (sgf-gtp-char-to-gtp ?A)))
   (should (= 8  (sgf-gtp-char-to-gtp ?H)))
@@ -274,3 +230,72 @@
      (should (string= "" (gtp-command *gnugo* "black A1")))
      (should (string= "" (sgf->move *gnugo* '(:B :pos . (0 . 1)))))
      (should (string= b2 (gtp-command *gnugo* "showboard"))))))
+
+
+;;; SGF tests
+(defmacro with-sgf-from-file (file &rest body)
+  (declare (indent 1))
+  `(let (*sgf*)
+     (progn
+       (setf *sgf* (make-instance 'sgf))
+       (setf (self *sgf*) (sgf2el-file-to-el ,file))
+       ,@body)))
+
+(ert-deftest sgf-test-sgf-class-creation ()
+  (with-sgf-from-file "sgf-files/jp-ming-5.sgf"
+    (should (tree-equal (index *sgf*) '(0)))
+    (should (tree-equal (current *sgf*) (root *sgf*)))
+    (should (string= "Famous Blood Vomiting Game" (sgf<-name *sgf*)))
+    (should (= 19 (sgf<-size *sgf*)))))
+
+
+;;; SGF and board tests
+(defmacro with-sgf-file (file &rest body)
+  (declare (indent 1))
+  `(let (*sgf* buffer)
+     (unwind-protect
+         (progn
+           (setf *sgf* (make-instance 'sgf))
+           (setf (self *sgf*) (sgf2el-file-to-el ,file))
+           (setf buffer (sgf-board-display *sgf*))
+           (with-current-buffer buffer ,@body))
+       (should (kill-buffer buffer)))))
+(def-edebug-spec parse-many (file body))
+
+(ert-deftest sgf-display-fresh-sgf-buffer ()
+  (with-sgf-file "sgf-files/3-4-joseki.sgf"
+    (should *board*)))
+
+(ert-deftest sgf-independent-points-properties ()
+  (with-sgf-file "sgf-files/3-4-joseki.sgf"
+    (let ((points-length (length (assoc :points (sgf-ref sgf '(0))))))
+      (right 4)
+      (should (= points-length
+                 (length (assoc :points (sgf-ref sgf '(0)))))))))
+
+(ert-deftest sgf-singl-stone-capture ()
+  (with-sgf-file "sgf-files/1-capture.sgf"
+    (right 3) (should (tree-equal (stone-counts) '(2 . 0)))))
+
+(ert-deftest sgf-remove-dead-stone-ko ()
+  (with-sgf-file "sgf-files/ko.sgf"
+    (should (tree-equal (stone-counts) '(0 . 0))) (right 1)
+    (should (tree-equal (stone-counts) '(1 . 0))) (right 1)
+    (should (tree-equal (stone-counts) '(1 . 1))) (right 1)
+    (should (tree-equal (stone-counts) '(2 . 1))) (right 1)
+    (should (tree-equal (stone-counts) '(2 . 2))) (right 1)
+    (should (tree-equal (stone-counts) '(3 . 2))) (right 1)
+    (should (tree-equal (stone-counts) '(2 . 3))) (right 1)
+    (should (tree-equal (stone-counts) '(3 . 2))) (right 1)
+    (should (tree-equal (stone-counts) '(2 . 3)))))
+
+(ert-deftest sgf-two-stone-capture ()
+  (with-sgf-file "sgf-files/2-capture.sgf"
+    (right 8) (should (tree-equal (stone-counts) '(6 . 0)))))
+
+(ert-deftest sgf-parse-empty-properties ()
+  (with-sgf-file "sgf-files/w-empty-properties.sgf"
+    (should (remove-if-not (lambda (prop)
+                             (let ((val (cdr prop)))
+                               (and (sequencep val) (= 0 (length val)))))
+                           (car sgf)))))
diff --git a/sgf-trans.el b/sgf-trans.el
index a439713..416fb2c 100644
--- a/sgf-trans.el
+++ b/sgf-trans.el
@@ -42,9 +42,10 @@
 (defgeneric sgf->resign  (back-end resign)  "Send RESIGN to BACK-END.")
 (defgeneric sgf->undo    (back-end undo)    "Send UNDO to BACK-END.")
 (defgeneric sgf->comment (back-end comment) "Send COMMENT to BACK-END.")
+(defgeneric sgf<-size    (back-end)         "Get size from BACK-END")
+(defgeneric sgf<-name    (back-end)         "Get a game name from BACK-END.")
 (defgeneric sgf<-alt     (back-end)         "Get an alternative from 
BACK-END.")
 (defgeneric sgf<-move    (back-end)         "Get POS from BACK-END.")
-(defgeneric sgf<-board   (back-end)         "Get SIZE from BACK-END.")
 (defgeneric sgf<-comment (back-end)         "Get COMMENT from BACK-END.")
 
 (provide 'sgf-trans)
diff --git a/sgf.el b/sgf.el
index 99e017a..1b18b2c 100644
--- a/sgf.el
+++ b/sgf.el
@@ -58,18 +58,45 @@
 
 ;;; Class and interface
 (defclass sgf nil
-  ((sgf   :initarg :sgf   :accessor sgf   :initform nil)
-   (index :initarg :index :accessor index :initform nil))
+  ((self  :initarg :self  :accessor self  :initform nil)
+   (index :initarg :index :accessor index :initform '(0)))
   "Class for the SGF back end.")
 
-(defmethod sgf->move    ((sgf sgf) move))
-(defmethod sgf->board   ((sgf sgf) size))
-(defmethod sgf->resign  ((sgf sgf) resign))
-(defmethod sgf->undo    ((sgf sgf) undo))
-(defmethod sgf->comment ((sgf sgf) comment))
-(defmethod sgf<-alt     ((sgf sgf)))
-(defmethod sgf<-move    ((sgf sgf)))
-(defmethod sgf<-board   ((sgf sgf)))
-(defmethod sgf<-comment ((sgf sgf)))
+(defmethod current ((sgf sgf))
+  (sgf-ref (self sgf) (index sgf)))
+
+(defmethod root ((sgf sgf))
+  (sgf-ref (self sgf) '(0)))
+
+(defmethod sgf->move ((sgf sgf) move))
+
+(defmethod sgf->board ((sgf sgf) size))
+
+(defmethod sgf->resign ((sgf sgf) resign))
+
+(defmethod sgf->undo ((sgf sgf) undo)
+  (decf (car (last (index sgf))))
+  (alistp (current sgf)))
+
+;; (defmethod sgf->comment ((sgf sgf) comment)
+;;   ;; TODO: need a setf method for current
+;;   (push (cons :C comment) (current sgf)))
+
+(defmethod sgf<-size ((sgf sgf))
+  (or (aget (root sgf) :S)
+      (aget (root sgf) :SZ)))
+
+(defmethod sgf<-name ((sgf sgf))
+  (or (aget (root sgf) :GN)
+      (aget (root sgf) :EV)))
+
+(defmethod sgf<-alt ((sgf sgf)))
+
+(defmethod sgf<-move ((sgf sgf))
+  (incf (car (last (index sgf))))
+  (alistp (current sgf)))
+
+(defmethod sgf<-comment ((sgf sgf))
+  (aget (current sgf) :C))
 
 (provide 'sgf)