eschulte pushed a commit to branch go
in repository elpa.
commit 6124fe7137e8cb6234f7fefe7ba59306b34dde1b
Author: Eric Schulte <eric.schu...@gmx.com>
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)
