[elpa] 86/255: playing gnugo

[Eric Schulte]

eschulte pushed a commit to branch go
in repository elpa.

commit 2a3604910cace9f838d439a95e4c1d18cd4f9d09
Author: Eric Schulte <address@hidden>
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))))