-;;; gnugo.el --- play GNU Go in a buffer
+;;; gnugo.el --- play GNU Go in a buffer -*- lexical-binding: t -*-
;; Copyright (C) 2014 Free Software Foundation, Inc.
;; `gnugo-animation-string'
;; `gnugo-mode-line'
;; `gnugo-X-face' `gnugo-O-face' `gnugo-grid-face'
+;; `gnugo-undo-reaction'
;; `gnugo-xpms'
;; normal hooks: `gnugo-board-mode-hook'
;; `gnugo-frolic-mode-hook'
;; `gnugo-start-game-hook'
;; `gnugo-post-move-hook'
-;; and the keymap: `gnugo-board-mode-map'
+;; and the keymaps: `gnugo-board-mode-map'
+;; `gnugo-frolic-mode-map'
;;
-;; The variable `gnugo-xpms' is a special case. To set it you need to load
-;; gnugo-xpms.el (http://www.emacswiki.org) or some other library w/ congruent
-;; interface.
+;;
+;; Meta-Meta-Playing (aka Hacking)
+;; -------------------------------
+;;
+;; <http://git.sv.gnu.org/cgit/emacs/elpa.git/tree/packages/gnugo/HACKING>
;;; Code:
(defvar gnugo-grid-face 'default
"Name of face to use for the grid (A B C ... 1 2 3 ...).")
+(defvar gnugo-undo-reaction 'play!
+ "What to do if undo (or oops) leaves GNU Go to play.
+After `gnugo-undo-one-move', `gnugo-undo-two-moves' or `gnugo-oops',
+when GNU Go is to play, this can be a symbol:
+ play -- make GNU Go play (unless in Zombie mode)
+ play! -- make GNU Go play unconditionally (traditional behavior)
+ zombie -- enable Zombie mode (`gnugo-zombie-mode')
+ one-shot -- like `zombie' but valid only for the next move
+Any other value, or (as a special case) for `gnugo-undo-one-move',
+any value other than `zombie', is taken as `one-shot'. Note that
+making GNU Go play will probably result in the recently-liberated
+board position becoming re-occupied.")
+
+(defvar gnugo-xpms nil
+ "List of 46 ((TYPE . LOCATION) . XPM-IMAGE) forms.
+XPM-IMAGE is an image as returned by `create-image' with
+inline data (i.e., property :data with string value).
+
+TYPE is a symbol, one of:
+ hoshi -- unoccupied position with dot
+ empty -- unoccupied position sans dot
+ bpmoku, bmoku -- black stone with and sans highlight point
+ wpmoku, wmoku -- white stone with and sans highlight point
+
+LOCATION is an integer encoding edge, corner, or center:
+ 1 2 3
+ 4 5 6
+ 7 8 9
+For instance, 4 means \"left edge\", 9 means \"bottom right\".
+
+There is only one location for hoshi: center. The other five
+types each have all possible locations. So (+ 1 (* 9 5)) => 46.
+
+The value can also be a function (satisfying `functionp') that
+takes one arg, the size of the board, and returns the appropriate
+list of forms.")
+
;;;---------------------------------------------------------------------------
;;; Variables for the inquisitive programmer
(defvar gnugo-state nil) ; hint: C-c C-p
-(eval-when-compile
- (defvar gnugo-xpms nil))
-
(defvar gnugo-frolic-parent-buffer nil)
(defvar gnugo-frolic-origin nil)
+(defvar gnugo-btw nil)
+
;;;---------------------------------------------------------------------------
;;; Support functions
using (hash-values val)
do (push (cons key
(case key
- ((:xpms :local-xpms)
+ ((:xpms)
(format "hash: %X (%d images)"
(sxhash val)
(length val)))
"Return the current player, either \"black\" or \"white\"."
(gnugo-other (gnugo-get :last-mover)))
-(defsubst gnugo--gate-game-over (enable)
- (when (and enable (gnugo-get :game-over))
- (user-error "Sorry, game over")))
-
-(defun gnugo--ERR-wait (color why)
- (user-error "%s -- please wait for \"(%s to play)\""
- why color))
+(defsubst gnugo--prop<-color (color)
+ (if (gnugo--blackp color) :B :W))
(defun gnugo-gate (&optional in-progress-p)
(unless (gnugo-board-buffer-p)
(user-error "Wrong buffer -- try M-x gnugo"))
(unless (gnugo-get :proc)
(user-error "No \"gnugo\" process!"))
- (let ((slow (gnugo-get :waiting)))
- (when slow
- (gnugo--ERR-wait (gnugo-get :user-color)
- (if (cdr slow)
- "Still thinking"
- "Not your turn yet"))))
- (gnugo--gate-game-over in-progress-p))
+ (destructuring-bind (&optional color . suggestion)
+ (gnugo-get :waiting)
+ (when color
+ (apply 'user-error
+ "%s -- please wait for \"(%s to play)\""
+ (if suggestion
+ (list "Still thinking"
+ color)
+ (list "Not your turn yet"
+ (gnugo-other color))))))
+ (when (and in-progress-p (gnugo-get :game-over))
+ (user-error "Sorry, game over")))
(defun gnugo-sentinel (proc string)
(let ((status (process-status proc)))
(prog1 (substring (process-get proc :srs) 0 -2)
(process-put proc :srs ""))))
+(defsubst gnugo--no-worries (string)
+ (= ?= (aref string 0)))
+
+(defun gnugo--q/ue (fmt &rest args)
+ (let ((ans (apply 'gnugo--q fmt args)))
+ (unless (gnugo--no-worries ans)
+ (user-error "%s" ans))
+ (substring ans 2)))
+
(defun gnugo-query (message-format &rest args)
"Send GNU Go a command formatted with MESSAGE-FORMAT and ARGS.
Return a string that omits the first two characters (corresponding
(substring (apply 'gnugo--q message-format args)
2))
+(defun gnugo--nquery (cmd)
+ (string-to-number (gnugo-query cmd)))
+
(defun gnugo-lsquery (message-format &rest args)
(split-string (apply 'gnugo-query message-format args)))
(t yang)))))
(defun gnugo-toggle-image-display ()
- (unless (and (fboundp 'display-images-p) (display-images-p))
+ (unless (display-images-p)
(user-error "Display does not support images, sorry"))
- (require 'gnugo-xpms)
- (unless (and (boundp 'gnugo-xpms) gnugo-xpms)
- (user-error "Could not load `gnugo-xpms', sorry"))
- (let ((fresh (or (gnugo-get :local-xpms) gnugo-xpms)))
+ (let ((fresh (if (functionp gnugo-xpms)
+ (funcall gnugo-xpms (gnugo-get :SZ))
+ gnugo-xpms)))
+ (unless fresh
+ (user-error "Sorry, `gnugo-xpms' unset"))
(unless (eq fresh (gnugo-get :xpms))
(gnugo-put :xpms fresh)
(gnugo--forget :all-yy)))
(+ ?A (- (if (> ?i col) col (1+ col)) ?a))
(- size (- (aref cc 1) ?a))))))))
-(defun gnugo-move-history (&optional rsel)
+(defsubst gnugo--resignp (string)
+ (string= "resign" string))
+
+(defsubst gnugo--passp (string)
+ (string= "PASS" string))
+
+(defun gnugo-move-history (&optional rsel color)
"Determine and return the game's move history.
Optional arg RSEL controls side effects and return value.
If nil, display the history in the echo area as \"(N moves)\"
car -- the most-recent move
cadr -- the next-to-most-recent move
two -- the last two moves as a list, oldest last
+ bpos -- the last stone on the board placed by COLOR
For all other values of RSEL, do nothing and return nil."
(interactive "P")
(let* ((monkey (gnugo-get :monkey))
(as-pos (gnugo--as-pos-func))
acc node mprop move)
(cl-flet*
- ((as-pos-maybe (x) (if (string= "resign" x)
+ ((as-pos-maybe (x) (if (gnugo--resignp x)
x
(funcall as-pos x)))
- (next (byp) (when (setq node (pop mem)
- mprop (gnugo--move-prop node))
+ (remem () (setq node (pop mem)
+ mprop (gnugo--move-prop node)))
+ (next (byp) (when (remem)
(setq move (as-pos-maybe (cdr mprop)))
(push (if byp
(format "%s%s" move (car mprop))
(`car (car (nn)))
(`cadr (nn) (car (nn)))
(`two (nn) (nn) acc)
+ (`bpos (loop with prop = (gnugo--prop<-color color)
+ while mem
+ when (and (remem)
+ (eq prop (car mprop))
+ (setq move (cdr mprop))
+ ;; i.e., "normal CC" position
+ (= 2 (length move)))
+ return (funcall as-pos move)))
(_ nil)))))
(define-derived-mode gnugo-frolic-mode special-mode "GNUGO Frolic"
;; require-valid-branch
;; (line . numeric)
;; (line . move-string)
+ ;; (omit . [VAR...])
;; Invalid elements blissfully ignored. :-D
(let* ((tree (gnugo-get :sgf-gametree))
(ends (gnugo--tree-ends tree))
(while (gnugo-board-buffer-p)
(bury-buffer)))
-(defsubst gnugo--passp (string)
- (string= "PASS" string))
-
(defsubst gnugo--no-regrets (monkey ends)
(eq (aref ends (aref monkey 1))
(aref monkey 0)))
(substring pos 1))))))
(format "%c%c" one two)))))
-(defsubst gnugo--decorate (node alist)
- ;; NB: ALIST should not have :B or :W keys.
- (setcdr (last node) alist))
+(defun gnugo--decorate (node &rest plist)
+ (loop with tp = (last node)
+ with fruit
+ while plist
+ do (setf
+ fruit (list (cons ; DWR: LtR OoE assumed.
+ (pop plist)
+ (pop plist)))
+ (cdr tp) fruit
+ tp fruit)))
(defun gnugo-close-game (end-time resign)
(gnugo-put :game-end-time end-time)
who))
(start (gnugo-get :waiting-start))
(now (current-time))
- (resignp (string= "resign" move))
+ (resignp (gnugo--resignp move))
(passp (gnugo--passp move))
(head (gnugo-move-history 'car))
(onep (and head (gnugo--passp head)))
(donep (or resignp (and onep passp))))
(unless resignp
- (let ((accept (gnugo--q (format "play %s %s" color move))))
- (unless (= ?= (aref accept 0))
- (user-error "%s" accept))))
+ (gnugo--q/ue "play %s %s" color move))
(unless passp
(gnugo-merge-showboard-results))
(gnugo-put :last-mover color)
(string= ucolor color))
(gnugo-put :last-user-bpos (and (not passp) (not resignp) move)))
;; update :sgf-gametree and :monkey
- (let* ((property (if (gnugo--blackp color)
- :B :W))
+ (let* ((property (gnugo--prop<-color color))
(pair (cons property (cond (resignp move)
(passp "")
(t (funcall (gnugo--as-cc-func)
seems corrupted.) NOCACHE is silently ignored when GNU Go is thinking about
its move."
(interactive "P")
- (let* ((last-mover (gnugo-get :last-mover))
- (other (gnugo-other last-mover))
- (move (gnugo-move-history 'car))
+ (let* ((move (gnugo-move-history 'car))
(game-over (gnugo-get :game-over))
(inhibit-read-only t)
window last)
(rename-buffer (concat (gnugo-get :diamond)
(if game-over
(format "%s(game over)"
- (if (string= move "resign")
+ (if (gnugo--resignp move)
(concat move "ation ")
""))
(format "%s(%s to play)"
(if move (concat move " ") "")
- other))))
+ (gnugo-current-player)))))
;; pall of death
(when game-over
(let ((live (cdr (assq 'live game-over)))
;; this dynamicism is nice but excessive in its wantonness
;;- `(" [" (:eval ,form) "]")
;; this dynamicism is ok because the user triggers it
- (list (format " [%s]" (eval form))
- '(:eval (if (gnugo-get :abd)
- " Abd"
- ""))))))
+ (format " [%s]" (eval form)))))
(force-mode-line-update))
;; last user move
(when (setq last (gnugo-get :last-user-bpos))
(gnugo-goto-pos last))))
-(defun gnugo--finish-move (buf)
- (run-hooks 'gnugo-post-move-hook)
- (with-current-buffer buf
- (gnugo-refresh)))
+(defun gnugo--turn-the-wheel (&optional now)
+ (unless (gnugo-get :waiting)
+ (let ((color (gnugo-current-player))
+ (wheel (gnugo-get :wheel)))
+ (setcar wheel
+ (when (and (not (gnugo-get :game-over))
+ (member color (cdr wheel)))
+ (run-at-time
+ (if now
+ nil
+ 2) ;;; sec (frettoloso? dubioso!)
+ nil
+ (lambda (buf color wheel)
+ (setcar wheel nil)
+ (with-current-buffer buf
+ (gnugo-get-move color)))
+ (current-buffer)
+ color wheel))))))
+
+(defun gnugo--finish-move (&optional now)
+ (let ((buf (current-buffer)))
+ (run-hooks 'gnugo-post-move-hook)
+ (set-buffer buf))
+ (gnugo-refresh)
+ (gnugo--turn-the-wheel now))
;;;---------------------------------------------------------------------------
;;; Game play actions
(when (string-match old name)
(rename-buffer (replace-match new t t name))))))
+(defun gnugo--display-suggestion (color suggestion)
+ (message "%sSuggestion for %s: %s"
+ (gnugo-get :diamond)
+ color suggestion))
+
(defun gnugo-get-move-insertion-filter (proc string)
(with-current-buffer (process-buffer proc)
(let* ((so-far (gnugo-get :get-move-string))
(full (gnugo-put :get-move-string (concat so-far string))))
(when (string-match "^= \\(.+\\)\n\n" full)
- (destructuring-bind (pos-or-pass color . suggestion)
- (cons (match-string 1 full)
- (gnugo-get :waiting))
+ (setq full (match-string 1 full)) ; POS or "PASS"
+ (destructuring-bind (color . suggestion)
+ (gnugo-get :waiting)
(gnugo--forget :get-move-string
:waiting)
(if suggestion
(gnugo--rename-buffer-portion t)
(unless (or (gnugo--passp full)
(eq 'nowarp suggestion))
- (gnugo-goto-pos pos-or-pass))
- (message "%sSuggestion: %s"
- (gnugo-get :diamond)
- pos-or-pass))
- (let* ((donep (gnugo-push-move color pos-or-pass))
- (buf (current-buffer)))
- (gnugo--finish-move buf)
- (when (gnugo-get :abd)
- (gnugo-put :abd
- (unless donep
- (run-at-time
- 2 ;;; sec (frettoloso? dubioso!)
- nil (lambda (buf color)
- (with-current-buffer buf
- (gnugo-get-move color)))
- buf
- (gnugo-other color))))))))))))
+ (gnugo-goto-pos full))
+ (gnugo--display-suggestion color full))
+ (gnugo-push-move color full)
+ (gnugo--finish-move)))))))
(defun gnugo-get-move (color &optional suggestion)
(gnugo-put :waiting (cons color suggestion))
(interactive "P")
(gnugo-gate t)
(gnugo--rename-buffer-portion)
- (gnugo-get-move (gnugo-get :user-color)
+ (gnugo-get-move (gnugo-current-player)
(if nowarp
'nowarp
t)))
+(defun gnugo--karma (color) ; => BOOL
+ (when (member color (cdr (gnugo-get :wheel)))
+ t))
+
+(defsubst gnugo--:karma (role)
+ (gnugo--karma (gnugo-get role)))
+
+(defun gnugo--assist-state (&optional gate)
+ (let ((bool (gnugo--:karma :user-color)))
+ (if (and bool gate)
+ (user-error "Sorry, Assist mode enabled")
+ bool)))
+
(defun gnugo--user-play (pos-or-pass)
(gnugo-gate t)
- (let ((donep (gnugo-push-move t pos-or-pass))
- (buf (current-buffer)))
- (gnugo--finish-move buf)
- (unless donep
- (with-current-buffer buf
- (gnugo-get-move (gnugo-get :gnugo-color))))))
+ ;; The "user" in this func's name used to signify both
+ ;; who does the action and for whom the action is done.
+ ;; Now, it signifies only the former.
+ (let ((color (gnugo-current-player)))
+ ;; Don't get confused by mixed signals.
+ (when (gnugo--karma color)
+ (if (equal color (gnugo-get :one-shot))
+ (gnugo--forget :one-shot)
+ (user-error "Sorry, you cannot play for %s at this time"
+ color)))
+ (gnugo-push-move color pos-or-pass))
+ (gnugo--finish-move t))
(defun gnugo-move ()
"Make a move on the GNUGO Board buffer.
(defun gnugo-animate-group (w/d)
;; W/D is a symbol, either ‘worm’ or ‘dragon’.
+ (gnugo-gate)
(let* ((pos (gnugo-position))
(orig-b-m-p (buffer-modified-p))
blurb stones)
t)))
(defun gnugo-display-group-data (command buffer-name)
+ (gnugo-gate)
(message "Computing %s ..." command)
(let ((data (gnugo--q "%s %s" command (gnugo-position))))
(switch-to-buffer buffer-name)
Signal error if done out-of-turn or if game-over.
See variable `gnugo-animation-string' for customization."
(interactive)
- (gnugo-gate)
(gnugo-animate-group 'worm))
(defun gnugo-worm-data ()
"Display in another buffer data from \"worm\" at current position.
Signal error if done out-of-turn or if game-over."
(interactive)
- (gnugo-gate)
(gnugo-display-group-data "worm_data" "*gnugo worm data*"))
(defun gnugo-dragon-stones ()
Signal error if done out-of-turn or if game-over.
See variable `gnugo-animation-string' for customization."
(interactive)
- (gnugo-gate)
(gnugo-animate-group 'dragon))
(defun gnugo-dragon-data ()
"Display in another buffer data from \"dragon\" at current position.
Signal error if done out-of-turn or if game-over."
(interactive)
- (gnugo-gate)
(gnugo-display-group-data "dragon_data" "*gnugo dragon data*"))
(defun gnugo-estimate-score ()
(message "Est.score ... B %s %s | W %s %s | %s"
black black-captures white white-captures est)))
+(defun gnugo--ok-file (filename)
+ (setq default-directory
+ (file-name-directory
+ (expand-file-name filename)))
+ (set-buffer-modified-p nil))
+
(defun gnugo-write-sgf-file (filename)
"Save the game history to FILENAME (even if unfinished).
If FILENAME already exists, Emacs confirms that you wish to overwrite it."
(not (y-or-n-p "File exists. Continue? ")))
(user-error "Not writing %s" filename))
(gnugo/sgf-write-file (gnugo-get :sgf-collection) filename)
- (set-buffer-modified-p nil))
+ (gnugo--ok-file filename))
+
+(defun gnugo--dance-dance (karma)
+ (destructuring-bind (dance btw)
+ (aref [(moshpit " Zombie")
+ (classic nil)
+ (reverse " Zombie Assist") ; "Assist Zombie"? no thanks! :-D
+ (stilted " Assist")]
+ (cl-flet
+ ((try (n prop)
+ (if (member (gnugo-get prop)
+ karma)
+ n
+ 0)))
+ (+ (try 2 :user-color)
+ (try 1 :gnugo-color))))
+ (gnugo-put :dance dance) ; pure cruft (for now)
+ (setq gnugo-btw btw)))
(defun gnugo--who-is-who (wait play samep)
+ (unless samep
+ (let ((wheel (gnugo-get :wheel)))
+ (when wheel
+ (gnugo--dance-dance
+ (setcdr wheel (mapcar 'gnugo-other
+ (cdr wheel)))))))
(message "GNU Go %splays as %s, you as %s (%s)"
(if samep "" "now ")
wait play (if samep
(defsubst gnugo--nodep (x)
(keywordp (caar x)))
-(defsubst gnugo--SZ! (size)
- (gnugo-put :SZ size))
+(defun gnugo--SZ! (size)
+ (gnugo-put :SZ size)
+ (gnugo-put :center-position
+ (funcall (gnugo--as-pos-func)
+ (let ((c (+ -1 ?a (truncate (1+ size) 2))))
+ (string c c)))))
(defun gnugo--plant-and-climb (collection &optional sel)
(gnugo-put :sgf-collection collection)
(interactive "fSGF file to load: ")
(when (file-directory-p filename)
(user-error "Cannot load a directory (try a filename with extension .sgf)"))
- (let (ans play wait samep coll tree game-over)
+ (let (play wait samep coll tree game-over)
;; problem: requiring GTP `loadsgf' complicates network subproc support;
;; todo: skip it altogether when confident about `gnugo/sgf-create'
- (unless (= ?= (aref (setq ans (gnugo--q "loadsgf %s"
- (expand-file-name filename)))
- 0))
- (user-error "%s" ans))
- (setq play (substring ans 2)
+ (setq play (gnugo--q/ue "loadsgf %s" (expand-file-name filename))
wait (gnugo-other play)
samep (string= (gnugo-get :user-color) play))
(gnugo-put :last-mover wait)
(gnugo-move-history 'two))
'two-passes)))
(gnugo-close-game nil game-over))
+ (gnugo-put :last-user-bpos
+ (gnugo-move-history 'bpos (gnugo-get :user-color)))
(gnugo-refresh t)
- (set-buffer-modified-p nil)
+ (gnugo--ok-file filename)
(gnugo--who-is-who wait play samep)))
-(defun gnugo-magic-undo (spec &optional noalt keep)
- "Undo moves on the GNUGO Board, based on SPEC, a string or number.
-If SPEC is a string in the form of a board position (e.g., \"T19\"),
-check that the position is occupied by a stone of the user's color,
-and if so, remove moves from the history until that position is clear.
-If SPEC is a positive number, remove exactly that many moves from the
-history, signaling an error if the history is exhausted before finishing.
-If SPEC Is 0 (zero), remove either one or two moves,
-so that you are to play next.
-If SPEC is not recognized, signal \"bad spec\" error.
-
-Refresh the board for each move undone. If (in the case where SPEC is
-a number) after finishing, the color to play is not the user's color,
-schedule a move by GNU Go.
-
-After undoing the move(s), schedule a move by GNU Go if it is GNU Go's
-turn to play. Optional second arg NOALT non-nil inhibits this.
-
-Optional third arg KEEP non-nil means do not prune the undone moves
-from the gametree, such that they become a sub-gametree (variation)
-when play resumes."
+(defun gnugo--mem-with-played-stone (pos &optional noerror)
+ (let ((color (case (following-char)
+ (?X :B)
+ (?O :W))))
+ (if (not color)
+ (unless noerror
+ (user-error "No stone at %s" pos))
+ (loop with fruit = (cons color (funcall (gnugo--as-cc-func) pos))
+ for mem on (aref (gnugo-get :monkey) 0)
+ when (equal fruit (caar mem))
+ return mem
+ finally return nil))))
+
+(defun gnugo--climb-towards-root (spec &optional reaction keep)
(gnugo-gate)
- (let* ((n 0)
- (user-color (gnugo-get :user-color))
+ (gnugo--assist-state t)
+ (let* ((user-color (gnugo-get :user-color))
(monkey (gnugo-get :monkey))
(tree (gnugo-get :sgf-gametree))
(ends (gnugo--tree-ends tree))
(remorseful (not (gnugo--no-regrets monkey ends)))
- done ans)
- (cond ((numberp spec)
- (setq n (if (zerop spec)
- (if (string= user-color (gnugo-get :last-mover))
- 1
- 2)
- spec)
- done (lambda () (zerop n))))
- ((string-match "^[a-z]" spec)
- (let ((pos (upcase spec)))
- (setq done `(lambda ()
- (gnugo-goto-pos ,pos)
- (memq (following-char) '(?. ?+))))
- (when (funcall done)
- (user-error "%s already clear" pos))
- (when (= (save-excursion
- (gnugo-goto-pos pos)
- (following-char))
- (if (gnugo--blackp user-color)
- ?O
- ?X))
- (user-error "%s not occupied by %s" pos user-color))))
- (t (user-error "Bad spec: %S" spec)))
+ (stop (if (numberp spec)
+ (nthcdr (if (zerop spec)
+ (if (string= (gnugo-get :last-mover)
+ user-color)
+ 1
+ 2)
+ spec)
+ (aref monkey 0))
+ (cdr (gnugo--mem-with-played-stone
+ (if (stringp spec)
+ spec
+ (gnugo-position)))))))
(when (gnugo-get :game-over)
(gnugo--unclose-game))
- (while (not (funcall done))
- (setq ans (gnugo--q "undo"))
- (unless (= ?= (aref ans 0))
- (user-error "%s" ans))
+ (while (and (not (eq stop (aref monkey 0)))
+ (gnugo--no-worries (gnugo--q "undo")))
(pop (aref monkey 0))
(gnugo-put :last-mover (gnugo-current-player))
(gnugo-merge-showboard-results) ; all
(gnugo-refresh) ; this
- (decf n) ; is
(redisplay)) ; eye candy
(let* ((ulastp (string= (gnugo-get :last-mover) user-color))
-
(ubpos (gnugo-move-history (if ulastp 'car 'cadr))))
(gnugo-put :last-user-bpos (if (and ubpos (not (gnugo--passp ubpos)))
ubpos
(gnugo-refresh t)
(unless (or keep remorseful)
(aset ends (aref monkey 1) (aref monkey 0)))
- (when (and ulastp (not noalt))
- (gnugo-get-move (gnugo-get :gnugo-color))))))
+ (when ulastp
+ (let ((g (gnugo-get :gnugo-color)))
+ (cl-flet ((turn () (gnugo--turn-the-wheel t)))
+ (case (or reaction gnugo-undo-reaction)
+ (play (turn))
+ (play! (let ((wheel (gnugo-get :wheel)))
+ (letf (((cdr wheel) (cons g (cdr wheel))))
+ (turn))))
+ (zombie (gnugo-zombie-mode 1))
+ (t (gnugo-put :one-shot g)))))))))
(defun gnugo-undo-one-move (&optional me-next)
"Undo exactly one move (perhaps GNU Go's, perhaps yours).
See also `gnugo-undo-two-moves'."
(interactive "P")
(gnugo-gate)
- (gnugo-magic-undo 1 t)
(when me-next
- (let* ((wait (gnugo-get :last-mover))
- (play (gnugo-other wait)))
- (gnugo--who-is-who wait play (string= play (gnugo-get :user-color)))
+ (let* ((play (gnugo-get :last-mover))
+ (wait (gnugo-other play))
+ (samep (string= play (gnugo-get :user-color))))
(gnugo-put :user-color play)
- (gnugo-put :gnugo-color wait))))
+ (gnugo-put :gnugo-color wait)
+ (gnugo--who-is-who wait play samep)))
+ (gnugo--climb-towards-root 1 (case gnugo-undo-reaction
+ (zombie gnugo-undo-reaction)
+ (t 'one-shot))))
(defun gnugo-undo-two-moves ()
"Undo a pair of moves (GNU Go's and yours).
However, if you are the last mover, undo only one move.
Regardless, after undoing, it is your turn to play again."
(interactive)
- (gnugo-gate)
- (gnugo-magic-undo 0))
+ (gnugo--climb-towards-root 0))
(defun gnugo-oops (&optional position)
"Like `gnugo-undo-two-moves', but keep the undone moves.
Prefix arg means, instead, undo repeatedly up to and including
the move which placed the stone at point, like `\\[gnugo-fancy-undo]'."
(interactive "P")
- (gnugo-gate)
- (gnugo-magic-undo (if position
- (gnugo-position)
- 0)
- nil t))
+ (gnugo--climb-towards-root (unless position
+ 0)
+ nil t))
(defun gnugo-okay (&optional full)
"Redo a pair of undone moves.
(bidx (aref monkey 1))
(end (aref ends bidx))
(ucolor (gnugo-get :user-color))
- (uprop (if (gnugo--blackp ucolor)
- :B :W)))
+ (uprop (gnugo--prop<-color ucolor)))
(cl-flet ((mvno (node) (gethash node mnum)))
(loop
with ok = (if full
(sit-for 3)))
(let ((b= " Black = ")
(w= " White = ")
- (res (when (string= "resign" (gnugo-move-history 'car))
+ (res (when (gnugo--resignp (gnugo-move-history 'car))
(gnugo-get :last-mover)))
blurb result)
(if res
(let ((node (car (aref (gnugo-get :monkey) 0))))
(gnugo--decorate
(delq (assq :C node) node)
+ :C
(with-temp-buffer ; lame
(insert blurb)
(when (search-backward "\n\nGame start:" nil t)
(rep "territory" "T")
(rep "captures" "C")
(rep "komi" "K"))
- `((:C . ,(buffer-string)))))))
+ (buffer-string)))))
(switch-to-buffer (format "%s*GNUGO Final Score*" (gnugo-get :diamond)))
(erase-buffer)
(insert blurb)))
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.
+ (gnugo--climb-towards-root
(cond ((numberp count) count)
- ((consp count) (car count))
- (t (gnugo-position)))))
+ ((consp count) (car count)))))
(defun gnugo-toggle-image-display-command () ; ugh
"Toggle use of images to display the board, then refresh."
(gnugo-toggle-image-display)
(save-excursion (gnugo-refresh)))
-(defun gnugo--node-with-played-stone (pos)
- (let ((color (case (following-char)
- (?X :B)
- (?O :W))))
- (when color
- (loop with fruit = (cons color (funcall (gnugo--as-cc-func) pos))
- for node in (aref (gnugo-get :monkey) 0)
- if (equal fruit (car node))
- return node
- finally return nil))))
+(defsubst gnugo--node-with-played-stone (pos &optional noerror)
+ (car (gnugo--mem-with-played-stone pos noerror)))
(defun gnugo-describe-position ()
"Display the board position under cursor in the echo area.
If there a stone at that position, also display its move number."
(interactive)
(let* ((pos (gnugo-position)) ; do first (can throw)
- (node (gnugo--node-with-played-stone pos)))
+ (node (gnugo--node-with-played-stone pos t)))
(message
"%s%s" pos
(or (when node
If COMMENT is nil or the empty string, remove the property entirely."
(interactive
(let* ((pos (gnugo-position))
- (node (or (gnugo--node-with-played-stone pos)
- (user-error "No stone at %s" pos))))
+ (node (gnugo--node-with-played-stone pos)))
(list node
(read-string (format "Comment for %s: "
(gnugo-describe-position))
(cdr (assq :C node))))))
(setq node (delq (assq :C node) node))
(unless (zerop (length comment))
- (gnugo--decorate node `((:C . ,comment)))))
-
-(defun gnugo-toggle-abdication ()
- "Toggle abdication, i.e., letting GNU Go play for you.
-When enabled, the mode line includes \"Abd\".
-Enabling signals error if the game is over.
-Disabling signals error if the color \"to play\" is the user color.
-This is to ensure that the user is the next to play after disabling."
- (interactive)
- (let ((last-mover (gnugo-get :last-mover))
- (abd (gnugo-get :abd))
- (warning ""))
- (if abd
+ (gnugo--decorate node :C comment)))
+
+(defun gnugo--struggle (prop updn)
+ (unless (eq updn (gnugo--:karma prop)) ; drudgery avoidance
+ (let ((color (gnugo-get prop)))
+ (if updn
+ ;; enable
+ (gnugo-gate)
;; disable
- (let ((gcolor (gnugo-get :gnugo-color)))
- (when (string= last-mover gcolor)
- (gnugo--ERR-wait gcolor "Sorry, too soon"))
- (when (timerp abd)
- (cancel-timer abd))
- (gnugo--forget :abd)
- (unless (gnugo-get :waiting)
- (gnugo-get-move gcolor)))
- ;; enable
- (gnugo--gate-game-over t)
- (gnugo-put :abd t)
- (gnugo-get-move (gnugo-other last-mover)))
- (message "Abdication %sabled%s"
- (if (gnugo-get :abd)
- "en"
- "dis")
- warning)))
+ (let ((waiting (gnugo-get :waiting)))
+ (when (and waiting (string= color (car waiting)))
+ (gnugo--rename-buffer-portion)
+ (setcdr waiting
+ ;; heuristic: Warp only if it appears
+ ;; that the user is "following along".
+ (or (ignore-errors
+ (string= (gnugo-position)
+ (gnugo-move-history 'bpos color)))
+ 'nowarp))
+ (gnugo--display-suggestion color "forthcoming")
+ (sit-for 2))))
+ (let* ((wheel (gnugo-get :wheel))
+ (timer (car wheel))
+ (karma (cdr wheel)))
+ (when (timerp timer)
+ (cancel-timer timer))
+ (setcar wheel nil)
+ (setcdr wheel (setq karma
+ ;; walk to the west, fly to the east,
+ ;; talk and then rest, cry and then feast.
+ ;; 99 beers down thirsty throats sloshed?
+ ;; 500 years under pink mountains squashed?
+ ;; balk with the best, child now re-creased!
+ (if updn
+ (push color karma)
+ (delete color karma))))
+ (gnugo--dance-dance karma))
+ (gnugo--turn-the-wheel t))))
+
+(define-minor-mode gnugo-assist-mode
+ "If enabled (\"Assist\" in mode line), GNU Go plays for you.
+When disabling, if GNU Go has already started thinking of
+a move to play for you, the thinking is not cancelled but instead
+transformed into a move suggestion (see `gnugo-request-suggestion')."
+ :variable
+ ((gnugo--assist-state)
+ .
+ (lambda (bool)
+ (gnugo--struggle :user-color bool))))
+
+(define-minor-mode gnugo-zombie-mode
+ "If enabled (\"Zombie\" in mode line), GNU Go lets you play for it.
+When disabling, if GNU Go has already started thinking of
+a move to play, the thinking is not cancelled but instead
+transformed into a move suggestion (see `gnugo-request-suggestion')."
+ :variable
+ ((not (gnugo--:karma :gnugo-color))
+ .
+ (lambda (bool)
+ (gnugo--struggle :gnugo-color (not bool)))))
;;;---------------------------------------------------------------------------
;;; Command properties and gnugo-command
(add-hook 'kill-buffer-hook 'gnugo-cleanup nil t)
(set (make-local-variable 'gnugo-state)
(gnugo--mkht :size (1- 42)))
+ (set (make-local-variable 'gnugo-btw) nil)
+ (add-to-list 'minor-mode-alist '(gnugo-btw gnugo-btw))
+ (gnugo-put :highlight-last-move-spec
+ (gnugo-put :default-highlight-last-move-spec '("(" -1 nil)))
+ (gnugo-put :paren-ov (cons (make-overlay 1 1)
+ (let ((ov (make-overlay 1 1)))
+ (overlay-put ov 'display ")")
+ ov)))
+ (gnugo-put :mul '(1 . 1))
(add-to-invisibility-spec :nogrid))
;;;---------------------------------------------------------------------------
;;;###autoload
(defun gnugo (&optional new-game)
"Run gnugo in a buffer, or resume a game in progress.
-Prefix arg means skip the game-in-progress check and start a new
-game straight away.
-\\<gnugo-board-mode-map>
-To play, use \\[gnugo-move] to place a stone or \\[gnugo-pass] to pass.
+If there is already a game in progress you may resume it instead
+of starting a new one. Prefix arg means skip the game-in-progress
+check and start a new game straight away.
-You are queried for additional command-line options (Emacs supplies
-\"--mode gtp --quiet\" automatically). Here is a list of options
-that gnugo.el understands and handles specially:
+Before starting, Emacs queries you for additional command-line
+options (Emacs supplies \"--mode gtp --quiet\" automatically).
- --boardsize num Set the board size to use (5--19)
- --color <color> Choose your color ('black' or 'white')
- --handicap <num> Set the number of handicap stones (0--9)
+Note that specifying \"--infile FILENAME\" (or, \"-l FILENAME\")
+silently clobbers certain other options, such as \"--color\".
+For details, see info node `(gnugo) Invoking GNU Go'.
-If there is already a game in progress you may resume it instead of
-starting a new one. See `gnugo-board-mode' documentation for more info."
+\\<gnugo-board-mode-map>
+To play, use \\[gnugo-move] to place a stone or \\[gnugo-pass] to pass.
+See `gnugo-board-mode' for a full list of commands."
(interactive "P")
(let* ((all (let (acc)
(dolist (buf (buffer-list))
;; set up a new board
(switch-to-buffer (generate-new-buffer "(Uninitialized GNUGO Board)"))
(gnugo-board-mode)
- (let ((args (read-string "GNU Go options: "
- (car gnugo-option-history)
- 'gnugo-option-history))
- proc
- board-size user-color handicap komi minus-l infile)
- (loop for (var default opt rx)
- in '((board-size 19 "--boardsize")
- (user-color "black" "--color" "\\(black\\|white\\)")
- (handicap 0 "--handicap")
- (komi 0.0 "--komi")
- (minus-l nil "\\([^-]\\|^\\)-l[ ]*" "[^ ]+")
- (infile nil "--infile" "[ ]*[^ ]+"))
- do (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)))
+ (let* ((filename nil)
+ (user-color "black")
+ (args (loop
+ with ls = (split-string
+ ;; todo: grok ‘gnugo --help’; completion
+ (read-string
+ "GNU Go options: "
+ (car gnugo-option-history)
+ 'gnugo-option-history))
+ with ok
+ while ls do
+ (let ((arg (pop ls)))
+ (cl-flet
+ ((ex (opt fn)
+ (if filename
+ (warn "%s %s ignored" opt fn)
+ (setq filename fn))))
+ (cond
+ ((string= "--color" arg)
+ (push arg ok)
+ (push
+ ;; Unfortunately, GTP does not provide
+ ;; a way to query the user color, so
+ ;; we must resort to this weirdness.
+ (setq user-color
+ (pop ls))
+ ok))
+ ((string= "--infile" arg)
+ (ex "--infile" (pop ls)))
+ ((string-match "^-l" arg)
+ (ex "-l" (if (< 2 (length arg))
+ (substring arg 2)
+ (pop ls))))
+ (t (push arg ok)))))
+ finally return (nreverse ok)))
+ (proc (apply 'start-process "gnugo"
+ (current-buffer)
+ gnugo-program
+ "--mode" "gtp" "--quiet"
+ args))
+ root board-size handicap komi)
(gnugo-put :user-color user-color)
- (let ((proc-args (split-string args)))
- (gnugo-put :proc-args proc-args)
- (gnugo-put :proc (setq proc (apply 'start-process "gnugo"
- (current-buffer)
- gnugo-program
- "--mode" "gtp" "--quiet"
- proc-args))))
+ (gnugo-put :proc proc)
(set-process-sentinel proc 'gnugo-sentinel)
;; Emacs is too protective sometimes, blech.
(set-process-query-on-exit-flag proc nil)
- (when (or minus-l infile)
- (loop for (prop q)
- in '((board-size "query_boardsize")
- (komi "get_komi")
- (handicap "get_handicap"))
- do (set prop (string-to-number (gnugo-query q)))))
(gnugo-put :diamond (substring (process-name proc) 5))
(gnugo-put :gnugo-color (gnugo-other user-color))
- (gnugo-put :highlight-last-move-spec
- (gnugo-put :default-highlight-last-move-spec '("(" -1 nil)))
- (gnugo-put :paren-ov (cons (make-overlay 1 1)
- (let ((ov (make-overlay 1 1)))
- (overlay-put ov 'display ")")
- ov)))
- (gnugo--plant-and-climb
- (gnugo/sgf-create "(;FF[4]GM[1])" t))
- (gnugo--SZ! board-size)
- (let ((root (gnugo--root-node)))
+ (if filename
+ (gnugo-read-sgf-file (expand-file-name filename))
(cl-flet
- ((r! (&rest plist)
- (gnugo--decorate
- root (loop ; hmm, available elsewhere?
- while plist
- collect (let* ((k (pop plist))
- (v (pop plist)))
- (cons k v))))))
+ ((r! (&rest plist) (apply 'gnugo--decorate root plist)))
+ (gnugo--SZ!
+ (setq root (gnugo--root-node
+ (gnugo--plant-and-climb
+ (gnugo/sgf-create "(;FF[4]GM[1])" t)))
+ komi (gnugo--nquery "get_komi")
+ handicap (gnugo--nquery "get_handicap")
+ board-size (gnugo--nquery "query_boardsize")))
+ ;; Work around a GNU Go 3.8 (and possibly earlier/later)
+ ;; bug whereby GTP command ‘get_handicap’ fails to return
+ ;; the N set by ‘--handicap N’ on the command line.
+ (let ((actually (member "--handicap" args)))
+ ;; Checking ‘(zerop handicap)’ first is not strictly
+ ;; necessary; it represents a hope that some day GNU Go
+ ;; will DTRT (or provide rationale for this weird behavior)
+ ;; and become worthy of our trust.
+ (when (and (zerop handicap) actually)
+ (setq handicap (string-to-number (cadr actually)))))
(r! :SZ board-size
:DT (format-time-string "%Y-%m-%d")
- :RU (if (string-match "--chinese-rules" args)
+ :RU (if (member "--chinese-rules" args)
"Chinese"
"Japanese")
:AP (cons "gnugo.el" gnugo-version)
(gnugo-lsquery "fixed_handicap %d"
handicap)))))))
(gnugo-put :waiting-start (current-time))
- (gnugo-put :mul '(1 . 1))
(gnugo-refresh t)
- (let ((half (truncate (1+ (gnugo-get :SZ)) 2)))
- (gnugo-goto-pos (format "A%d" half))
- (forward-char (* 2 (1- half)))
- (gnugo-put :last-user-bpos
- (gnugo-put :center-position
- (get-text-property (point) 'gnugo-position))))
+ (gnugo-goto-pos (or (gnugo-get :last-user-bpos)
+ (gnugo-get :center-position)))
;; first move
(gnugo-put :game-start-time (current-time))
(let ((g (gnugo-get :gnugo-color))
(n (or (gnugo--root-prop :HA) 0))
(u (gnugo-get :user-color)))
- (gnugo-put :last-mover
- (if (or (and (gnugo--blackp u) (< 1 n))
- (and (gnugo--blackp g) (< n 2)))
- u
- g))
+ (unless (gnugo-get :last-mover)
+ (gnugo-put :last-mover
+ (if (or (and (gnugo--blackp u) (< 1 n))
+ (and (gnugo--blackp g) (< n 2)))
+ u
+ g)))
+ (let ((karma (list g)))
+ (gnugo-put :wheel (cons nil karma))
+ (gnugo--dance-dance karma))
(run-hooks 'gnugo-start-game-hook)
- (when (string= g (gnugo-current-player))
- (gnugo-refresh t)
- (gnugo-get-move g))))))
+ (gnugo--turn-the-wheel)))))
;;;---------------------------------------------------------------------------
;;; Load-time actions
(define-key gnugo-frolic-mode-map (car pair) (cdr pair)))
'(("q" . gnugo-frolic-quit)
("Q" . gnugo-frolic-quit)
+ ("\C-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)
("_" . gnugo-boss-is-near)
("h" . gnugo-move-history)
("L" . gnugo-frolic-in-the-leaves)
+ ("\C-c\C-l" . gnugo-frolic-in-the-leaves)
("i" . gnugo-toggle-image-display-command)
("w" . gnugo-worm-stones)
("W" . gnugo-worm-data)
("F" . gnugo-display-final-score)
("A" . gnugo-switch-to-another)
("C" . gnugo-comment)
- ("\C-c\C-a" . gnugo-toggle-abdication)
+ ("\C-c\C-a" . gnugo-assist-mode)
+ ("\C-c\C-z" . gnugo-zombie-mode)
;; mouse
([(down-mouse-1)] . gnugo-mouse-move)
([(down-mouse-2)] . gnugo-mouse-move) ; mitigate accidents
((sget (x) (get x :gnugo-gtp-command-spec))
(jam (cmd prop val) (put cmd :gnugo-gtp-command-spec
(plist-put (sget cmd) prop val)))
+ (validpos (s &optional go)
+ (let ((pos (upcase s)))
+ (loop with size = (gnugo-get :SZ)
+ for c across (funcall (gnugo--as-cc-func)
+ pos)
+ do (let ((norm (- c ?a)))
+ (unless (and (< -1 norm)
+ (> size norm))
+ (user-error "Invalid position: %s"
+ pos))))
+ (when go
+ (gnugo-goto-pos pos))
+ pos))
(defgtp (x &rest props) (dolist (cmd (if (symbolp x) (list x) x))
(let ((ls props))
(while ls
(gnugo--unclose-game)
(gnugo--forget :last-mover)
;; ugh
- (gnugo--SZ! (string-to-number
- (gnugo-query
- "query_boardsize")))
+ (gnugo--SZ! (gnugo--nquery "query_boardsize"))
(gnugo-refresh t)))
(deffull loadsgf
(gnugo-read-sgf-file (car sel)))
(deffull (undo gg-undo)
- (gnugo-magic-undo
+ (gnugo--climb-towards-root
(let (n)
(cond ((not sel) 1)
((cl-plusp (setq n (string-to-number (car sel)))) n)
- (t (car sel)))))))))
+ (t (validpos (car sel) t)))))))))
(provide 'gnugo)