eschulte pushed a commit to branch go
in repository elpa.
commit 2a3604910cace9f838d439a95e4c1d18cd4f9d09
Author: Eric Schulte <eric.schu...@gmx.com>
Date: Thu May 24 18:27:13 2012 -0600
playing gnugo
---
sgf-board.el | 82 ++++++++++++++++++++++++++++++---------------------------
sgf-gnugo.el | 5 +++-
sgf-gtp.el | 40 ++++++++++++++++++++++++---
sgf-tests.el | 19 +++++++------
sgf-trans.el | 4 ++-
sgf-util.el | 21 ++++++--------
sgf.el | 2 +-
sgf2el.el | 7 +++++
8 files changed, 112 insertions(+), 68 deletions(-)
diff --git a/sgf-board.el b/sgf-board.el
index 84a5583..a66c3ba 100644
--- a/sgf-board.el
+++ b/sgf-board.el
@@ -31,6 +31,7 @@
(defvar *history* nil "Holds the board history for a GO buffer.")
(defvar *size* nil "Holds the board size.")
+(defvar *turn* nil "Holds the color of the current turn.")
(defvar *back-ends* nil "Holds the back-ends connected to a board.")
(defvar black-piece "X")
@@ -43,9 +44,6 @@
(defun board-size (board) (round (sqrt (length board))))
-(defun pos-to-index (pos size)
- (+ (car pos) (* (cdr pos) size)))
-
(defun move-type (move)
(cond
((member (car move) '(:B :W)) :move)
@@ -54,7 +52,14 @@
(defun other-color (color)
(if (equal color :B) :W :B))
-(defun apply-moves (board moves)
+(defun apply-turn-to-board (moves)
+ (let ((board (pieces-to-board (car *history*) *size*)))
+ (clear-labels board)
+ (dolist (move moves) (apply-move board move))
+ (push (board-to-pieces board) *history*)
+ (update-display (current-buffer))))
+
+(defun apply-move (board move)
(flet ((bset (val data)
(let ((data (if (listp (car data)) data (list data))))
(setf (aref board (pos-to-index (aget data :pos)
@@ -65,15 +70,14 @@
(:LB (aget data :label))
(:LW (aget data :label))
(t nil))))))
- (dolist (move moves board)
- (case (move-type move)
- (:move
- (bset (car move) (cdr move))
- (let ((color (if (equal :B (car move)) :B :W)))
- (remove-dead board (other-color color))
- (remove-dead board color)))
- (:label
- (dolist (data (cdr move)) (bset (car move) data)))))))
+ (case (move-type move)
+ (:move
+ (bset (car move) (cdr move))
+ (let ((color (if (equal :B (car move)) :B :W)))
+ (remove-dead board (other-color color))
+ (remove-dead board color)))
+ (:label
+ (dolist (data (cdr move)) (bset (car move) data))))))
(defun clear-labels (board)
(dotimes (point (length board) board)
@@ -157,7 +161,7 @@
(defun board-row-to-string (board row)
(let* ((size (board-size board))
- (label (format "%3d" (- size row)))
+ (label (format "%3d" (1+ row)))
(row-body (mapconcat
(lambda (n)
(board-pos-to-string board (cons row n)))
@@ -165,8 +169,9 @@
(concat label " " row-body label)))
(defun board-body-to-string (board)
- (mapconcat (lambda (m) (board-row-to-string board m))
- (range (board-size board)) "\n"))
+ (let ((board (transpose-array board)))
+ (mapconcat (lambda (m) (board-row-to-string board m))
+ (reverse (range (board-size board))) "\n")))
(defun board-to-string (board)
(let ((header (board-header board))
@@ -197,6 +202,7 @@
(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 '*turn*) :B)
(set (make-local-variable '*size*) (sgf<-size back-end))
(set (make-local-variable '*history*)
(list (board-to-pieces (make-board *size*))))
@@ -221,21 +227,25 @@
(defun sgf-board-act-move (&optional pos)
(interactive)
- (unless pos
- (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))
+ (let* ((color (case *turn* (:B "black") (:W "white")))
+ (move (cons *turn*
+ (cons :pos
+ (cons (sgf-gtp-char-to-num
+ (aref (downcase
+ (org-icompleting-read
+ (format "[%s] X pos: " color)
+ (mapcar #'string
+ (mapcar #'sgf-gtp-num-to-char
+ (range 1 *size*)))))
+ 0))
+ (1- (string-to-number
+ (org-icompleting-read
+ (format "[%s] Y pos: " color)
+ (mapcar #'number-to-string
+ (range 1 *size*))))))))))
+ (sgf->move (car *back-ends*) move)
+ (apply-turn-to-board (list move))
+ (setf *turn* (other-color *turn*))))
(defun sgf-board-act-resign ()
(interactive)
@@ -266,14 +276,8 @@
(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)))))
+ (apply-turn-to-board (sgf<-turn (car *back-ends*) *turn*))
+ (setf *turn* (other-color *turn*))))
(defun sgf-board-prev (&optional count)
(interactive "p")
diff --git a/sgf-gnugo.el b/sgf-gnugo.el
index 72dcbf4..6925c28 100644
--- a/sgf-gnugo.el
+++ b/sgf-gnugo.el
@@ -31,6 +31,7 @@
;;; CODE:
(require 'sgf-util)
+(require 'sgf-gtp)
(require 'comint)
(defun sgf-gnugo-gtp-commands ()
@@ -88,7 +89,9 @@
;;; Class and interface
(defclass gnugo (gtp)
- ((buffer :initarg :buffer :accessor buffer :initform nil)))
+ ((buffer :initarg :buffer
+ :accessor buffer
+ :initform (sgf-gnugo-start-process))))
(defmethod gtp-command ((gnugo gnugo) command)
(sgf-gnugo-command-to-string gnugo command))
diff --git a/sgf-gtp.el b/sgf-gtp.el
index a198c5a..c90a05b 100644
--- a/sgf-gtp.el
+++ b/sgf-gtp.el
@@ -35,20 +35,31 @@
(require 'sgf-util)
(require 'sgf-trans)
-(defun sgf-gtp-char-to-pos (char)
+(defun sgf-gtp-char-to-num (char)
(flet ((err () (error "sgf-gtp: invalid char %s" char)))
(cond
((< char ?A) (err))
- ((< char ?I) (1+ (- char ?A)))
- ((<= char ?T) (- char ?A))
+ ((< char ?I) (- char ?A))
+ ((<= char ?T) (1- (- char ?A)))
((< char ?a) (err))
- ((< char ?i) (1+ (- char ?a)))
- ((<= char ?t) (- char ?a))
+ ((< char ?i) (- char ?a))
+ ((<= char ?t) (1- (- char ?a)))
(t (err)))))
+(defun sgf-gtp-num-to-char (num)
+ (flet ((err () (error "sgf: invalid num %s" num)))
+ (cond
+ ((< num 1) (err))
+ ((< num 9) (+ ?A (1- num)))
+ (t (+ ?A num)))))
+
(defun sgf-pos-to-gtp (pos)
(format "%c%d" (num-to-char (1+ (car pos))) (1+ (cdr pos))))
+(defun sgf-gtp-to-pos (color gtp)
+ (cons color (cons :pos (cons (sgf-gtp-char-to-num (aref gtp 0))
+ (1- (parse-integer (substring gtp 1)))))))
+
(defun sgf-to-gtp-command (element)
"Convert an sgf ELEMENT to a gtp command."
(let ((key (car element))
@@ -70,5 +81,24 @@
(defmethod sgf->move ((gtp gtp) move)
(gtp-command gtp (sgf-to-gtp-command move)))
+(defmethod sgf<-size ((gtp gtp))
+ (parse-integer (gtp-command gtp "query_boardsize")))
+
+(defmethod sgf<-name ((gtp gtp))
+ (gtp-command gtp "name"))
+
+(defmethod sgf<-comment ((gtp gtp)) nil)
+
+(defmethod sgf<-move ((gtp gtp) color)
+ (sgf-gtp-to-pos color
+ (case color
+ (:B (gtp-command gtp "genmove_black"))
+ (:W (gtp-command gtp "genmove_white")))))
+
+(defmethod sgf<-turn ((gtp gtp) color) (list (sgf<-move gtp color)))
+
+(defmethod sgf->reset ((gtp gtp))
+ (gtp-command gtp "clear_board"))
+
(provide 'sgf-gtp)
;;; sgf-gtp.el ends here
diff --git a/sgf-tests.el b/sgf-tests.el
index 761bc01..311dfda 100644
--- a/sgf-tests.el
+++ b/sgf-tests.el
@@ -139,7 +139,8 @@
" 1 . . . . . . . . . . . . . . . . . . . 1\n"
" A B C D E F G H J K L M N O P Q R S T")))
(dolist (moves rest)
- (apply-moves board moves))
+ (dolist (move moves)
+ (apply-move board move)))
(board-to-string board)
(should t)))
@@ -153,14 +154,14 @@
;;; GTP and gnugo tests
(ert-deftest sgf-test-sgf-gtp-char-to-gtp ()
- (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))))
+ (should (= 1 (sgf-gtp-char-to-num ?A)))
+ (should (= 8 (sgf-gtp-char-to-num ?H)))
+ (should (= 9 (sgf-gtp-char-to-num ?J)))
+ (should (= 19 (sgf-gtp-char-to-num ?T)))
+ (should (= 1 (sgf-gtp-char-to-num ?a)))
+ (should (= 8 (sgf-gtp-char-to-num ?h)))
+ (should (= 9 (sgf-gtp-char-to-num ?j)))
+ (should (= 19 (sgf-gtp-char-to-num ?t))))
(defmacro with-gnugo (&rest body)
`(let (*gnugo*)
diff --git a/sgf-trans.el b/sgf-trans.el
index a8b9ace..14689ac 100644
--- a/sgf-trans.el
+++ b/sgf-trans.el
@@ -42,10 +42,12 @@
(defgeneric sgf->resign (back-end resign) "Send RESIGN 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->reset (back-end) "Reset the current 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<-move (back-end color) "Get a pos from BACK-END.")
+(defgeneric sgf<-turn (back-end color) "Get a full turn from BACK-END.")
(defgeneric sgf<-comment (back-end) "Get COMMENT from BACK-END.")
(provide 'sgf-trans)
diff --git a/sgf-util.el b/sgf-util.el
index 89d989d..04148d7 100644
--- a/sgf-util.el
+++ b/sgf-util.el
@@ -51,18 +51,15 @@
(listp (car list))
(not (listp (caar list)))))
-(defun num-to-char (num)
- (flet ((err () (error "sgf: invalid num %s" num)))
- (cond
- ((< num 1) (err))
- ((< num 9) (+ ?A (1- num)))
- (t (+ ?A num)))))
+(defun pos-to-index (pos size)
+ (+ (car pos) (* (cdr pos) size)))
-(defun char-to-num (char)
- (cond
- ((or (< char ?A) (< ?z char))
- (error "sgf: invalid char %s" char))
- ((< char ?a) (+ 26 (- char ?A)))
- (t (- char ?a))))
+(defun transpose-array (board)
+ (let ((size (round (sqrt (length board))))
+ (trans (make-vector (length board) nil)))
+ (dotimes (row size trans)
+ (dotimes (col size)
+ (setf (aref trans (pos-to-index (cons row col) size))
+ (aref board (pos-to-index (cons col row) size)))))))
(provide 'sgf-util)
diff --git a/sgf.el b/sgf.el
index 9756110..19bf52c 100644
--- a/sgf.el
+++ b/sgf.el
@@ -92,7 +92,7 @@
(defmethod sgf<-alt ((sgf sgf)))
-(defmethod sgf<-move ((sgf sgf))
+(defmethod sgf<-move ((sgf sgf) color)
(incf (car (last (index sgf))))
(current sgf))
diff --git a/sgf2el.el b/sgf2el.el
index 401ed56..f3012fa 100644
--- a/sgf2el.el
+++ b/sgf2el.el
@@ -149,6 +149,13 @@
(car date-args)))))
(add-to-list 'sgf2el-special-properties (cons :DT #'process-date))
+(defun char-to-num (char)
+ (cond
+ ((or (< char ?A) (< ?z char))
+ (error "sgf: invalid char %s" char))
+ ((< char ?a) (+ 26 (- char ?A)))
+ (t (- char ?a))))
+
(defun process-position (position-string)
(cons (char-to-num (aref position-string 0))
(char-to-num (aref position-string 1))))
