[elpa] 123/255: working towards savings games in SGF format

[Eric Schulte]

eschulte pushed a commit to branch go
in repository elpa.

commit e7c262f157e6e0e25f18d17720d9e9599883739e
Author: Eric Schulte <address@hidden>
Date:   Mon May 28 10:51:18 2012 -0600

    working towards savings games in SGF format
---
 back-ends/gtp.el |    2 ++
 back-ends/sgf.el |   13 +++++++++++++
 go-board.el      |   50 +++++++++++++++++++++++++++++++-------------------
 go.el            |   15 +++++++++------
 4 files changed, 55 insertions(+), 25 deletions(-)

diff --git a/back-ends/gtp.el b/back-ends/gtp.el
index 7a2321c..c7e0ee7 100644
--- a/back-ends/gtp.el
+++ b/back-ends/gtp.el
@@ -142,4 +142,6 @@
 
 (defmethod go-reset ((gtp gtp)) (gtp-command gtp "clear_board"))
 
+(defmethod go-quit ((gtp gtp)) (gtp-command gtp "quit"))
+
 (provide 'gtp)
diff --git a/back-ends/sgf.el b/back-ends/sgf.el
index 9b7cc04..0acac5d 100644
--- a/back-ends/sgf.el
+++ b/back-ends/sgf.el
@@ -65,6 +65,15 @@
   (interactive "f")
   (make-instance 'sgf :self (sgf2el-file-to-el file)))
 
+(defun sgf-to-file (sgf file)
+  (interactive "F")
+  (when (and (file-exists-p file)
+             (not (y-or-n-p (format "overwrite %s? " file))))
+    (error "aborted"))
+  (with-temp-file file
+    (delete-region (point-min) (point-max))
+    (insert (pp (self sgf)))))
+
 (defmethod current ((sgf sgf))
   (sgf-ref (self sgf) (index sgf)))
 
@@ -169,4 +178,8 @@
 (defmethod go-resign ((sgf sgf))
   (signal 'unsupported-back-end-command (list sgf :resign)))
 
+(defmethod go-quit ((sgf sgf))
+  (when (y-or-n-p "Save game to file: ")
+    (sgf-to-file sgf (read-file-name "Save game to: "))))
+
 (provide 'sgf)
diff --git a/go-board.el b/go-board.el
index 6d1b239..474ce69 100644
--- a/go-board.el
+++ b/go-board.el
@@ -53,6 +53,13 @@
 (defun other-color (color)
   (if (equal color :B) :W :B))
 
+(defun point-of-pos (pos)
+  (catch 'found-pos
+    (dotimes (p (1- (point-max)) (error "go: pos %S not found" pos))
+      (let ((pos-at-point (get-text-property (1+ p) :pos)))
+        (when (and pos-at-point (tree-equal pos pos-at-point))
+          (throw 'found-pos p))))))
+
 (defun apply-turn-to-board (moves)
   (let ((board (pieces-to-board (car *history*) *size*)))
     (clear-labels board)
@@ -206,19 +213,19 @@
 
 (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 (ignoring-unsupported (go-comment *back-end*))))
-      (when comment
-        (insert (make-string (+ 6 (* 2 *size*)) ?=)
-                "\n\n"
-                comment)))
-    (go-board-paint)
-    (goto-char (point-min))))
+    (let ((point (point)))
+      (delete-region (point-min) (point-max))
+      (insert "\n"
+              (board-to-string
+               (pieces-to-board (car *history*) *size*))
+              "\n\n")
+      (let ((comment (ignoring-unsupported (go-comment *back-end*))))
+        (when comment
+          (insert (make-string (+ 6 (* 2 *size*)) ?=)
+                  "\n\n"
+                  comment)))
+      (go-board-paint)
+      (goto-char point))))
 
 (defun go-board (back-end &rest trackers)
   (let ((buffer (generate-new-buffer "*GO*")))
@@ -227,11 +234,11 @@
       (let ((name (go-name back-end)))
         (when name
           (rename-buffer (ear-muffs name) 'unique)
-          (mapcar (lambda (tr) (go-name tr name)) trackers)))
+          (mapcar (lambda (tr) (setf (go-name tr) name)) trackers)))
       (set (make-local-variable '*back-end*) back-end)
       (set (make-local-variable '*turn*) :B)
       (set (make-local-variable '*size*) (go-size back-end))
-      (mapcar (lambda (tr) (go-size tr *size*)) trackers)
+      (mapcar (lambda (tr) (setf (go-size tr) *size*)) trackers)
       (set (make-local-variable '*history*)
            (list (board-to-pieces (make-board *size*))))
       (set (make-local-variable '*trackers*) trackers)
@@ -301,14 +308,20 @@
 (defun go-board-next (&optional count)
   (interactive "p")
   (dotimes (n (or count 1) (or count 1))
-    (apply-turn-to-board
-     (cons (go-move *back-end*) (ignoring-unsupported (go-labels *back-end*))))
+    (let ((move (go-move *back-end*)))
+      (apply-turn-to-board
+       (cons move (ignoring-unsupported (go-labels *back-end*)))))
     (setf *turn* (other-color *turn*))))
 
 (defun go-board-mouse-move (ev)
   (interactive "e")
   (go-board-act-move (get-text-property (posn-point (event-start ev)) :pos)))
 
+(defun go-board-quit ()
+  (interactive)
+  (with-backends back (go-quit back))
+  (kill-buffer (current-buffer)))
+
 
 ;;; Display mode
 (defvar go-board-mode-map
@@ -322,8 +335,7 @@
     (define-key map (kbd "p") 'go-board-act-undo)
     (define-key map (kbd "<right>") 'go-board-next)
     (define-key map (kbd "<left>")  'go-board-act-undo)
-    (define-key map (kbd "q") (lambda () (interactive)
-                                (kill-buffer (current-buffer))))
+    (define-key map (kbd "q") 'go-board-quit)
     map)
   "Keymap for `go-board-mode'.")
 
diff --git a/go.el b/go.el
index 7052502..993f82c 100644
--- a/go.el
+++ b/go.el
@@ -61,12 +61,14 @@
   "Play a game of GO against gnugo.
 Optional argument LEVEL specifies gnugo's level of play."
   (interactive "P")
-  (let ((*autoplay* t))
-    (go-board
-     (make-instance 'gnugo
-       :buffer (apply #'gnugo-start-process
-                      (when level
-                        (list "--level" (number-to-string level))))))))
+  (with-current-buffer
+      (go-board
+       (make-instance 'gnugo
+         :buffer (apply #'gnugo-start-process
+                        (when level
+                          (list "--level" (number-to-string level)))))
+       (make-instance 'sgf))
+    (setq *autoplay* t)))
 
 ;; setf'able back-end access
 (defgeneric-w-setf go-size    "Access BACK-END size.")
@@ -82,5 +84,6 @@ Optional argument LEVEL specifies gnugo's level of play."
 (defgeneric go-pass   (back-end) "Send pass to BACK-END.")
 (defgeneric go-resign (back-end) "Send resign to BACK-END.")
 (defgeneric go-reset  (back-end) "Send reset to BACK-END.")
+(defgeneric go-quit   (back-end) "Quit the BACK-END.")
 
 (provide 'go)