[elpa] 58/255: able to load and play through games w/sgf2el

[Eric Schulte]

eschulte pushed a commit to branch go
in repository elpa.

commit 7fb5907025d6a33cf4dcde5d2aa9e5cef237e630
Author: Eric Schulte <address@hidden>
Date:   Tue May 22 10:03:53 2012 -0400

    able to load and play through games w/sgf2el
---
 sgf-board.el |   54 ++++++++++++++++++++++++++++--------------------------
 sgf-tests.el |   17 +----------------
 sgf-util.el  |    6 +++++-
 sgf2el.el    |   38 ++++++++++++++++++++++++++------------
 4 files changed, 60 insertions(+), 55 deletions(-)

diff --git a/sgf-board.el b/sgf-board.el
index 9fe575d..86b9b08 100644
--- a/sgf-board.el
+++ b/sgf-board.el
@@ -74,8 +74,8 @@
                        (= 4 n))))))
       (let ((val (aref board (pos-to-index pos size))))
         (cond
-         ((equal val :w) white-piece)
-         ((equal val :b) black-piece)
+         ((equal val :W) white-piece)
+         ((equal val :B) black-piece)
          ((and (stringp val) (= 1 (length val)) val))
          (t  (if (and (emph (car pos)) (emph (cdr pos))) "+" ".")))))))
 
@@ -125,7 +125,7 @@
    "\n"
    (board-to-string *board*)
    "\n\n")
-  (let ((comment (second (assoc "C" (sgf-ref *sgf* *index*)))))
+  (let ((comment (aget (sgf-ref *sgf* *index*) :C)))
     (when comment
       (insert (make-string (+ 6 (* 2 (board-size *board*))) ?=)
               "\n\n")
@@ -137,13 +137,12 @@
     (with-current-buffer buffer
       (sgf-mode)
       (set (make-local-variable '*sgf*)   game)
-      (set (make-local-variable '*index*) '(0 1))
+      (set (make-local-variable '*index*) '(0))
       (let* ((root (sgf-ref *sgf* *index*))
-             (name (format (or (second (assoc "GN" root))
-                               (second (assoc "EV" root)))))
-             (size (aget "S" root)))
-        (unless size
-          (error "sgf: game has no associated size"))
+             (name (or (aget root :GN)
+                       (aget root :EV)))
+             (size (or (aget root :S) (aget root :SZ)
+                       (error "sgf: game has no associated size"))))
         (when name (rename-buffer name 'unique))
         (set (make-local-variable '*board*) (make-board size))
         (push (cons :pieces (board-to-pieces *board*))
@@ -170,9 +169,9 @@
 (defsetf sgf-ref set-sgf-ref)
 
 (defun get-create-pieces ()
-  (if (aget :pieces (sgf-ref *sgf* *index*))
+  (if (aget (sgf-ref *sgf* *index*) :pieces)
       (setf *board* (pieces-to-board
-                     (aget :pieces (sgf-ref *sgf* *index*))
+                     (aget (sgf-ref *sgf* *index*) :pieces)
                      (length *board*)))
     (clear-labels *board*)
     (apply-moves *board* (sgf-ref *sgf* *index*))
@@ -187,7 +186,7 @@
              (error "sgf: no more upwards moves."))
            (decf (car (last *index* 2)))
            (setq *board* (pieces-to-board
-                          (aget :pieces (sgf-ref *sgf* *index*))
+                          (aget (sgf-ref *sgf* *index*) :pieces)
                           (length *board*))))
     (update-display)))
 
@@ -209,9 +208,10 @@
              (update-display)
              (error "sgf: no more backwards moves."))
            (decf (car (last *index*)))
-           (setq *board* (pieces-to-board
-                          (aget :pieces (sgf-ref *sgf* *index*))
-                          (length *board*))))
+           (let ((pieces (aget (sgf-ref *sgf* *index*) :pieces)))
+             (setq *board* (pieces-to-board
+                            (if (listp pieces) pieces nil)
+                            (length *board*)))))
     (update-display)))
 
 (defun right (&optional num)
@@ -229,23 +229,25 @@
 ;;; Board manipulation functions
 (defun move-type (move)
   (cond
-   ((member (car move) '("B"  "W"))  :move)
-   ((member (car move) '("LB" "LW")) :label)))
+   ((member (car move) '(:B  :W))  :move)
+   ((member (car move) '(:LB :LW)) :label)))
 
 (defun apply-moves (board moves)
   (flet ((bset (val data)
-               (setf (aref board (pos-to-index (aget :pos data)
-                                               (board-size board)))
-                     (cond ((string= "B"  val)  :b)
-                           ((string= "W"  val)  :w)
-                           ((string= "LB" val) (aget :label data))
-                           ((string= "LW" val) (aget :label data))
-                           (t nil)))))
+           (let ((data (if (listp (car data)) data (list data))))
+             (setf (aref board (pos-to-index (aget data :pos)
+                                             (board-size board)))
+                   (case val
+                     (:B  :B)
+                     (:W  :W)
+                     (: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 (string= "B" (car move)) :b :w)))
+         (let ((color (if (equal :B (car move)) :B :W)))
            (remove-dead *board* (other-color color))
            (remove-dead *board* color)))
         (:label
@@ -254,7 +256,7 @@
 (defun clear-labels (board)
   (dotimes (point (length board))
     (when (aref board point)
-      (unless (member (aref board point) '(:b :w))
+      (unless (member (aref board point) '(:B :W))
         (setf (aref board point) nil)))))
 
 (defun stones-for (board color)
diff --git a/sgf-tests.el b/sgf-tests.el
index 94eb25e..0f83016 100644
--- a/sgf-tests.el
+++ b/sgf-tests.el
@@ -31,21 +31,6 @@
 (require 'sgf-board)
 (require 'ert)
 
-(ert-deftest sgf-parse-prop-tests ()
-  (flet ((should= (a b) (should (tree-equal a b :test #'string=))))
-    (should= (parse-props "B[pq]") '(("B" "pq")))
-    (should= (parse-props "GM[1]") '(("GM" "1")))
-    (should= (parse-props "GM[1]\nB[pq]\tB[pq]")
-             '(("GM" "1") ("B" "pq") ("B" "pq")))
-    (should (= (length (cdar (parse-props "TB[as][bs][cq][cr][ds][ep]")))
-               6))))
-
-(ert-deftest sgf-parse-multiple-small-nodes-test ()
-  (let* ((str ";B[pq];W[dd];B[pc];W[eq];B[cp];W[cm];B[do];W[hq];B[qn];W[cj]")
-         (nodes (parse-nodes str)))
-    (should (= (length nodes) 10))
-    (should (tree-equal (car nodes) '(("B" "pq")) :test #'string=))))
-
 (ert-deftest sgf-parse-one-large-node-test ()
   (let* ((str ";GM[1]FF[4]
                SZ[19]
@@ -114,7 +99,7 @@
   (let* ((joseki (read-from-file "sgf-files/3-4-joseki.sgf"))
          (root (car joseki))
          (rest (cdr joseki))
-         (board (make-board (aget "S" root)))
+         (board (make-board (aget root :S)))
          (string (concat "    A B C D E F G H J K L M N O P Q R S T\n"
                          " 19 . . . . . . . . . . . . . . . . . . . 19\n"
                          " 18 . . . . . . . . . . . . . . . . . . . 18\n"
diff --git a/sgf-util.el b/sgf-util.el
index 91f17b3..5c86295 100644
--- a/sgf-util.el
+++ b/sgf-util.el
@@ -26,7 +26,7 @@
 ;; Boston, MA 02110-1301, USA.
 
 ;;; Code:
-(defun aget (key list) (cdr (assoc key list)))
+(eval-when-compile (require 'cl))
 
 (defun range (a &optional b)
   (block nil
@@ -40,6 +40,10 @@
       (let ((res (number-sequence a b)))
         (if tmp (nreverse res) res)))))
 
+(defmacro until (test &rest body)
+  (declare (indent 1))
+  `(while (not ,test) ,@body))
+
 (defun other-color (color)
   (if (equal color :B) :W :B))
 
diff --git a/sgf2el.el b/sgf2el.el
index d11c7d6..5fa11d2 100644
--- a/sgf2el.el
+++ b/sgf2el.el
@@ -26,7 +26,9 @@
 ;; Boston, MA 02110-1301, USA.
 
 ;;; Code:
-(defvar prop-re "\\([[:alpha:]]+\\)\\(\\[[^\000]*?[^\\]?\\]\\)+")
+(eval-when-compile (require 'cl))
+
+(defvar prop-re "\\([[:alpha:]]+\\)\\(\\(\\[[^\000]*?[^\\]?\\]\\)+\\)")
 
 (defvar prop-val-re "\\[\\([^\000]*?[^\\]?\\)\\]")
 
@@ -70,17 +72,26 @@
   (interactive "r")
   (let ((start (copy-marker (or start (point-min))))
         (end   (copy-marker (or end   (point-max))))
-        (re    (format "\\(%s\\|%s\\)" prop-re ";")))
+        (re    (format "\\(%s\\|%s\\)" prop-re ";"))
+        last-node)
     (save-excursion (goto-char start)
       (while (re-search-forward re end t)
+        (message "1%S 2%S 3%S 4%S 5%S"
+                 (match-string 1)
+                 (match-string 2)
+                 (match-string 3)
+                 (match-string 4)
+                 (match-string 5))
         (if (string= (match-string 0) ";")
-            (replace-match ":node ")
+            (progn (replace-match (if last-node ")(" "("))
+                   (setq last-node t))
           (let* ((key (sgf2el-convert-prop-key (match-string 2)))
                  (val (sgf2el-convert-prop-vals key
                        (sgf2el-all-matches (match-string 3) prop-val-re 1)))
                  (rep (format "%S " (cons key (if (= 1 (length val))
                                                   (car val) val)))))
-            (replace-match rep nil 'literal)))))))
+            (replace-match rep nil 'literal))))
+      (when last-node (insert ")")))))
 
 (defun sgf2el (&optional sgf-buffer)
   "Convert the content of SGF-BUFFER to emacs-lisp in a new buffer."
@@ -90,6 +101,7 @@
          (sgf-str (with-current-buffer sgf-buffer (buffer-string))))
     (with-current-buffer buffer
       (insert sgf-str)
+      (goto-char (point-min))
       (sgf2el-region)
       (emacs-lisp-mode))
     (pop-to-buffer buffer)))
@@ -108,7 +120,7 @@
       (save-excursion
         (delete-region (point-min) (point-max))
         (insert (pp temp))))
-    (length temp)))
+    temp))
 
 
 ;;; Specific property converters
@@ -136,13 +148,15 @@
 (add-to-list 'sgf2el-special-properties (cons :W #'process-move))
 
 (defun process-label (label-args)
-  (mapcar (lambda (l-arg)
-            (if (string-match "\\([[:alpha:]]+\\):\\(.*\\)" l-arg)
-                (list
-                 (cons :label (match-string 2 l-arg))
-                 (cons :pos (process-position (match-string 1 l-arg))))
-                (error "sgf: malformed label %S" l-arg)))
-          label-args))
+  (let ((res (mapcar (lambda (l-arg)
+                       (if (string-match "\\([[:alpha:]]+\\):\\(.*\\)" l-arg)
+                           (list
+                            (cons :label (match-string 2 l-arg))
+                            (cons :pos (process-position
+                                        (match-string 1 l-arg))))
+                         (error "sgf: malformed label %S" l-arg)))
+                     label-args)))
+    (if (= 1 (length label-args)) (list res) res)))
 (add-to-list 'sgf2el-special-properties (cons :LB #'process-label))
 (add-to-list 'sgf2el-special-properties (cons :LW #'process-label))