;; Author: Thien-Thi Nguyen <ttn@gnu.org>
;; Version: 2.3.1
+;; Package-Requires: ((ascii-art-to-unicode "1.5"))
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
(defvar gnugo-board-mode-map nil
"Keymap for GNUGO Board mode.")
+(defvar gnugo-frolic-mode-map nil
+ "Keymap for GNUGO Frolic mode.")
+
(defvar gnugo-board-mode-hook nil
"Hook run when entering GNUGO Board mode.")
(eval-when-compile
(defvar gnugo-xpms nil))
+(defvar gnugo-frolic-parent-buffer nil)
+(defvar gnugo-frolic-origin nil)
+
;;;---------------------------------------------------------------------------
;;; Support functions
+(defsubst gnugo--mkht (&rest etc)
+ (apply 'make-hash-table :test 'eq etc))
+
(defsubst gnugo--compare-strings (s1 beg1 s2 beg2)
(compare-strings s1 beg1 nil s2 beg2 nil))
:sgf-gametree -- one of the gametrees in :sgf-collection
- :monkey -- vector of three elements:
+ :monkey -- vector of two elements:
MEM, a pointer to one of the branches in the gametree;
- BIDX, the index of the \"current branch\"; and
- COUNT, the number of moves from the beginning of the game
+ BIDX, the index of the \"current branch\"
:gnugo-color -- either \"black\" or \"white\"
:user-color
See `gnugo-put'."
(gethash key gnugo-state))
+(defsubst gnugo--tree-mnum (tree)
+ (aref tree 1))
+
+(defsubst gnugo--tree-ends (tree)
+ (aref tree 0))
+
+(defsubst gnugo--set-tree-ends (tree ls)
+ (aset tree 0 (apply 'vector ls))
+ (gnugo--tree-ends tree))
+
(defun gnugo-describe-internal-properties ()
"Pretty-print `gnugo-state' properties in another buffer.
Handle the big, slow-to-render, and/or uninteresting ones specially."
(interactive)
(let ((buf (current-buffer))
(d (gnugo-get :diamond))
- (acc (loop for key being the hash-keys of gnugo-state
- using (hash-values val)
- collect (cons key
- (case key
- ((:xpms :local-xpms)
- (format "hash: %X (%d images)"
- (sxhash val)
- (length val)))
- (:sgf-collection
- (length val))
- (:monkey
- (let ((mem (aref val 0)))
- (list (aref val 1)
- (aref val 2)
- (car mem))))
- (t val))))))
+ acc)
+ (loop for key being the hash-keys of gnugo-state
+ using (hash-values val)
+ do (push (cons key
+ (case key
+ ((:xpms :local-xpms)
+ (format "hash: %X (%d images)"
+ (sxhash val)
+ (length val)))
+ (:sgf-collection
+ (length val))
+ (:sgf-gametree
+ (list (hash-table-count
+ (gnugo--tree-mnum val))
+ (gnugo--tree-ends val)))
+ (:monkey
+ (let ((mem (aref val 0)))
+ (list (aref val 1)
+ (car mem))))
+ (t val)))
+ acc))
(switch-to-buffer (get-buffer-create
(format "%s*GNUGO Board Properties*"
(gnugo-get :diamond))))
(emacs-lisp-mode)
(setq truncate-lines t)
(save-excursion
- (let ((standard-output (current-buffer)))
- (pp (reverse acc)))
+ (pp acc
+ (current-buffer))
(goto-char (point-min))
(let ((rx (format "overlay from \\([0-9]+\\).+\n%s\\s-+"
(if (string= "" d)
(defun gnugo-board-buffer-p (&optional buffer)
"Return non-nil if BUFFER is a GNUGO Board buffer."
- (with-current-buffer (or buffer (current-buffer)) gnugo-state))
+ (eq 'gnugo-board-mode
+ (buffer-local-value
+ 'major-mode
+ (or buffer (current-buffer)))))
(defun gnugo-board-user-play-ok-p (&optional buffer)
"Return non-nil if BUFFER is a GNUGO Board buffer ready for a user move."
(when (gnugo-get :waitingp)
(user-error "Not your turn yet -- please wait for \"\(%s to play\)\""
(gnugo-get :user-color)))
- (when (and (gnugo-get :game-over) in-progress-p)
+ (when (and in-progress-p (gnugo-get :game-over))
(user-error "Sorry, game over")))
(defun gnugo-sentinel (proc string)
(split-string (apply 'gnugo-query message-format args)))
(defun gnugo--root-node (&optional tree)
- (gnugo/sgf-root-node (or tree (gnugo-get :sgf-gametree))))
+ (aref (or tree (gnugo-get :sgf-gametree))
+ 2))
(defsubst gnugo--root-prop (prop &optional tree)
(cdr (assq prop (gnugo--root-node tree))))
(or (assq :B node)
(assq :W node)))
-(defun gnugo--as-pos-func (size)
- (lexical-let ((size size))
+(defun gnugo--as-pos-func ()
+ (lexical-let ((size (gnugo-get :SZ)))
;; rv
(lambda (cc)
(if (string= "" cc)
(interactive "P")
(let* ((monkey (gnugo-get :monkey))
(mem (aref monkey 0))
- (as-pos (gnugo--as-pos-func (gnugo-get :SZ)))
- col
+ (as-pos (gnugo--as-pos-func))
acc node mprop move)
- (cl-labels
+ (cl-flet*
((as-pos-maybe (x) (if (string= "resign" x)
x
(funcall as-pos x)))
(`nil (finish nil))
(`car (car (nn)))
(`cadr (nn) (car (nn)))
- (`count (aref monkey 2))
+ (`count (gethash (car mem) (gnugo--tree-mnum
+ (gnugo-get :sgf-gametree))))
(`two (nn) (nn) acc)
(_ nil)))))
+(define-derived-mode gnugo-frolic-mode special-mode "GNUGO Frolic"
+ "A special mode for manipulating a GNUGO gametree.
+
+\\{gnugo-frolic-mode-map}"
+ (setq truncate-lines t)
+ (buffer-disable-undo))
+
+(defun gnugo-frolic-quit ()
+ "Kill GNUGO Frolic buffer and switch to its parent buffer."
+ (interactive)
+ (let ((bye (current-buffer)))
+ (switch-to-buffer (when (buffer-live-p gnugo-frolic-parent-buffer)
+ gnugo-frolic-parent-buffer))
+ (kill-buffer bye)))
+
+(defun gnugo-frolic-return-to-origin ()
+ "Move point to the board's current position."
+ (interactive)
+ (if (not gnugo-frolic-origin)
+ (message "No origin")
+ (goto-char gnugo-frolic-origin)
+ (recenter (- (count-lines (line-beginning-position)
+ (point-max))))))
+
(defun gnugo-frolic-in-the-leaves ()
"Display the game tree in a *GNUGO Frolic* buffer.
This looks something like:
to indicate the branches. Branch 0 is the \"main line\".
Point (* in this example) indicates the current position,
and moves not actually on the game tree (e.g., E7, branch 3)
-are dimmed. The buffer is in View minor mode."
+are dimmed. Type \\[describe-mode] in that buffer for details."
(interactive)
(let* ((buf (get-buffer-create (concat (gnugo-get :diamond)
"*GNUGO Frolic*")))
+ (from (or gnugo-frolic-parent-buffer
+ (current-buffer)))
;; todo: use defface once we finally succumb to ‘customize’
(dimmed-node-face (list :inherit 'default
:foreground "gray50"))
(tree (gnugo-get :sgf-gametree))
- (seen (make-hash-table :test 'eq))
- (soil (make-hash-table :test 'eq))
- (width (length tree))
+ (ends (copy-sequence (gnugo--tree-ends tree)))
+ (mnum (gnugo--tree-mnum tree))
+ (seen (gnugo--mkht))
+ (soil (gnugo--mkht))
+ (width (length ends))
(lanes (number-sequence 0 (1- width)))
(monkey (gnugo-get :monkey))
- (as-pos (gnugo--as-pos-func (gnugo-get :SZ)))
+ (as-pos (gnugo--as-pos-func))
(at (car (aref monkey 0)))
(bidx (aref monkey 1))
- (max-move-num (aref monkey 2))
- (eert (make-vector width nil))
+ (valid (map 'vector (lambda (end)
+ (gethash (car end) mnum))
+ ends))
+ (max-move-num (apply 'max (append valid nil)))
+ (inhibit-read-only t)
finish)
(cl-flet
((on (node)
(gethash node seen))
(emph (s face)
(propertize s 'face face))
- (fsi (fmt &rest args)
- (insert (apply 'format fmt args))))
+ (fsi (properties fmt &rest args)
+ (insert (apply 'propertize
+ (apply 'format fmt args)
+ properties))))
;; breathe in
- (let ((order (make-hash-table :test 'eq))
- (monkey-on-main-line (zerop bidx))
- fixup)
- ;; monkey knows a lot
- (loop with move-num = (1+ max-move-num)
- with acc
- for node in (aref monkey 0)
- do (puthash node bidx seen)
- if (gnugo--move-prop node)
- do (progn
- (push node acc)
- (puthash node (decf move-num) order))
- finally do (progn
- (unless monkey-on-main-line
- (setq fixup (apply 'vector acc)))
- (aset eert bidx acc)))
- ;; but monkey does not know everything
- (loop
- for bx below width
- do (loop
- with (bef acc node fork cur)
- for ls on (aref tree bx)
- do (if (setq node (car ls)
- fork (on node))
- (cl-flet
- ((link (other)
- (push other (gethash node soil))))
- (let ((move-num (gethash node order)))
- (when (< bx fork)
- (assert (and (not monkey-on-main-line)
- (= fork bidx)))
- (loop for old in ls
- while (< bx (on old))
- do (puthash old bx seen))
- (when (< move-num (length fixup))
- (link (aref fixup move-num))))
- ;; ugh, wasteful
- (when (setq bef (copy-sequence (aref eert fork)))
- (setcdr (nthcdr (1- move-num) bef)
- acc))
- (aset eert bx (or bef acc))
- (dolist (node acc)
- (puthash node (incf move-num)
- order))
- (setq max-move-num (max max-move-num
- move-num))
- (when acc
- (link (car acc)))))
- (puthash node bx seen)
- (when (gnugo--move-prop node)
- (push node acc)))
- until fork)))
+ (loop
+ for bx below width
+ do (loop
+ with fork
+ for node in (aref ends bx)
+ do (if (setq fork (on node))
+ (cl-flet
+ ((tip-p (bix)
+ ;; todo: ignore non-"move" nodes
+ (eq node (car (aref ends bix))))
+ (link (other)
+ (pushnew other (gethash node soil))))
+ (unless (tip-p bx)
+ (unless (tip-p fork)
+ (link fork))
+ (link bx)))
+ (puthash node bx seen))
+ until fork))
;; breathe out
(switch-to-buffer buf)
- (when view-mode
- (view-mode -1))
- (buffer-disable-undo)
+ (gnugo-frolic-mode)
(erase-buffer)
(setq header-line-format
- (concat (make-string 11 ?\s)
- (mapconcat (lambda (n)
- (format "%-5s" n))
- lanes
- " ")))
+ (lexical-let ((full (concat
+ (make-string 11 ?\s)
+ (mapconcat (lambda (n)
+ (format "%-5s" n))
+ lanes
+ " "))))
+ `((:eval
+ (funcall
+ ,(lambda ()
+ (cl-flet
+ ((sp (w) (propertize
+ " " 'display
+ `(space :width ,w))))
+ (concat
+ (when (eq 'left scroll-bar-mode)
+ (let ((w (or scroll-bar-width
+ (frame-parameter
+ nil 'scroll-bar-width)))
+ (cw (frame-char-width)))
+ (sp (if w
+ (/ w cw)
+ 2))))
+ (let ((fc (fringe-columns 'left t)))
+ (unless (zerop fc)
+ (sp fc)))
+ (condition-case nil
+ (substring full (window-hscroll))
+ (error ""))))))))))
+ (set (make-local-variable 'gnugo-frolic-parent-buffer) from)
+ (set (make-local-variable 'gnugo-state)
+ (buffer-local-value 'gnugo-state from))
(loop
+ with props
for n ; move number
- from 1 upto max-move-num
+ from max-move-num downto 1
+ do (setq props (list 'n n))
do
(loop
with (move forks br)
- initially (fsi "%3d %s -- "
- n (aref ["W" "B"] (logand 1 n)))
+ initially (progn
+ (goto-char (point-min))
+ (fsi props
+ "%3d %s -- "
+ n (aref ["W" "B"] (logand 1 n))))
for bx below width
- do (let* ((node (pop (aref eert bx)))
+ do (let* ((node (unless (< (aref valid bx) n)
+ ;; todo: ignore non-"move" nodes
+ (pop (aref ends bx))))
(ok (when node
(= bx (on node))))
(s (cond ((not node) "")
((not (setq move (gnugo--move-prop node))) "-")
(t (funcall as-pos (cdr move))))))
- ;; todo: move this into "breathe in"
(when (and ok (setq br (gethash node soil)))
- (setq br (delq bx (mapcar #'on br)))
- (when (and br (car (aref eert bx)))
- (push bx br))
- ;; do not point w/ a fist
- (when br
- (push (cons bx (sort br '<))
- forks)))
- (fsi " %-5s"
+ (push (cons bx (sort br '<))
+ forks))
+ (fsi (list* 'bx bx props)
+ " %-5s"
(cond ((and (eq at node)
(or ok (= bx bidx)))
(when (= bx bidx)
- (setq finish (point)))
+ (setq finish (point-marker)))
(emph s (list :inherit 'default
:foreground (frame-parameter
nil 'cursor-color))))
(emph s dimmed-node-face))
(t s))))
finally do
- (when (progn (newline)
+ (when (progn (fsi props "\n")
(setq forks (nreverse forks)))
(let* ((margin (make-string 11 ?\s))
- (count (length forks))
(heads (mapcar #'car forks))
(tails (mapcar #'cdr forks)))
(cl-flet*
"\n"))
(push one bef)))
(edge (apply 'append tails))
- ;; NB: This requires ascii-art-to-unicode.el 1.5 or later.
(aa2u (line-beginning-position
(- (1+ (length forks))))
(point))))))))
(when finish
- (goto-char finish)
- (recenter (- (count-lines (line-beginning-position) (point-max)))))
- (view-mode 1)))
+ (set (make-local-variable 'gnugo-frolic-origin) finish)
+ (gnugo-frolic-return-to-origin))))
+
+(defun gnugo--awake (how)
+ ;; Valid HOW elements:
+ ;; require-valid-branch
+ ;; (line . numeric)
+ ;; (line . move-string)
+ ;; Invalid elements blissfully ignored. :-D
+ (let* ((tree (gnugo-get :sgf-gametree))
+ (ends (gnugo--tree-ends tree))
+ (width (length ends))
+ (monkey (gnugo-get :monkey))
+ (line (case (cdr (assq 'line how))
+ (numeric
+ (count-lines (point-min) (line-beginning-position)))
+ (move-string
+ (save-excursion
+ (when (re-search-backward "^ *[0-9]+ [BW]" nil t)
+ (match-string 0))))
+ (t nil)))
+ (col (current-column))
+ (a (unless (> 10 col)
+ (let ((try (/ (- col 10)
+ 6)))
+ (unless (<= width try)
+ try))))
+ (rv (list a)))
+ (when (memq 'require-valid-branch how)
+ (unless a
+ (user-error "No branch here")))
+ (loop with omit = (cdr (assq 'omit how))
+ for (name . value) in `((line . ,line)
+ (bidx . ,(aref monkey 1))
+ (monkey . ,monkey)
+ (width . ,width)
+ (ends . ,ends)
+ (tree . ,tree))
+ do (unless (memq name omit)
+ (push value rv)))
+ rv))
+
+(defmacro gnugo--awakened (how &rest body)
+ (declare (indent 1))
+ `(destructuring-bind ,(loop with omit = (cdr (assq 'omit how))
+ with ls = (list 'a)
+ for name in '(line bidx monkey
+ width ends
+ tree)
+ do (unless (memq name omit)
+ (push name ls))
+ finally return ls)
+ (gnugo--awake ',how)
+ ,@body))
+
+(defsubst gnugo--move-to-bcol (bidx)
+ (move-to-column (+ 10 (* 6 bidx))))
+
+(defun gnugo--swiz (direction &optional blunt)
+ (gnugo--awakened (require-valid-branch
+ (omit tree)
+ (line . numeric))
+ (let* ((b (cond ((numberp blunt)
+ (unless (and (< -1 blunt)
+ (< blunt width))
+ (user-error "No such branch: %s" blunt))
+ blunt)
+ (t (mod (+ direction a) width))))
+ (flit (if blunt (lambda (n)
+ (cond ((= n a) b)
+ ((= n b) a)
+ (t n)))
+ (lambda (n)
+ (mod (+ direction n) width))))
+ (was (copy-sequence ends))
+ (new-bidx (funcall flit bidx)))
+ (loop for bx below width
+ do (aset ends (funcall flit bx)
+ (aref was bx)))
+ (unless (= new-bidx bidx)
+ (aset monkey 1 new-bidx))
+ (gnugo-frolic-in-the-leaves)
+ (goto-char (point-min))
+ (forward-line line)
+ (gnugo--move-to-bcol b))))
+
+(defun gnugo-frolic-exchange-left ()
+ "Exchange the current branch with the one to its left."
+ (interactive)
+ (gnugo--swiz -1 t))
+
+(defun gnugo-frolic-rotate-left ()
+ "Rotate all branches left."
+ (interactive)
+ (gnugo--swiz -1))
+
+(defun gnugo-frolic-exchange-right ()
+ "Exchange the current branch with the one to its right."
+ (interactive)
+ (gnugo--swiz 1 t))
+
+(defun gnugo-frolic-rotate-right ()
+ "Rotate all branches right."
+ (interactive)
+ (gnugo--swiz 1))
+
+(defun gnugo-frolic-set-as-main-line ()
+ "Make the current branch the main line."
+ (interactive)
+ (gnugo--swiz nil 0))
+
+(defun gnugo-frolic-prune-branch ()
+ "Remove the current branch from the gametree.
+This fails if there is only one branch in the tree.
+This fails if the monkey is on the current branch
+\(a restriction that will probably be lifted Real Soon Now\)."
+ (interactive)
+ (gnugo--awakened (require-valid-branch
+ (line . move-string))
+ ;; todo: define meaningful eviction semantics; remove restriction
+ (when (= a bidx)
+ (user-error "Cannot prune with monkey on branch"))
+ (when (= 1 width)
+ (user-error "Cannot prune last remaining branch"))
+ (let ((new (append ends nil)))
+ ;; Explicit ignorance avoids byte-compiler warning.
+ (ignore (pop (nthcdr a new)))
+ (gnugo--set-tree-ends tree new))
+ (when (< a bidx)
+ (aset monkey 1 (decf bidx)))
+ (gnugo-frolic-in-the-leaves)
+ (when line
+ (goto-char (point-min))
+ (search-forward line)
+ (gnugo--move-to-bcol (min a (- width 2))))))
+
+(defun gnugo--sideways (backwards n)
+ (gnugo--awakened ((omit tree ends monkey bidx line))
+ (gnugo--move-to-bcol (mod (if backwards
+ (- (or a width) n)
+ (+ (or a -1) n))
+ width))))
+
+(defun gnugo-frolic-backward-branch (&optional n)
+ "Move backward N (default 1) branches."
+ (interactive "p")
+ (gnugo--sideways t n))
+
+(defun gnugo-frolic-forward-branch (&optional n)
+ "Move forward N (default 1) branches."
+ (interactive "p")
+ (gnugo--sideways nil n))
+
+(defun gnugo--vertical (n direction)
+ (when (> 0 n)
+ (setq n (- n)
+ direction (- direction)))
+ (gnugo--awakened ((line . numeric)
+ (omit tree ends width monkey bidx))
+ (let ((stop (if (> 0 direction)
+ 0
+ (max 0 (1- (count-lines (point-min)
+ (point-max))))))
+ (col (unless a
+ (current-column))))
+ (loop while (not (= line stop))
+ do (loop do (progn
+ (forward-line direction)
+ (incf line direction))
+ until (get-text-property (point) 'n))
+ until (zerop (decf n)))
+ (if a
+ (gnugo--move-to-bcol a)
+ (move-to-column col)))))
+
+(defun gnugo-frolic-previous-move (&optional n)
+ "Move to the Nth (default 1) previous move."
+ (interactive "p")
+ (gnugo--vertical n -1))
+
+(defun gnugo-frolic-next-move (&optional n)
+ "Move to the Nth (default 1) next move."
+ (interactive "p")
+ (gnugo--vertical n 1))
(defun gnugo-boss-is-near ()
"Do `bury-buffer' until the current one is not a GNU Board."
(defsubst gnugo--passp (string)
(string= "PASS" string))
-(defsubst gnugo--no-regrets (monkey tree)
- (eq (aref tree (aref monkey 1))
+(defsubst gnugo--no-regrets (monkey ends)
+ (eq (aref ends (aref monkey 1))
(aref monkey 0)))
+(defun gnugo--as-cc-func ()
+ (lexical-let ((size (gnugo-get :SZ)))
+ (lambda (pos)
+ (let* ((col (aref pos 0))
+ (one (+ ?a (- col (if (< ?H col) 1 0) ?A)))
+ (two (+ ?a (- size (string-to-number
+ (substring pos 1))))))
+ (format "%c%c" one two)))))
+
(defun gnugo-note (property value &optional mogrifyp)
(when mogrifyp
- (let ((sz (gnugo-get :SZ)))
- (cl-labels
+ (let ((as-cc (gnugo--as-cc-func)))
+ (cl-flet
((mog (pos) (if (gnugo--passp pos)
""
- (let* ((col (aref pos 0))
- (one (+ ?a (- col (if (< ?H col) 1 0) ?A)))
- (two (+ ?a (- sz (string-to-number
- (substring pos 1))))))
- (format "%c%c" one two)))))
+ (funcall as-cc pos))))
(setq value (if (consp value)
(mapcar #'mog value)
(mog value))))))
(let* ((pair (cons property value))
(fruit (list pair))
(monkey (gnugo-get :monkey))
- (mem (aref monkey 0)))
+ (mem (aref monkey 0))
+ (tip (car mem)))
(if (memq property '(:B :W))
- (let ((tree (gnugo-get :sgf-gametree))
- (bidx (aref monkey 1)))
+ (let* ((tree (gnugo-get :sgf-gametree))
+ (ends (gnugo--tree-ends tree))
+ (mnum (gnugo--tree-mnum tree))
+ (count (length ends))
+ (tip-move-num (gethash tip mnum))
+ (bidx (aref monkey 1)))
;; Detect déjà-vu. That is, when placing "A", avoid:
;;
;; X---Y---A new
;; \
;; --B old
;;
- ;; This presumes ‘bidx’ is 0 (main line) and that
- ;; all growth should occur on the main line.
- (cl-labels
- ((continue-on (bx)
- (rotatef (aref tree bidx)
- (aref tree bx))))
- ;; ugh, quadratic
- (loop
- with count = (length tree)
- with (bx previous)
- for i
- ;; Start with latest / highest likelihood for hit.
- ;; todo: prune unfeasible candidates
- from 0 above (- count)
- if (setq bx (mod i count)
- previous
- ;; todo: early termination based on move number
- (loop for m on (aref tree bx)
- if (eq mem (cdr m))
- return
- (when (equal pair (assoc property (car m)))
- m)
- finally return
- nil))
- ;; yes => follow
- return
- (progn
- ;; (message "déjà-vu! %d follows %d" bidx bx)
- (unless (= bidx bx)
- (continue-on bx))
- (setq mem previous))
- ;; no => construct
- finally do
- (progn
- ;; (message "new %d" bidx)
- (unless (gnugo--no-regrets monkey tree)
- ;; <grumble grumble> SGF sez "move" node in the root
- ;; position of a (sub-)gametree is "bad style". :-/
- (let ((where (memq tree (gnugo-get :sgf-collection))))
- (setq tree (apply 'vector (append tree (list mem))))
- (continue-on count)
- (gnugo-put :sgf-gametree tree)
- (setcar where tree)))
- (push fruit mem)
- (aset tree bidx mem))))
- (setf (aref monkey 0) mem)
- (incf (aref monkey 2)))
- (setcdr (last (car mem)) fruit))))
+ ;; This linear search loses for multiple ‘old’ w/ "A",
+ ;; a very unusual (but not invalid, sigh) situation.
+ (loop
+ with (bx previous)
+ for i
+ ;; Start with latest / highest likelihood for hit.
+ ;; (See "to the right" comment, below.)
+ from (if (gnugo--no-regrets monkey ends)
+ 1
+ 0)
+ below count
+ if (setq bx (mod (+ bidx i) count)
+ previous
+ (loop with node
+ for m on (aref ends bx)
+ while (< tip-move-num
+ (gethash (setq node (car m))
+ mnum))
+ if (eq mem (cdr m))
+ return
+ (when (equal pair (assoc property node))
+ m)
+ finally return
+ nil))
+ ;; yes => follow
+ return
+ (progn
+ (unless (= bidx bx)
+ (rotatef (aref ends bidx)
+ (aref ends bx)))
+ (setq mem previous))
+ ;; no => construct
+ finally do
+ (progn
+ (unless (gnugo--no-regrets monkey ends)
+ (setq ends (gnugo--set-tree-ends
+ tree (let ((ls (append ends nil)))
+ ;; copy old to the right of new
+ (push mem (nthcdr bidx ls))
+ ls))))
+ (puthash fruit (1+ (gethash tip mnum)) mnum)
+ (push fruit mem)
+ (aset ends bidx mem)))
+ (setf (aref monkey 0) mem))
+ (setcdr (last tip) fruit))))
(defun gnugo-close-game (end-time resign)
(gnugo-put :game-end-time end-time)
(if (or (eq t resign)
(and (stringp resign)
(string-match "[BW][+][Rr]esign" resign)))
- (cl-labels
+ (cl-flet
((ls (color) (mapcar
(lambda (x)
(cons (list color)
(setcdr now (cons group (cdr now)))
;; disabled permanently -- too wrong
(when nil
- (cl-labels
+ (cl-flet
((populate (group)
(let ((color (caar group)))
(dolist (stone (cdr group))
(user-error "Cannot load a directory (try a filename with extension .sgf)"))
(let (ans play wait samep coll tree)
;; problem: requiring GTP `loadsgf' complicates network subproc support;
- ;; todo: skip it altogether when confident about `gnugo/sgf-read-file'
+ ;; todo: skip it altogether when confident about `gnugo/sgf-create'
(unless (= ?= (aref (setq ans (gnugo--q "loadsgf %s"
(expand-file-name filename)))
0))
(unless samep
(gnugo-put :gnugo-color wait)
(gnugo-put :user-color play))
- (setq coll (gnugo/sgf-read-file filename)
+ (setq coll (gnugo/sgf-create filename)
tree (nth (let ((n (length coll)))
;; This is better:
;; (if (= 1 n)
coll))
(gnugo-put :sgf-collection coll)
(gnugo-put :sgf-gametree tree)
+ (gnugo-put :monkey (vector (aref (gnugo--tree-ends tree) 0) 0))
;; This is deliberately undocumented for now.
(gnugo--SZ! (gnugo--root-prop :SZ tree))
- (let* ((mem (aref tree 0))
- game-over)
- (gnugo-put :monkey
- (vector mem 0 (loop for node in mem
- count (gnugo--move-prop node))))
+ (let (game-over)
(gnugo-put :game-over
(setq game-over
(or (gnugo--root-prop :RE tree)
(user-color (gnugo-get :user-color))
(monkey (gnugo-get :monkey))
(tree (gnugo-get :sgf-gametree))
- (remorseful (not (gnugo--no-regrets monkey tree)))
+ (ends (gnugo--tree-ends tree))
+ (remorseful (not (gnugo--no-regrets monkey ends)))
done ans)
(cond ((numberp spec)
(setq n (if (zerop spec)
(setq ans (gnugo--q "undo"))
(unless (= ?= (aref ans 0))
(user-error "%s" ans))
- (decf (aref monkey 2))
(pop (aref monkey 0))
(gnugo-put :last-mover (gnugo-other (gnugo-get :last-mover)))
(gnugo-merge-showboard-results) ; all
(gnugo-get :center-position)))
(gnugo-refresh t)
(unless (or keep remorseful)
- (aset tree (aref monkey 1) (aref monkey 0)))
+ (aset ends (aref monkey 1) (aref monkey 0)))
(when (and ulastp (not noalt))
(gnugo-get-move (gnugo-get :gnugo-color))))))
0)
nil t))
+(defun gnugo-okay (&optional full)
+ "Redo a pair of undone moves.
+Prefix arg means to redo all the undone moves."
+ (interactive "P")
+ (gnugo-gate)
+ (let* ((tree (gnugo-get :sgf-gametree))
+ (ends (gnugo--tree-ends tree))
+ (monkey (gnugo-get :monkey)))
+ (if (gnugo--no-regrets monkey ends)
+ (message "Oop ack!")
+ (let* ((as-pos (gnugo--as-pos-func))
+ (mnum (gnugo--tree-mnum tree))
+ (mem (aref monkey 0))
+ (bidx (aref monkey 1))
+ (end (aref ends bidx))
+ (ucolor (gnugo-get :user-color))
+ (gcolor (gnugo-other ucolor))
+ (uprop (if (gnugo--blackp ucolor)
+ :B :W)))
+ (cl-flet ((mvno (node) (gethash node mnum)))
+ (loop
+ with ok = (if full
+ (mvno (car end))
+ (+ 2 (mvno (car mem))))
+ with (node move todo)
+ for ls on end
+ do (progn
+ (setq node (car ls)
+ move (gnugo--move-prop node))
+ (when (and move (>= ok (mvno node)))
+ (let ((userp (eq uprop (car move))))
+ (push (list (if userp ucolor gcolor)
+ userp
+ (funcall as-pos (cdr move)))
+ todo))))
+ until (eq mem (cdr ls))
+ finally do
+ (loop
+ for (color userp pos) in todo
+ do (let* ((move (format "play %s %s" color pos))
+ (accept (gnugo--q move)))
+ (unless (= ?= (aref accept 0))
+ (user-error "%s" accept))
+ (gnugo-push-move userp pos)
+ (gnugo-refresh)
+ (redisplay)))))))))
+
(defun gnugo-display-final-score ()
"Display final score and other info in another buffer (when game over).
If the game is still ongoing, Emacs asks if you wish to stop play (by
(y-or-n-p "Game still in play. Stop play now? ")))
(user-error "Sorry, game still in play"))
(unless game-over
- (cl-labels
+ (cl-flet
((pass (userp)
(message "Playing PASS for %s ..."
(gnugo-get (if userp :user-color :gnugo-color)))
(end (gnugo-get :game-end-time)))
(when end
(push "\n" blurb)
- (cl-labels
+ (cl-flet
((yep (pretty moment)
(push (format-time-string
(concat pretty ": %Y-%m-%d %H:%M:%S %z\n")
(save-excursion (gnugo-refresh)))
(defun gnugo-describe-position ()
- "Display the board position under cursor in the echo area."
+ "Display the board position under cursor in the echo area.
+If there a stone at that position, also display its move number."
(interactive)
- (message "%s" (gnugo-position)))
+ (let ((pos (gnugo-position)) ; do first (can throw)
+ (color (case (following-char)
+ (?X :B)
+ (?O :W))))
+ (message
+ "%s%s" pos
+ (or (when color
+ (loop
+ with monkey = (gnugo-get :monkey)
+ with tree = (gnugo-get :sgf-gametree)
+ with mnum = (gnugo--tree-mnum tree)
+ with as-cc = (gnugo--as-cc-func)
+ with fruit = (cons color (funcall as-cc pos))
+ for node in (aref monkey 0)
+ if (member fruit node)
+ return
+ (format " (move %d)"
+ (gethash node mnum))
+ finally return
+ nil))
+ ""))))
(defun gnugo-switch-to-another ()
"Switch to another GNU Go game buffer (if any)."
truncate-lines t)
(add-hook 'kill-buffer-hook 'gnugo-cleanup nil t)
(set (make-local-variable 'gnugo-state)
- (make-hash-table :size (1- 42) :test 'eq))
+ (gnugo--mkht :size (1- 42)))
(add-to-invisibility-spec :nogrid)
(mapc (lambda (prop)
(gnugo-put prop nil)) ; todo: separate display/game aspects;
'gnugo-option-history))
proc
board-size user-color handicap komi minus-l infile)
- (loop for (var default opt &optional rx)
+ (loop for (var default opt rx)
in '((board-size 19 "--boardsize")
(user-color "black" "--color" "\\(black\\|white\\)")
(handicap 0 "--handicap")
(gnugo-put :rparen-ov (let ((ov (make-overlay 1 1)))
(overlay-put ov 'display ")")
ov))
- (let ((tree (vector (list (list '(:FF . 4) '(:GM . 1))))))
+ (let* ((coll (gnugo/sgf-create "(;FF[4]GM[1])" t))
+ (tree (car coll)))
(gnugo-put :sgf-gametree tree)
- (gnugo-put :sgf-collection (list tree))
- (gnugo-put :monkey (vector (aref tree 0) 0 0)))
+ (gnugo-put :sgf-collection coll)
+ (gnugo-put :monkey (vector (aref (gnugo--tree-ends tree) 0) 0)))
(gnugo--SZ! board-size)
(loop with gb = (gnugo--blackp (gnugo-other user-color))
- for (property value &optional mogrifyp) in
+ for (property value mogrifyp) in
`((:SZ ,board-size)
(:DT ,(format-time-string "%Y-%m-%d"))
(:RU ,(if (string-match "--chinese-rules" args)
;;;---------------------------------------------------------------------------
;;; Load-time actions
+(unless gnugo-frolic-mode-map
+ (setq gnugo-frolic-mode-map (make-sparse-keymap))
+ (suppress-keymap gnugo-frolic-mode-map)
+ (mapc (lambda (pair)
+ (define-key gnugo-frolic-mode-map (car pair) (cdr pair)))
+ '(("q" . gnugo-frolic-quit)
+ ("C" . gnugo-frolic-quit) ; like ‘View-kill-and-leave’
+ ("\C-b" . gnugo-frolic-backward-branch)
+ ("\C-f" . gnugo-frolic-forward-branch)
+ ("\C-p" . gnugo-frolic-previous-move)
+ ("\C-n" . gnugo-frolic-next-move)
+ ("j" . gnugo-frolic-exchange-left)
+ ("J" . gnugo-frolic-rotate-left)
+ ("k" . gnugo-frolic-exchange-right)
+ ("K" . gnugo-frolic-rotate-right)
+ ("\C-m" . gnugo-frolic-set-as-main-line)
+ ("\C-\M-p" . gnugo-frolic-prune-branch)
+ ("o" . gnugo-frolic-return-to-origin))))
+
(unless gnugo-board-mode-map
(setq gnugo-board-mode-map (make-sparse-keymap))
(suppress-keymap gnugo-board-mode-map)
("u" . gnugo-undo-two-moves)
("\C-?" . gnugo-undo-two-moves)
("o" . gnugo-oops)
+ ("O" . gnugo-okay)
("\C-l" . gnugo-refresh)
("\M-_" . gnugo-boss-is-near)
("_" . gnugo-boss-is-near)
("\C-c\C-p" . gnugo-describe-internal-properties))))
(unless (get 'help :gnugo-gtp-command-spec)
- (cl-labels
+ (cl-flet*
((sget (x) (get x :gnugo-gtp-command-spec))
(jam (cmd prop val) (put cmd :gnugo-gtp-command-spec
(plist-put (sget cmd) prop val)))
(info "(gnugo)GTP command reference")
(when sel (setq sel (intern (car sel))))
(let (buffer-read-only pad cur spec output found)
- (cl-labels
+ (cl-flet
((note (s) (insert pad "[NOTE: gnugo.el " s ".]\n")))
(goto-char (point-min))
(save-excursion
(t (message "(no such command: %s)" sel)))))
(deffull final_score
+ ;; Explicit ignorance avoids byte-compiler warning.
+ (ignore sel)
(gnugo-display-final-score))
(defgtp '(boardsize
;; - added: AP AR AS DD IP IY LN OT PM SE SQ ST SU VW
"List of SGF[4] properties, each of the form (PROP NAME CONTEXT SPEC...).")
-(defun gnugo/sgf-root-node (tree)
- (car (last (aref tree
- ;; Any bidx is fine, but we choose the last one since
- ;; usually the main line (bidx 0) is the longest.
- ;; Ugh, heuristics for the sake of performance. :-/
- (1- (length tree))))))
+(defun gnugo/sgf-create (file-or-data &optional data-p)
+ "Return the SGF[4] collection parsed from FILE-OR-DATA.
+FILE-OR-DATA is a file name or SGF[4] data.
+Optional arg DATA-P non-nil means FILE-OR-DATA is
+a string containing SGF[4] data.
+A collection is a list of gametrees, each a vector of four elements:
+
+ ENDS -- a vector of node lists, with shared tails
+ (last element of all the lists is the root node)
+
+ MNUM -- `eq' hash: node to move numbers; non-\"move\" nodes
+ have a move number of the previous \"move\" node (or zero)
-(defun gnugo/sgf-read-file (filename)
- "Return the collection (list) of gametrees in SGF[4] file FILENAME."
+ ROOT -- the root node"
+ ;; Arg names inspired by `create-image', despite -P being frowned upon.
(let ((keywords (or (get 'gnugo/sgf-*r4-properties* :keywords)
(put 'gnugo/sgf-*r4-properties* :keywords
(mapcar (lambda (full)
SZ)
(cl-labels
((sw () (skip-chars-forward " \t\n"))
- (x (end) (let ((beg (point))
- (endp (case end
- (:end (lambda (char) (= ?\] char)))
- (:mid (lambda (char) (= ?\: char)))
- (t (lambda (char) (or (= ?\: char)
- (= ?\] char))))))
- c)
- (while (not (funcall endp (setq c (following-char))))
- (cond ((= ?\\ c)
- (delete-char 1)
- (if (eolp)
- (kill-line 1)
- (forward-char 1)))
- ((looking-at "\\s-+")
- (delete-region (point) (match-end 0))
- (insert " "))
- (t (forward-char 1))))
- (buffer-substring-no-properties beg (point))))
+ (x (end preserve-whitespace)
+ (let ((beg (point))
+ (endp (case end
+ (:end (lambda (char) (= ?\] char)))
+ (:mid (lambda (char) (= ?\: char)))
+ (t (lambda (char) (or (= ?\: char)
+ (= ?\] char))))))
+ c)
+ (while (not (funcall endp (setq c (following-char))))
+ (cond ((= ?\\ c)
+ (delete-char 1)
+ (if (eolp)
+ (kill-line 1)
+ (forward-char 1)))
+ ((unless preserve-whitespace
+ (looking-at "\\s-+"))
+ (delete-region (point) (match-end 0))
+ (insert " "))
+ (t (forward-char 1))))
+ (buffer-substring-no-properties beg (point))))
(one (type end) (let ((s (progn
(forward-char 1)
- (x end))))
+ (x end (eq 'text type)))))
(case type
((stone point move)
;; blech, begone bu"tt"-ugly blatherings
(when (eq :SZ (car prop))
(setq SZ (cdr prop)))
prop))))
- (TREE (parent)
+ (TREE (parent mnum)
(let ((ls parent)
- node)
+ prev node)
(seek-into ?\()
(while (seek ?\;)
- (push (setq node (NODE))
+ (setq prev (car ls)
+ node (NODE))
+ (puthash node (+ (if (gnugo--move-prop node)
+ 1
+ 0)
+ (gethash prev mnum 0))
+ mnum)
+ (push node
ls))
(prog1
- (if (seek ?\()
- ;; multiple
- (loop while (seek ?\()
- append (TREE ls))
- ;; singular
- (list ls))
+ (if (not (seek ?\())
+ ;; singular
+ (list ls)
+ ;; multiple
+ (loop while (seek ?\()
+ append (TREE ls mnum)))
(seek-into ?\))))))
(with-temp-buffer
- (insert-file-contents filename)
+ (if (not data-p)
+ (insert-file-contents file-or-data)
+ (insert file-or-data)
+ (goto-char (point-min)))
(loop while (morep)
- collect (apply 'vector (TREE nil)))))))
-
-(defun gnugo/sgf-hang-from-root (tree)
- (let ((ht (make-hash-table :test 'eq))
- (leaves (append tree nil)))
- (cl-labels
- ((hang (stack)
- (loop
- with rh ; rectified history
- with bp ; branch point
- for node in stack
- until (setq bp (gethash node ht))
- do (puthash node
- (push node rh) ; good for now: ½τ
- ht)
- finally return
- (if (not bp)
- ;; first run: main line
- rh
- ;; subsequent runs: grafts (value discarded)
- (setcdr bp (nconc
- ;; Maintain order of ‘leaves’.
- (let ((was (cdr bp)))
- (if (gnugo--nodep (car was))
- (list was)
- was))
- (list rh)))))))
- (setq tree (hang (pop leaves)))
- (mapc #'hang leaves)
- tree)))
+ collect (let* ((mnum (gnugo--mkht :weakness 'key))
+ (ends (TREE nil mnum))
+ (root (car (last (car ends)))))
+ (vector (apply 'vector ends)
+ mnum
+ root)))))))
(defun gnugo/sgf-write-file (collection filename)
- ;; take responsibility for our actions
- (let ((me (cons "gnugo.el" gnugo-version)))
- (dolist (tree collection)
- (gnugo--set-root-prop :AP me tree)))
- ;; write it out
(let ((aft-newline-appreciated '(:AP :GN :PB :PW :HA :KM :RU :RE))
+ (me (cons "gnugo.el" gnugo-version))
(specs (mapcar (lambda (full)
(cons (intern (format ":%s" (car full)))
(cdddr full)))
gnugo/sgf-*r4-properties*))
p name v spec)
- ;; todo: escape special chars for `text' and `simpletext'.
(cl-labels
- ((>>one (v) (insert (format "[%s]" v)))
- (>>two (v) (insert (format "[%s:%s]" (car v) (cdr v))))
+ ((esc (composed fmt arg)
+ (mapconcat (lambda (c)
+ (case c
+ ;; ‘?\[’ is not strictly required
+ ;; but neither is it forbidden.
+ ((?\[ ?\] ?\\) (format "\\%c" c))
+ (?: (concat (if composed "\\" "") ":"))
+ (t (string c))))
+ (string-to-list (format fmt arg))
+ ""))
+ (>>one (v) (insert "[" (esc nil "%s" v) "]"))
+ (>>two (v) (insert "["
+ (esc t "%s" (car v))
+ ":"
+ (esc t "%s" (cdr v))
+ "]"))
(>>nl () (cond ((memq name aft-newline-appreciated)
(insert "\n"))
((< 60 (current-column))
(insert ")")))
(with-temp-buffer
(dolist (tree collection)
- (>>tree (gnugo/sgf-hang-from-root tree)))
+ ;; take responsibility for our actions
+ (gnugo--set-root-prop :AP me tree)
+ ;; write it out
+ (let ((ht (gnugo--mkht))
+ (leaves (append (gnugo--tree-ends tree) nil)))
+ (cl-flet
+ ((hang (stack)
+ (loop
+ with rh ; rectified history
+ with bp ; branch point
+ for node in stack
+ until (setq bp (gethash node ht))
+ do (puthash node
+ (push node rh) ; good for now: ½τ
+ ht)
+ finally return
+ (if (not bp)
+ ;; first run: main line
+ rh
+ ;; subsequent runs: grafts (value discarded)
+ (setcdr bp (nconc
+ ;; Maintain order of ‘leaves’.
+ (let ((was (cdr bp)))
+ (if (gnugo--nodep (car was))
+ (list was)
+ was))
+ (list rh)))))))
+ (setq tree (hang (pop leaves)))
+ (mapc #'hang leaves)
+ (>>tree tree))))
(newline)
(write-file filename)))))