[elpa] 85/255: working with new set less some state-leak issues

[Eric Schulte]

eschulte pushed a commit to branch go
in repository elpa.

commit 6124fe7137e8cb6234f7fefe7ba59306b34dde1b
Author: Eric Schulte <address@hidden>
Date:   Wed May 23 00:03:56 2012 -0400

    working with new set less some state-leak issues
---
 sgf-board.el |  116 +++++++++++++++++++++++++++++++++-------------------------
 sgf-tests.el |  103 +++++++++++++++++++++++++++------------------------
 sgf-trans.el |    2 +-
 sgf.el       |    8 +++-
 4 files changed, 127 insertions(+), 102 deletions(-)

diff --git a/sgf-board.el b/sgf-board.el
index 7cdb913..84a5583 100644
--- a/sgf-board.el
+++ b/sgf-board.el
@@ -29,8 +29,8 @@
 (require 'sgf-util)
 (require 'sgf-trans)
 
-(defvar *history* nil "Holds the board history for a GO buffer.")
-
+(defvar *history*   nil "Holds the board history for a GO buffer.")
+(defvar *size*      nil "Holds the board size.")
 (defvar *back-ends* nil "Holds the back-ends connected to a board.")
 
 (defvar black-piece "X")
@@ -76,16 +76,11 @@
          (dolist (data (cdr move)) (bset (car move) data)))))))
 
 (defun clear-labels (board)
-  (dotimes (point (length board))
+  (dotimes (point (length board) board)
     (when (aref board point)
       (unless (member (aref board point) '(:B :W))
         (setf (aref board point) nil)))))
 
-(defun stones-for (board color)
-  (let ((count 0))
-    (dotimes (n (length board) count)
-      (when (equal color (aref board n)) (incf count)))))
-
 (defun neighbors (board piece)
   (let ((size (board-size board))
         neighbors)
@@ -101,15 +96,15 @@
          (neighbors (remove-if (lambda (n) (member n already))
                                (neighbors board piece)))
          (neighbor-vals (mapcar (lambda (n) (aref board n)) neighbors))
-         (friendly-neighbors (delete nil (map 'list (lambda (n v)
-                                                      (when (equal v val) n))
-                                              neighbors neighbor-vals)))
+         (friendly (delete nil (mapcar
+                                (lambda (n) (when (equal (aref board n) val) 
n))
+                                neighbors)))
          (already (cons piece already)))
     (or (some (lambda (v) (not (or (equal v enemy) ; touching open space
                               (equal v val))))
               neighbor-vals)
         (some (lambda (n) (alive-p board n already)) ; touching alive dragon
-              friendly-neighbors))))
+              friendly))))
 
 (defun remove-dead (board color)
   ;; must remove one color at a time for ko situations
@@ -126,7 +121,7 @@
         (when val (push (cons val n) pieces))))))
 
 (defun pieces-to-board (pieces size)
-  (let ((board (make-vector size nil)))
+  (let ((board (make-vector (* size size) nil)))
     (dolist (piece pieces board)
       (setf (aref board (cdr piece)) (car piece)))))
 
@@ -178,30 +173,34 @@
         (body (board-body-to-string board)))
     (mapconcat #'identity (list header body header) "\n")))
 
-(defun update-display ()
-  (delete-region (point-min) (point-max))
-  (goto-char (point-min))
-  (insert
-   "\n"
-   (board-to-string (car *history*))
-   "\n\n")
-  (let ((comment (sgf<-comment (car *back-ends*))))
-    (when comment
-      (insert
-       (make-string (+ 6 (* 2 (board-size (car *history*)))) ?=)
-       "\n\n"
-       comment)))
-  (goto-char (point-min)))
+(defun ear-muffs (str) (concat "*" str "*"))
+
+(defun update-display (buffer)
+  (with-current-buffer buffer
+    (delete-region (point-min) (point-max))
+    (goto-char (point-min))
+    (insert "\n"
+            (board-to-string
+             (pieces-to-board (car *history*) *size*))
+            "\n\n")
+    (let ((comment (sgf<-comment (car *back-ends*))))
+      (when comment
+        (insert (make-string (+ 6 (* 2 *size*)) ?=)
+                "\n\n"
+                comment)))
+    (goto-char (point-min))))
 
 (defun sgf-board-display (back-end)
   (let ((buffer (generate-new-buffer "*GO*")))
     (with-current-buffer buffer
+      (sgf-board-mode)
+      (when (sgf<-name back-end)
+        (rename-buffer (ear-muffs (sgf<-name back-end)) 'unique))
       (set (make-local-variable '*back-ends*) (list back-end))
-      (set (make-local-variable '*history*) nil)
-      (push (make-board (sgf<-size back-end)) *history*)
-      (sgf-board-mode))
-    (when (sgf<-name back-end)
-      (rename-buffer (sgf<-name back-end) 'unique))
+      (set (make-local-variable '*size*) (sgf<-size back-end))
+      (set (make-local-variable '*history*)
+           (list (board-to-pieces (make-board *size*))))
+      (update-display (current-buffer)))
     (pop-to-buffer buffer)))
 
 
@@ -223,20 +222,19 @@
 (defun sgf-board-act-move (&optional pos)
   (interactive)
   (unless pos
-    (let ((size (board-size (car *history*))))
-      (setq pos
-            (cons
-             (char-to-num
-              (aref (downcase
-                     (org-icompleting-read
-                      "X pos: "
-                      (mapcar #'string
-                              (mapcar #'num-to-char (range 1 size)))))
-                    0))
-             (1- (string-to-number
-                  (org-icompleting-read
-                   "Y pos: "
-                   (mapcar #'number-to-string (range 1 size)))))))))
+    (setq pos
+          (cons
+           (char-to-num
+            (aref (downcase
+                   (org-icompleting-read
+                    "X pos: "
+                    (mapcar #'string
+                            (mapcar #'num-to-char (range 1 *size*)))))
+                  0))
+           (1- (string-to-number
+                (org-icompleting-read
+                 "Y pos: "
+                 (mapcar #'number-to-string (range 1 *size*))))))))
   (message "move: %S" pos))
 
 (defun sgf-board-act-resign ()
@@ -255,10 +253,8 @@
 ;;; Display mode
 (defvar sgf-board-mode-map
   (let ((map (make-sparse-keymap)))
-    (define-key map (kbd "<right>") 'right)
-    (define-key map (kbd "<left>")  'left)
-    (define-key map (kbd "<up>")    'up)
-    (define-key map (kbd "<down>")  'down)
+    (define-key map (kbd "<right>") 'sgf-board-next)
+    (define-key map (kbd "<left>")  'sgf-board-prev)
     (define-key map (kbd "q") (lambda () (interactive)
                                 (kill-buffer (current-buffer))))
     map)
@@ -267,4 +263,24 @@
 (define-derived-mode sgf-board-mode nil "SGF"
   "Major mode for editing text written for viewing SGF files.")
 
+(defun sgf-board-next (&optional count)
+  (interactive "p")
+  (dotimes (n (or count 1) (or count 1))
+    (let ((board (pieces-to-board (car *history*) *size*))
+          (move (sgf<-move (car *back-ends*))))
+      (if move
+          (push (board-to-pieces
+                 (apply-moves (clear-labels board) move))
+                *history*)
+        (error "sgf-board: no more moves"))
+      (update-display (current-buffer)))))
+
+(defun sgf-board-prev (&optional count)
+  (interactive "p")
+  (dotimes (n (or count 1) (or count 1))
+    (message "index:" (index (car *back-ends*)))
+    (sgf->undo (car *back-ends*))
+    (pop *history*)
+    (update-display (current-buffer))))
+
 (provide 'sgf-board)
diff --git a/sgf-tests.el b/sgf-tests.el
index e3378fc..761bc01 100644
--- a/sgf-tests.el
+++ b/sgf-tests.el
@@ -30,6 +30,8 @@
 (require 'sgf2el)
 (require 'sgf-board)
 (require 'sgf-gtp)
+(require 'sgf-gnugo)
+(require 'sgf)
 (require 'ert)
 
 
@@ -148,21 +150,17 @@
     (should (= 4 (length (neighbors board (/ (length board) 2)))))
     (should (= 3 (length (neighbors board 1))))))
 
-(defun stone-counts ()
-  (cons (stones-for (car *history*) :B)
-        (stones-for (car *history*) :W)))
-
 
 ;;; 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)))
-  (should (= 9  (sgf-gtp-char-to-gtp ?J)))
-  (should (= 19 (sgf-gtp-char-to-gtp ?T)))
-  (should (= 1  (sgf-gtp-char-to-gtp ?a)))
-  (should (= 8  (sgf-gtp-char-to-gtp ?h)))
-  (should (= 9  (sgf-gtp-char-to-gtp ?j)))
-  (should (= 19 (sgf-gtp-char-to-gtp ?t))))
+  (should (= 1  (sgf-gtp-char-to-pos ?A)))
+  (should (= 8  (sgf-gtp-char-to-pos ?H)))
+  (should (= 9  (sgf-gtp-char-to-pos ?J)))
+  (should (= 19 (sgf-gtp-char-to-pos ?T)))
+  (should (= 1  (sgf-gtp-char-to-pos ?a)))
+  (should (= 8  (sgf-gtp-char-to-pos ?h)))
+  (should (= 9  (sgf-gtp-char-to-pos ?j)))
+  (should (= 19 (sgf-gtp-char-to-pos ?t))))
 
 (defmacro with-gnugo (&rest body)
   `(let (*gnugo*)
@@ -228,7 +226,7 @@
     (with-gnugo
      (should (string= b1 (gtp-command *gnugo* "showboard")))
      (should (string= "" (gtp-command *gnugo* "black A1")))
-     (should (string= "" (sgf->move *gnugo* '(:B :pos . (0 . 1)))))
+     (should (string= "" (sgf->move   *gnugo* '(:B :pos . (0 . 1)))))
      (should (string= b2 (gtp-command *gnugo* "showboard"))))))
 
 
@@ -237,10 +235,18 @@
   (declare (indent 1))
   `(let (*sgf*)
      (progn
-       (setf *sgf* (make-instance 'sgf))
-       (setf (self *sgf*) (sgf2el-file-to-el ,file))
+       (setf *sgf* (make-instance 'sgf
+                     :self (sgf2el-file-to-el ,file)
+                     :index '(0)))
        ,@body)))
 
+(ert-deftest sgf-parse-empty-properties ()
+  (with-sgf-from-file "sgf-files/w-empty-properties.sgf"
+    (should (remove-if-not (lambda (prop)
+                             (let ((val (cdr prop)))
+                               (and (sequencep val) (= 0 (length val)))))
+                           (root *sgf*)))))
+
 (ert-deftest sgf-test-sgf-class-creation ()
   (with-sgf-from-file "sgf-files/jp-ming-5.sgf"
     (should (tree-equal (index *sgf*) '(0)))
@@ -250,53 +256,52 @@
 
 
 ;;; SGF and board tests
-(defmacro with-sgf-file (file &rest body)
+(defmacro with-sgf-display (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)))))
+  (let ((buffer (gensym "sgf-display-buffer")))
+    `(let ((,buffer (sgf-board-display
+                     (make-instance 'sgf
+                       :self (sgf2el-file-to-el ,file)
+                       :index '(0)))))
+       (unwind-protect (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"
+  (with-sgf-display "sgf-files/3-4-joseki.sgf"
     (should *history*)
     (should *back-ends*)))
 
 (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)))))))))
+  (with-sgf-display "sgf-files/3-4-joseki.sgf"
+    (sgf-board-next 4)
+    (should (not (tree-equal (car *history*) (car (last *history*)))))))
+
+(defun stone-counts ()
+  (let ((pieces (car sgf-board-history)))
+    (flet ((count-for (color) (length (remove-if-not
+                                      (lambda (piece) (equal color (car 
piece)))
+                                      pieces))))
+      (cons (count-for :B) (count-for :W)))))
 
 (ert-deftest sgf-singl-stone-capture ()
-  (with-sgf-file "sgf-files/1-capture.sgf"
-    (right 3) (should (tree-equal (stone-counts) '(2 . 0)))))
+  (with-sgf-display "sgf-files/1-capture.sgf"
+    (sgf-board-next 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)
+  (with-sgf-display "sgf-files/ko.sgf"
+    (should (tree-equal (stone-counts) '(0 . 0))) (sgf-board-next)
+    (should (tree-equal (stone-counts) '(1 . 0))) (sgf-board-next)
+    (should (tree-equal (stone-counts) '(1 . 1))) (sgf-board-next)
+    (should (tree-equal (stone-counts) '(2 . 1))) (sgf-board-next)
+    (should (tree-equal (stone-counts) '(2 . 2))) (sgf-board-next)
+    (should (tree-equal (stone-counts) '(3 . 2))) (sgf-board-next)
+    (should (tree-equal (stone-counts) '(2 . 3))) (sgf-board-next)
+    (should (tree-equal (stone-counts) '(3 . 2))) (sgf-board-next)
     (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)))))
+  (with-sgf-display "sgf-files/2-capture.sgf"
+    (sgf-board-next 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)))))
+(provide 'sgf-tests)
diff --git a/sgf-trans.el b/sgf-trans.el
index 416fb2c..a8b9ace 100644
--- a/sgf-trans.el
+++ b/sgf-trans.el
@@ -40,7 +40,7 @@
 (defgeneric sgf->move    (back-end move)    "Send MOVE to BACK-END.")
 (defgeneric sgf->board   (back-end size)    "Send SIZE to BACK-END.")
 (defgeneric sgf->resign  (back-end resign)  "Send RESIGN to BACK-END.")
-(defgeneric sgf->undo    (back-end undo)    "Send UNDO to BACK-END.")
+(defgeneric sgf->undo    (back-end)         "Tell BACK-END undo the last 
move.")
 (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.")
diff --git a/sgf.el b/sgf.el
index 1b18b2c..9756110 100644
--- a/sgf.el
+++ b/sgf.el
@@ -74,7 +74,7 @@
 
 (defmethod sgf->resign ((sgf sgf) resign))
 
-(defmethod sgf->undo ((sgf sgf) undo)
+(defmethod sgf->undo ((sgf sgf))
   (decf (car (last (index sgf))))
   (alistp (current sgf)))
 
@@ -94,9 +94,13 @@
 
 (defmethod sgf<-move ((sgf sgf))
   (incf (car (last (index sgf))))
-  (alistp (current sgf)))
+  (current sgf))
 
 (defmethod sgf<-comment ((sgf sgf))
   (aget (current sgf) :C))
 
+(defun sgf-from-file (file)
+  (interactive "f")
+  (make-instance 'sgf :self (sgf2el-file-to-el file)))
+
 (provide 'sgf)