;;; Variables for the uninquisitive programmer
(defvar gnugo-program "gnugo"
- "*Command to start an external program that speaks GTP, such as \"gnugo\".
+ "Command to start an external program that speaks GTP, such as \"gnugo\".
The value may also be in the form \"PROGRAM OPTIONS...\" in which case the
the command `gnugo' will prefix OPTIONS in its default offering when it
queries you for additional options. It is an error for \"--mode\" to appear
"Keymap for GNUGO Board mode.")
(defvar gnugo-board-mode-hook nil
- "*Hook run when entering GNUGO Board mode.")
+ "Hook run when entering GNUGO Board mode.")
(defvar gnugo-post-move-hook nil
- "*Normal hook run after a move and before the board is refreshed.
+ "Normal hook run after a move and before the board is refreshed.
Hook functions can prevent the call to `gnugo-refresh' by evaluating:
(setq inhibit-gnugo-refresh t)
Initially, when `run-hooks' is called, the current buffer is the GNUGO
;; knows many people may come to know; knowledge does not build
;; solely move by move. Wisdom, on the other hand...
yada yada yada))
- "*String whose individual characters are used for animation.
+ "String whose individual characters are used for animation.
Specifically, the commands `gnugo-worm-stones' and `gnugo-dragon-stones'
render the stones in their respective result groups as the first character
in the string, then the next, and so on.")
(defvar gnugo-mode-line "~b ~w :~m :~u"
- "*A `mode-line-format'-compliant value for GNUGO Board mode.
+ "A `mode-line-format'-compliant value for GNUGO Board mode.
If a single string, the following special escape sequences are
replaced with their associated information:
~b,~w black,white captures (a number)
For ~t, the value is a snapshot, use `gnugo-refresh' to update it.")
(defvar gnugo-X-face 'font-lock-string-face
- "*Name of face to use for X (black) stones.")
+ "Name of face to use for X (black) stones.")
(defvar gnugo-O-face 'font-lock-builtin-face
- "*Name of face to use for O (white) stones.")
+ "Name of face to use for O (white) stones.")
(defvar gnugo-grid-face 'default
- "*Name of face to use for the grid (A B C ... 1 2 3 ...).")
+ "Name of face to use for the grid (A B C ... 1 2 3 ...).")
;;;---------------------------------------------------------------------------
;;; Variables for the inquisitive programmer
;;;---------------------------------------------------------------------------
;;; Support functions
-(put 'gnugo-put 'lisp-indent-function 1)
-(defun gnugo-put (key value) (puthash key value gnugo-state))
-(defun gnugo-get (key) (gethash key gnugo-state))
-
-(let ((docs "Put or get move/game/board-specific properties.
-\(This docstring is shared by `gnugo-put' and `gnugo-get'.\)
+(defun gnugo-put (key value)
+ "Associate move/game/board-specific property KEY with VALUE.
There are many properties, each named by a keyword, that record and control
how gnugo.el manages each game. Each GNUGO Board buffer has its own set
:last-user-bpos -- board position; keep the hapless human happy
-As things stabilize probably more info will be added to this docstring."))
- (put 'gnugo-put 'function-documentation docs)
- (put 'gnugo-get 'function-documentation docs))
+As things stabilize probably more info will be added to this docstring."
+ (declare (indent 1))
+ (puthash key value gnugo-state))
+
+(defun gnugo-get (key)
+ "Return the move/game/board-specific value for KEY.
+See `gnugo-put'."
+ (gethash key gnugo-state))
(defun gnugo-describe-internal-properties ()
"Pretty-print `gnugo-state' properties in another buffer.
(defun gnugo-gate (&optional in-progress-p)
(unless (gnugo-board-buffer-p)
- (error "Wrong buffer -- try M-x gnugo"))
+ (user-error "Wrong buffer -- try M-x gnugo"))
(unless (gnugo-get :proc)
- (error "No \"gnugo\" process!"))
+ (user-error "No \"gnugo\" process!"))
(when (gnugo-get :waitingp)
- (error "Not your turn yet -- please wait for \"\(%s to play\)\""
- (gnugo-get :user-color)))
+ (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)
- (error "Sorry, game over")))
+ (user-error "Sorry, game over")))
(defun gnugo-sentinel (proc string)
(let ((status (process-status proc)))
"Return (TIME . STRING) where TIME is that returned by `current-time' and
STRING omits the two trailing newlines. See also `gnugo-query'."
(when (gnugo-get :waitingp)
- (error "Sorry, still waiting for %s to play" (gnugo-get :gnugo-color)))
- (gnugo-put :sync-return "")
+ (user-error "Sorry, still waiting for %s to play"
+ (gnugo-get :gnugo-color)))
(let ((proc (gnugo-get :proc)))
+ (process-put proc :srs "") ; synchronous return stash
(set-process-filter
proc (lambda (proc string)
- (let* ((so-far (gnugo-get :sync-return))
+ (let* ((so-far (process-get proc :srs))
(start (max 0 (- (length so-far) 2))) ; backtrack a little
- (full (gnugo-put :sync-return (concat so-far string))))
+ (full (concat so-far string)))
+ (process-put proc :srs full)
(when (string-match "\n\n" full start)
- (gnugo-put :sync-return
- (cons (current-time) (substring full 0 -2)))))))
+ (process-put proc :srs (cons (current-time)
+ (substring full 0 -2)))))))
(gnugo-send-line message)
(let (rv)
;; type change => break
- (while (stringp (setq rv (gnugo-get :sync-return)))
+ (while (stringp (setq rv (process-get proc :srs)))
(accept-process-output proc 30))
- (gnugo-put :sync-return "")
+ (process-put proc :srs "")
rv)))
(defun gnugo-query (message-format &rest args)
(defun gnugo-toggle-image-display ()
(unless (and (fboundp 'display-images-p) (display-images-p))
- (error "Display does not support images, sorry"))
+ (user-error "Display does not support images, sorry"))
(require 'gnugo-xpms)
(unless (and (boundp 'gnugo-xpms) gnugo-xpms)
- (error "Could not load `gnugo-xpms', sorry"))
+ (user-error "Could not load `gnugo-xpms', sorry"))
(let ((fresh (or (gnugo-get :local-xpms) gnugo-xpms)))
(unless (eq fresh (gnugo-get :xpms))
(gnugo-put :xpms fresh)
(defun gnugo-merge-showboard-results ()
(let ((aft (substring (cdr (gnugo-synchronous-send/return "showboard")) 3))
(adj 1) ; string to buffer position adjustment
- (sync "[0-9]+ stones$")
+
+ (sync "[0-9]* stones$")
+ ;; Note: `sync' used to start w/ "[0-9]+", but that is too
+ ;; restrictive a condition that fails in the case of:
+ ;;
+ ;; (before)
+ ;; ... WHITE has captured 1 stones
+ ;; ^
+ ;; (after)
+ ;; ... WHITE has captured 14 stones
+ ;; ^
+ ;;
+ ;; where the after count has more digits than the before count,
+ ;; but shares the same leading digits. In this case, the result
+ ;; of `compare-strings' points to the SPC following the before
+ ;; count (indicated by caret in this example).
+
(bef (buffer-substring-no-properties (point-min) (point-max)))
(bef-start 0) (bef-idx 0)
(aft-start 0) (aft-idx 0)
(while (numberp (setq mis (compare-strings bef bef-start nil
aft aft-start nil)))
(setq aft-sync-backtrack nil
- inc (if (> 0 mis)
+ inc (if (cl-minusp mis)
(- (+ 1 mis))
(- mis 1))
bef-idx (+ bef-start inc)
`((live ,@live)
(dead ,@dead))))))
+(defun gnugo--unclose-game ()
+ (dolist (prop '(:game-over ; all those in -close-game
+ :scoring-seed
+ :game-end-time))
+ (gnugo-put prop nil))
+ (let* ((root (car (gnugo-get :sgf-gametree)))
+ (cur (assq :RE root)))
+ (when cur
+ (assert (not (eq cur (car root))) nil
+ ":RE at head of root node: %S"
+ root)
+ (delq cur root))))
+
(defun gnugo-push-move (userp move)
(let* ((color (gnugo-get (if userp :user-color :gnugo-color)))
(start (gnugo-get :waiting-start))
(when (string-match "\\([0-9]+\\)\\s-+[0-9]+\"," s)
(setq start (match-end 0))
(string-to-number (match-string 1 s)))))
- (while (and (<= 0 ncolors) (string-match ",\n" s start))
+ (while (and (not (cl-minusp ncolors))
+ (string-match ",\n" s start))
(setq start (match-end 0)
ncolors (1- ncolors)))
(string-match "\"" s start)
(color-key (aref new sx))) ; blech, heuristic
(while (< sx lx)
(when (and (not (= color-key (aref new sx)))
- (< 0 (random 4)))
+ (cl-plusp (random 4)))
(aset new sx (aref bg-data sb)))
(incf sx)
(incf sb))
(if under10p 2 4)
0))
2.0)))
- (dolist (pair `((tpad . ,(if (and h (< 0 h))
+ (dolist (pair `((tpad . ,(if (and h (cl-plusp h))
`(display ,(make-string h 10))
'(invisible :nogrid)))
(gpad . (display
(defun gnugo-position ()
(or (get-text-property (point) 'gnugo-position)
- (error "Not a proper position point")))
+ (user-error "Not a proper position point")))
(defun gnugo-move ()
"Make a move on the GNUGO Board buffer.
(move (format "play %s %s" (gnugo-get :user-color) pos))
(accept (cdr (gnugo-synchronous-send/return move))))
(unless (= ?= (aref accept 0))
- (error "%s" accept))
+ (user-error "%s" accept))
(gnugo-push-move t pos) ; value always nil for non-pass move
(let (inhibit-gnugo-refresh)
(run-hooks 'gnugo-post-move-hook)
(let ((accept (cdr (gnugo-synchronous-send/return
(format "play %s PASS" (gnugo-get :user-color))))))
(unless (= ?= (aref accept 0))
- (error "%s" accept)))
+ (user-error "%s" accept)))
(let ((donep (gnugo-push-move t "PASS"))
(buf (current-buffer)))
(let (inhibit-gnugo-refresh)
(gnugo-push-move t "resign")
(gnugo-refresh)))
-(defun gnugo-animate-group (command)
- (message "Computing %s ..." command)
+(defun gnugo-animate-group (w/d)
+ ;; W/D is a symbol, either ‘worm’ or ‘dragon’.
(let* ((pos (gnugo-position))
(orig-b-m-p (buffer-modified-p))
- (stones (if (memq (char-after) '(?X ?O))
- (gnugo-lsquery "%s %s" command pos)
- (error "No stone at %s" pos))))
- (message "Computing %s ... %s in group." command (length stones))
+ blurb stones)
+ (unless (memq (char-after) '(?X ?O))
+ (user-error "No stone at %s" pos))
+ (setq blurb (message "Computing %s stones ..." w/d)
+ stones (gnugo-lsquery "%s_stones %s" w/d pos))
+ (message "%s %s in group." blurb (length stones))
(setplist (gnugo-f 'anim) nil)
(let* ((spec (let ((spec (split-string gnugo-animation-string "" t)))
(cond ((gnugo-get :display-using-images)
See variable `gnugo-animation-string' for customization."
(interactive)
(gnugo-gate)
- (gnugo-animate-group "worm_stones"))
+ (gnugo-animate-group 'worm))
(defun gnugo-worm-data ()
"Display in another buffer data from \"worm\" at current position.
See variable `gnugo-animation-string' for customization."
(interactive)
(gnugo-gate)
- (gnugo-animate-group "dragon_stones"))
+ (gnugo-animate-group 'dragon))
(defun gnugo-dragon-data ()
"Display in another buffer data from \"dragon\" at current position.
to enable full functionality."
(interactive)
(let ((game-over (or (gnugo-get :game-over)
- (error "Sorry, game still in play")))
+ (user-error "Sorry, game still in play")))
(group (or (get-text-property (point) 'group)
- (error "No stone at that position")))
+ (user-error "No stone at that position")))
(now (current-time)))
(gnugo-put :scoring-seed (logior (ash (logand (car now) 255) 16)
(cadr now)))
(interactive "FWrite game as SGF file: ")
(when (and (file-exists-p filename)
(not (y-or-n-p "File exists. Continue? ")))
- (error "Not writing %s" filename))
+ (user-error "Not writing %s" filename))
(gnugo/sgf-write-file (gnugo-get :sgf-collection) filename)
(set-buffer-modified-p nil))
"Load the first game tree from FILENAME, a file in SGF format."
(interactive "fSGF file to load: ")
(when (file-directory-p filename)
- (error "Cannot load a directory (try a filename with extension .sgf)"))
+ (user-error "Cannot load a directory (try a filename with extension .sgf)"))
(let (ans play wait samep coll)
;; problem: requiring GTP `loadsgf' complicates network subproc support;
;; todo: skip it altogether when confident about `gnugo/sgf-read-file'
(format "loadsgf %s"
(expand-file-name filename)))))
0))
- (error "%s" ans))
+ (user-error "%s" ans))
(setq play (substring ans 2)
wait (gnugo-other play)
samep (string= (gnugo-get :user-color) play))
t)
(gnugo-close-game nil game-over)))
(gnugo-refresh t)
+ (set-buffer-modified-p nil)
(message "GNU Go %splays as %s, you as %s (%s)"
(if samep "" "now ")
wait play (if samep
(mem (aref monkey 1))
(count (aref monkey 2))
done ans)
- (cond ((and (numberp spec) (< 0 spec))
+ (cond ((and (numberp spec) (cl-plusp spec))
(setq n spec done (lambda () (zerop n))))
((string-match "^[a-z]" spec)
(let ((pos (upcase spec)))
(gnugo-goto-pos ,pos)
(memq (char-after) '(?. ?+))))
(when (funcall done)
- (error "%s already clear" pos))
+ (user-error "%s already clear" pos))
(let ((u (gnugo-get :user-color)))
(when (= (save-excursion
(gnugo-goto-pos pos)
(if (string= "black" u)
?O
?X))
- (error "%s not occupied by %s" pos u)))))
- (t (error "Bad spec: %S" spec)))
+ (user-error "%s not occupied by %s" pos u)))))
+ (t (user-error "Bad spec: %S" spec)))
(when (gnugo-get :game-over)
- (gnugo-put :game-over nil))
+ (gnugo--unclose-game))
(while (not (funcall done))
(setq ans (cdr (gnugo-synchronous-send/return "undo")))
(unless (= ?= (aref ans 0))
- (error "%s" ans))
+ (user-error "%s" ans))
(aset monkey 2 (decf count))
(aset monkey 1 (setq mem (cdr mem)))
(aset monkey 0 (or (car mem) (gnugo-get :sgf-gametree)))
(unless (or (gnugo-get :game-over)
(and (not (gnugo-get :waitingp))
(y-or-n-p "Game still in play. Stop play now? ")))
- (error "Sorry, game still in play"))
+ (user-error "Sorry, game still in play"))
(unless (gnugo-get :game-over)
(cl-labels
((pass (userp)
(erase-buffer)
(insert blurb)))
+(defun gnugo-quit ()
+ "Kill the current buffer, assumed to be in GNUGO Board mode, maybe.
+If the game is not over, ask for confirmation first."
+ (interactive)
+ (if (or (gnugo-get :game-over)
+ (y-or-n-p "Quit? "))
+ (kill-buffer nil)
+ (message "(not quitting)")))
+
+(defun gnugo-leave-me-alone ()
+ "Kill the current buffer unconditionally."
+ (interactive)
+ (kill-buffer nil))
+
+(defun gnugo-fancy-undo (count)
+ "Rewind the game tree in various ways.
+Prefix arg COUNT means to undo that many moves.
+Otherwise, undo repeatedly up to and including the move
+which placed the stone at point."
+ (interactive "P")
+ (gnugo-magic-undo
+ ;; TODO: Move this into `gnugo-magic-undo' proper.
+ (cond ((numberp count) count)
+ ((consp count) (car count))
+ (t (gnugo-position)))))
+
+(defun gnugo-toggle-image-display-command () ; ugh
+ "Toggle use of images to display the board, then refresh."
+ (interactive)
+ (gnugo-toggle-image-display)
+ (save-excursion (gnugo-refresh)))
+
+(defun gnugo-describe-position ()
+ "Display the board position under cursor in the echo area."
+ (interactive)
+ (message "%s" (gnugo-position)))
+
;;;---------------------------------------------------------------------------
;;; Command properties and gnugo-command
(let* ((split (split-string command))
(cmd (intern (car split)))
(spec (get cmd :gnugo-gtp-command-spec))
- (full (plist-get spec :full))
- (last-message nil))
+ (full (plist-get spec :full)))
(if full
(funcall full (cdr split))
(message "Doing %s ..." command)
(o (substring gnugo-program (match-end 0)))
(h (or (car gnugo-option-history) "")))
(when (string-match "--mode" o)
- (error "Found \"--mode\" in `gnugo-program'"))
- (when (and o (< 0 (length o))
- h (< 0 (length o))
+ (user-error "Found \"--mode\" in `gnugo-program'"))
+ (when (and o (cl-plusp (length o))
+ h (cl-plusp (length o))
(or (< (length h) (length o))
(not (string= (substring h 0 (length o))
o))))
'gnugo-option-history))
(rules "Japanese")
board-size user-color handicap komi minus-l infile)
- (mapc (lambda (x)
- (apply (lambda (var default opt &optional rx)
- (set var
- (or (when (string-match opt args)
- (let ((start (match-end 0)) s)
- (string-match (or rx "[0-9.]+") args start)
- (setq s (match-string 0 args))
- (if rx s (string-to-number s))))
- default)))
- x))
- '((board-size 19 "--boardsize")
- (user-color "black" "--color" "\\(black\\|white\\)")
- (handicap 0 "--handicap")
- (komi 0.0 "--komi")
- (minus-l nil "\\([^-]\\|^\\)-l[ ]*" "[^ ]+")
- (infile nil "--infile" "[ ]*[^ ]+")))
+ (dolist (x '((board-size 19 "--boardsize")
+ (user-color "black" "--color" "\\(black\\|white\\)")
+ (handicap 0 "--handicap")
+ (komi 0.0 "--komi")
+ (minus-l nil "\\([^-]\\|^\\)-l[ ]*" "[^ ]+")
+ (infile nil "--infile" "[ ]*[^ ]+")))
+ (destructuring-bind (var default opt &optional rx) x
+ (set var
+ (or (when (string-match opt args)
+ (let ((start (match-end 0)) s)
+ (string-match (or rx "[0-9.]+") args start)
+ (setq s (match-string 0 args))
+ (if rx s (string-to-number s))))
+ default))))
(gnugo-put :user-color user-color)
(when (string-match "--chinese-rules" args)
(setq rules "Chinese"))
"--mode" "gtp" "--quiet"
proc-args)))
;; Emacs is too protective sometimes, blech.
- (remove-hook (make-local-variable 'kill-buffer-query-functions)
- 'process-kill-buffer-query-function
- t)
+ (set-process-query-on-exit-flag (gnugo-get :proc) nil)
(when (or minus-l infile)
(mapc (lambda (x)
(apply (lambda (prop q)
acc))
(n (length all)))
(if (and (not new-game)
- (< 0 n)
+ (cl-plusp n)
(y-or-n-p (format "GNU Go game%s in progress, resume play? "
(if (= 1 n) "" "s"))))
;; resume
(" " . gnugo-move)
("P" . gnugo-pass)
("R" . gnugo-resign)
- ("q" . (lambda () (interactive)
- (if (or (gnugo-get :game-over)
- (y-or-n-p "Quit? "))
- (kill-buffer nil)
- (message "(not quitting)"))))
- ("Q" . (lambda () (interactive)
- (kill-buffer nil)))
- ("U" . (lambda (x) (interactive "P")
- (gnugo-magic-undo
- (cond ((numberp x) x)
- ((consp x) (car x))
- (t (gnugo-position))))))
+ ("q" . gnugo-quit)
+ ("Q" . gnugo-leave-me-alone)
+ ("U" . gnugo-fancy-undo)
("u" . gnugo-undo-two-moves)
("\C-l" . gnugo-refresh)
("\M-_" . bury-buffer)
("_" . bury-buffer)
("h" . gnugo-move-history)
- ("i" . (lambda () (interactive)
- (gnugo-toggle-image-display)
- (save-excursion (gnugo-refresh))))
+ ("i" . gnugo-toggle-image-display-command)
("w" . gnugo-worm-stones)
("W" . gnugo-worm-data)
("d" . gnugo-dragon-stones)
("!" . gnugo-estimate-score)
(":" . gnugo-command)
(";" . gnugo-command)
- ("=" . (lambda () (interactive)
- (message (gnugo-position))))
+ ("=" . gnugo-describe-position)
("s" . gnugo-write-sgf-file)
("\C-x\C-s" . gnugo-write-sgf-file)
("\C-x\C-w" . gnugo-write-sgf-file)
fixed_handicap)
:output :discard
:post-thunk (lambda ()
- (gnugo-put :game-over nil)
+ (gnugo--unclose-game)
(gnugo-put :last-mover nil)
(gnugo-refresh t)))
(lambda (sel) (gnugo-magic-undo
(let (n)
(cond ((not sel) 1)
- ((< 0 (setq n (string-to-number (car sel)))) n)
+ ((cl-plusp (setq n (string-to-number (car sel)))) n)
(t (car sel)))))))))
(provide 'gnugo)