-;;; 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.
;; Author: Thien-Thi Nguyen <ttn@gnu.org>
-;; Version: 2.3.1
-;; Package-Requires: ((ascii-art-to-unicode "1.5"))
+;; Maintainer: Thien-Thi Nguyen <ttn@gnu.org>
+;; Version: 3.0.0
+;; Package-Requires: ((ascii-art-to-unicode "1.5") (xpm "1.0.1") (cl-lib "0.5"))
+;; Keywords: games, processes
+;; URL: http://www.gnuvola.org/software/gnugo/
;; 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
;; `gnugo-animation-string'
;; `gnugo-mode-line'
;; `gnugo-X-face' `gnugo-O-face' `gnugo-grid-face'
-;; `gnugo-xpms'
+;; `gnugo-undo-reaction'
+;; `gnugo-xpms' (see also gnugo-imgen.el)
;; 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/>
;;; Code:
-(eval-when-compile (require 'cl)) ; use the source luke!
-(require 'ascii-art-to-unicode) ; for `aa2u'
+(require 'cl-lib) ; use the source luke!
(require 'time-date) ; for `time-subtract'
;;;---------------------------------------------------------------------------
;;; Political arts
-(defconst gnugo-version "2.3.1"
+(defconst gnugo-version "3.0.0"
"Version of gnugo.el currently loaded.
This follows a MAJOR.MINOR.PATCH scheme.")
;;; Variables for the uninquisitive programmer
(defvar gnugo-program "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
-in OPTIONS.
-
-For more information on GTP and GNU Go, feel free to visit:
-http://www.gnu.org/software/gnugo")
-
-(defvar gnugo-board-mode-map nil
+ "Name of the GNU Go program (executable file).
+\\[gnugo] validates this using `executable-find'.
+This program must accept command line args:
+ --mode gtp --quiet
+For more information on GTP and GNU Go, please visit:
+<http://www.gnu.org/software/gnugo>")
+
+(defvar gnugo-board-mode-map
+ ;; Re <http://lists.gnu.org/archive/html/emacs-devel/2014-04/msg00123.html>,
+ ;; ideally we could ‘defvar’ here w/o value and also ‘defvar’ below
+ ;; in "load-time actions" w/ value and docstring, to avoid this ugly
+ ;; (from the forward references) block early in the file. Unfortunately,
+ ;; byte-compiling such a split formulation results in the initial ‘defvar’
+ ;; being replaced by:
+ ;; (defvar VAR (make-sparse-keymap))
+ ;; and the second ‘defvar’ is ignored on load. At least, this is the case
+ ;; for Emacs built from repo (trunk) 2014-05-27. --ttn
+ (let ((map (make-sparse-keymap)))
+ (suppress-keymap map)
+ (mapc (lambda (pair)
+ (define-key map (car pair) (cdr pair)))
+ '(("?" . describe-mode)
+ ("S" . gnugo-request-suggestion)
+ ("\C-m" . gnugo-move)
+ (" " . gnugo-move)
+ ("P" . gnugo-pass)
+ ("R" . gnugo-resign)
+ ("q" . gnugo-quit)
+ ("Q" . gnugo-leave-me-alone)
+ ("U" . gnugo-fancy-undo)
+ ("\M-u" . gnugo-undo-one-move)
+ ("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)
+ ("h" . gnugo-move-history)
+ ("L" . gnugo-frolic-in-the-leaves)
+ ("\C-c\C-l" . gnugo-frolic-in-the-leaves)
+ ("i" . gnugo-image-display-mode)
+ ("w" . gnugo-worm-stones)
+ ("W" . gnugo-worm-data)
+ ("d" . gnugo-dragon-stones)
+ ("D" . gnugo-dragon-data)
+ ("g" . gnugo-grid-mode)
+ ("!" . gnugo-estimate-score)
+ (":" . gnugo-command)
+ (";" . gnugo-command)
+ ("=" . gnugo-describe-position)
+ ("s" . gnugo-write-sgf-file)
+ ("\C-x\C-s" . gnugo-write-sgf-file)
+ ("\C-x\C-w" . gnugo-write-sgf-file)
+ ("l" . gnugo-read-sgf-file)
+ ("F" . gnugo-display-final-score)
+ ("A" . gnugo-switch-to-another)
+ ("C" . gnugo-comment)
+ ("\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
+ ([(down-mouse-3)] . gnugo-mouse-pass)
+ ;; delving into the curiosities
+ ("\C-c\C-p" . gnugo-describe-internal-properties)))
+ map)
"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.")
(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
`gnugo-toggle-image-display' and `gnugo-refresh',
as well as gnugo-xpms.el (available elsewhere)
- :all-yy -- list of 46 keywords used as the `category' text property
+ :all-yy -- list of 46 symbols used as the `category' text property
(so that their plists, typically w/ property `display' or
`do-not-display') are consulted by the Emacs display engine;
46 = 9 places * (4 moku + 1 empty) + 1 hoshi; see functions
(interactive)
(let ((buf (current-buffer))
(d (gnugo-get :diamond))
- 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--root-node val)
- (gnugo--tree-ends val)))
- (:monkey
- (let ((mem (aref val 0)))
- (list (aref val 1)
- (car mem))))
- (t val)))
- acc))
+ (acc (cl-loop
+ for key being the hash-keys of gnugo-state
+ using (hash-values val)
+ collect (cons key
+ (cl-case key
+ ((: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--root-node val)
+ (gnugo--tree-ends val)))
+ (:monkey
+ (let ((mem (aref val 0)))
+ (list (aref val 1)
+ (car mem))))
+ (t val))))))
(switch-to-buffer (get-buffer-create
(format "%s*GNUGO Board Properties*"
- (gnugo-get :diamond))))
+ d)))
(erase-buffer)
(emacs-lisp-mode)
(setq truncate-lines t)
(if (string= "" d)
".+\n"
""))))
- (while (re-search-forward rx (point-max) t)
+ (while (re-search-forward rx nil t)
(let ((pos (get-text-property (string-to-number (match-string 1))
'gnugo-position buf)))
(delete-region (+ 2 (match-beginning 0)) (point))
"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))
+ (cl-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)))
(1- letter)))
?A)))))
-(defun gnugo-f (frag)
- (intern (format ":gnugo-%s%s-props" (gnugo-get :diamond) frag)))
+(defun gnugo-f (id)
+ (intern (if (symbolp id)
+ (symbol-name id)
+ id)
+ (gnugo-get :obarray)))
(defun gnugo-yang (c)
(cdr (assq c '((?+ . hoshi)
(defun gnugo-yy (yin yang &optional momentaryp)
(gnugo-f (format "%d-%s"
- yin (cond ((and (consp yang) momentaryp) (cdr yang))
- ((consp yang) (car yang))
- (t yang)))))
+ yin (cond ((symbolp yang) yang)
+ (momentaryp (cdr yang))
+ (t (car 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)))
(setplist (gnugo-f 'ispc) (and new '(display (space :width 0))))
(gnugo-put :highlight-last-move-spec
(if new
- '((lambda (p)
- (get (gnugo-yy (get-text-property p 'gnugo-yin)
- (get-text-property p 'gnugo-yang)
- t)
- 'display))
+ `(,(lambda (p)
+ (get (gnugo-yy (get-text-property p 'gnugo-yin)
+ (get-text-property p 'gnugo-yang)
+ t)
+ 'display))
0 delete-overlay)
(gnugo-get :default-highlight-last-move-spec)))
;; a kludge to be reworked another time perhaps by another gnugo.el lover
'(1 . 1)))
(gnugo-put :display-using-images new)))
-(defun gnugo-toggle-grid ()
- "Turn the grid around the board on or off."
- (interactive)
- (funcall (if (memq :nogrid buffer-invisibility-spec)
- 'remove-from-invisibility-spec
- 'add-to-invisibility-spec)
- :nogrid)
- (save-excursion (gnugo-refresh)))
+(define-minor-mode gnugo-grid-mode
+ "If enabled, display grid around the board."
+ :variable
+ ((not (memq :nogrid buffer-invisibility-spec))
+ .
+ (lambda (bool)
+ (funcall (if bool
+ 'remove-from-invisibility-spec
+ 'add-to-invisibility-spec)
+ :nogrid)
+ (save-excursion (gnugo-refresh)))))
(defun gnugo-propertize-board-buffer ()
(erase-buffer)
;; This has something to do w/ the bletcherous `before-string'.
(overlay-put ov 'invisible :nogrid)
(overlay-put ov 'category %lpad))
- (do ((p edge (+ 2 p)) (ival 'even (if (eq 'even ival) 'odd 'even)))
+ (cl-do ((p edge (+ 2 p)) (ival 'even (if (eq 'even ival) 'odd 'even)))
((< other-edge p))
(let* ((position (format "%c%s" (aref "ABCDEFGHJKLMNOPQRST"
(truncate (- p edge) 2))
(bef (buffer-substring-no-properties (point-min) (point-max)))
(bef-start 0) (bef-idx 0)
(aft-start 0) (aft-idx 0)
- aft-sync-backtrack mis inc cut new very-strange)
+ aft-sync-backtrack mis inc cut new very-strange
+
+ (inhibit-read-only t))
(while (numberp (setq mis (gnugo--compare-strings
bef bef-start
aft aft-start)))
(gnugo-put capprop new)
(delete-char old-len)
(insert (apply 'propertize new keep))
- (incf adj (- (length new) old-len)))
+ (cl-incf adj (- (length new) old-len)))
(setq new (aref aft aft-idx))
(insert-and-inherit (char-to-string new))
(let ((yin (get-text-property cut 'gnugo-yin))
(assq :W node)))
(defun gnugo--as-pos-func ()
- (lexical-let ((size (gnugo-get :SZ)))
+ (let ((size (gnugo-get :SZ)))
;; rv
(lambda (cc)
(if (string= "" cc)
(+ ?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 (cl-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"
- "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:
-
- 1 B -- E7 E7 E7 E7
- 2 W -- K10 K10 K10 K10
- 3 B -- E2 E2 E2 E2
- 4 W -- J3 J3 J3 J3
- 5 B -- A6 A6 A6 A6
- 6 W -- C9 C9 C9 C9
- │
- ├─────┬─────┐
- │ │ │
- 7 B -- H7 !B8 C8 C8
- │
- ├─────┐
- │ │
- 8 W -- D9 D9 D9 E9
- 9 B -- H8 H8
- 10 W -- PASS PASS
- 11 B -- H5 PASS
- 12 W -- PASS
- 13 B -- *PASS
-
-with 0, 1, ... N (in this case N is 3) in the header line
-to indicate the branches. Branch 0 is the \"main line\".
-Point (* in this example) indicates the current position,
-\"!\" indicates comment properties (e.g., B8, branch 1),
-and moves not actually on the game tree (e.g., E7, branch 3)
-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))
- (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))
- (at (car (aref monkey 0)))
- (bidx (aref monkey 1))
- (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 (properties fmt &rest args)
- (insert (apply 'propertize
- (apply 'format fmt args)
- properties))))
- ;; breathe in
- (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)
- (gnugo-frolic-mode)
- (erase-buffer)
- (setq header-line-format
- (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 max-move-num downto 1
- do (setq props (list 'n n))
- do
- (loop
- with (move forks br)
- initially (progn
- (goto-char (point-min))
- (fsi props
- "%3d %s -- "
- n (aref ["W" "B"] (logand 1 n))))
- for bx below width
- do (let* ((node (unless (< (aref valid bx) n)
- ;; todo: ignore non-"move" nodes
- (pop (aref ends bx))))
- (zow (list* 'bx bx props))
- (ok (when node
- (= bx (on node))))
- (comment (when ok
- (cdr (assq :C node))))
- (s (cond ((not node) "")
- ((not (setq move (gnugo--move-prop node))) "-")
- (t (funcall as-pos (cdr move))))))
- (when comment
- (push comment zow)
- (push 'help-echo zow))
- (when (and ok (setq br (gethash node soil)))
- (push (cons bx (sort br '<))
- forks))
- (fsi zow
- "%c%-5s"
- (if comment ?! ?\s)
- (cond ((and (eq at node)
- (or ok (= bx bidx)))
- (when (= bx bidx)
- (setq finish (point-marker)))
- (emph s (list :inherit 'default
- :foreground (frame-parameter
- nil 'cursor-color))))
- ((not ok)
- (emph s dimmed-node-face))
- (t s))))
- finally do
- (when (progn (fsi props "\n")
- (setq forks (nreverse forks)))
- (let* ((margin (make-string 11 ?\s))
- (heads (mapcar #'car forks))
- (tails (mapcar #'cdr forks)))
- (cl-flet*
- ((spaced (lanes func)
- (mapconcat func lanes " "))
- ;; live to play ~ ~ ()
- ;; play to learn (+) (-) . o O
- ;; learn to live --ttn .M. _____U
- (dashed (lanes func) ;;; _____ ^^^^
- (mapconcat func lanes "-----"))
- (cnxn (lanes set)
- (spaced lanes (lambda (bx)
- (if (memq bx set)
- "|"
- " "))))
- (pad-unless (condition)
- (if condition
- ""
- " "))
- (edge (set)
- (insert margin
- (cnxn lanes set)
- "\n")))
- (edge heads)
- (loop with bef
- for ls on forks
- do (let* ((one (car ls))
- (yes (append
- ;; "aft" heads
- (mapcar 'car (cdr ls))
- ;; ‘bef’ tails
- (apply 'append (mapcar 'cdr bef))))
- (ord (sort one '<))
- (beg (car ord))
- (end (car (last ord))))
- (cl-flet
- ((also (b e) (cnxn (number-sequence b e)
- yes)))
- (insert
- margin
- (also 0 (1- beg))
- (pad-unless (zerop beg))
- (dashed (number-sequence beg end)
- (lambda (bx)
- (cond ((memq bx ord) "+")
- ((memq bx yes) "|")
- (t "-"))))
- (pad-unless (>= end width))
- (also (1+ end) (1- width))
- "\n"))
- (push one bef)))
- (edge (apply 'append tails))
- (aa2u (line-beginning-position
- (- (1+ (length forks))))
- (point))))))))
- (when finish
- (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."
(interactive)
(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)))
(defun gnugo--as-cc-func ()
- (lexical-let ((size (gnugo-get :SZ)))
+ (let ((size (gnugo-get :SZ)))
(lambda (pos)
(let* ((col (aref pos 0))
(one (+ ?a (- col (if (< ?H col) 1 0) ?A)))
(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)
+ (cl-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)
(let* ((root (gnugo--root-node))
(cur (assq :RE root)))
(when cur
- (assert (not (eq cur (car root))) nil
- ":RE at head of root node: %S"
- root)
+ (cl-assert (not (eq cur (car root))) nil
+ ":RE at head of root node: %S"
+ root)
(delq cur root))))
(defun gnugo-push-move (who move)
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)
;;
;; This linear search loses for multiple ‘old’ w/ "A",
;; a very unusual (but not invalid, sigh) situation.
- (loop
+ (cl-loop
with (bx previous)
for i
;; Start with latest / highest likelihood for hit.
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 (assq property node))
- m)
- finally return
- nil))
+ (cl-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 (assq property node))
+ m)
+ finally return nil))
;; yes => follow
return
(progn
(unless (= bidx bx)
- (rotatef (aref ends bidx)
- (aref ends bx)))
+ (cl-rotatef (aref ends bidx)
+ (aref ends bx)))
(setq mem previous))
;; no => construct
finally do
(let* ((fg-yy (gnugo-yy yin yang))
(fg-disp (or (get fg-yy 'display)
(get fg-yy 'do-not-display)))
- (fg-data (plist-get (cdr fg-disp) :data))
+ (fg-props (cdr fg-disp))
+ (fg-data (plist-get fg-props :data))
+ (c-symbs (plist-get fg-props :color-symbols))
(bg-yy (gnugo-yy yin (gnugo-yang ?.)))
(bg-disp (or (get bg-yy 'display)
(get bg-yy 'do-not-display)))
(when (and (not (= color-key (aref new sx)))
(cl-plusp (random 4)))
(aset new sx (aref bg-data sb)))
- (incf sx)
- (incf sb))
- (create-image new 'xpm t :ascent 'center)))
+ (cl-incf sx)
+ (cl-incf sb))
+ (apply 'create-image new 'xpm t
+ :ascent 'center (when c-symbs
+ (list :color-symbols
+ c-symbs)))))
(defun gnugo-refresh (&optional nocache)
"Update GNUGO Board buffer display.
seems corrupted.) NOCACHE is silently ignored when GNU Go is thinking about
its move."
(interactive "P")
- (when (and nocache (not (gnugo-get :waiting)))
- (gnugo-propertize-board-buffer))
- (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)
+ (when (and nocache (not (gnugo-get :waiting)))
+ (gnugo-propertize-board-buffer))
;; last move
(when move
- (destructuring-bind (l-ov . r-ov) (gnugo-get :paren-ov)
+ (cl-destructuring-bind (l-ov . r-ov) (gnugo-get :paren-ov)
(if (member move '("PASS" "resign"))
(mapc 'delete-overlay (list l-ov r-ov))
(gnugo-goto-pos move)
(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)))
(let (acc cut c)
(while (setq cut (string-match "~[bwpmtu]" cur))
(aset cur cut ?%)
- (setq c (aref cur (incf cut)))
+ (setq c (aref cur (cl-incf cut)))
(aset cur cut ?s)
(push
`(,(intern (format "squig-%c" c))
- ,(case c
+ ,(cl-case c
(?b '(or (gnugo-get :black-captures) 0))
(?w '(or (gnugo-get :white-captures) 0))
(?p '(gnugo-current-player))
;; 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
(let ((old "to play")
(new "waiting for suggestion"))
(when back
- (rotatef old new))
+ (cl-rotatef old new))
(let ((name (buffer-name)))
(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"
+ (cl-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))
(when (gnugo-board-buffer-p)
(unless (zerop (buffer-size))
(message "Thank you for playing GNU Go."))
- (mapc (lambda (sym)
- (setplist sym nil) ; "...is next to fordliness." --Huxley
- ;; Sigh, "2nd arg optional" obsolete as of Emacs 23.3.
- ;; No worries, things will be Much Better w/ structs, RSN...
- (unintern sym nil))
- (append (gnugo-get :all-yy)
- (mapcar 'gnugo-f
- '(anim
- tpad
- gpad
- gspc
- lpad
- rpad
- ispc))))
(setq gnugo-state nil)))
(defun gnugo-position ()
(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)
(message "%s %s in group." blurb (length stones))
(setplist (gnugo-f 'anim) nil)
(let* ((spec (if (gnugo-get :display-using-images)
- (loop with yin = (get-text-property (point) 'gnugo-yin)
- with yang = (gnugo-yang (following-char))
- with up = (get (gnugo-yy yin yang t) 'display)
- with dn = (get (gnugo-yy yin yang) 'display)
- for n below (length gnugo-animation-string)
- collect (if (zerop (logand 1 n))
- dn up))
+ (cl-loop
+ with yin = (get-text-property (point) 'gnugo-yin)
+ with yang = (gnugo-yang (following-char))
+ with up = (get (gnugo-yy yin yang t) 'display)
+ with dn = (get (gnugo-yy yin yang) 'display)
+ for n below (length gnugo-animation-string)
+ collect (if (zerop (logand 1 n))
+ dn up))
(split-string gnugo-animation-string "" t)))
(cell (list spec))
(ovs (save-excursion
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."
(when (and (file-exists-p filename)
(not (y-or-n-p "File exists. Continue? ")))
(user-error "Not writing %s" filename))
+ (when (buffer-modified-p)
+ ;; take responsibility for our actions
+ (gnugo--set-root-prop :AP (cons "gnugo.el" gnugo-version)))
(gnugo/sgf-write-file (gnugo-get :sgf-collection) filename)
- (set-buffer-modified-p nil))
+ (gnugo--ok-file filename))
+
+(defun gnugo--dance-dance (karma)
+ (cl-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)
+ (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)
0)))
;; This is deliberately undocumented for now.
(gnugo--SZ! (gnugo--root-prop :SZ tree))
- (let (game-over)
- (gnugo-put :game-over
- (setq game-over
- (or (gnugo--root-prop :RE tree)
- (and (equal '("PASS" "PASS") (gnugo-move-history 'two))
- 'two-passes))))
- (when (and game-over
- ;; (maybe) todo: user var to inhibit (can be slow)
- t)
- (gnugo-close-game nil game-over)))
+ (when (setq game-over (or (gnugo--root-prop :RE tree)
+ (when (equal '("PASS" "PASS")
+ (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 (cl-case (following-char)
+ (?X :B)
+ (?O :W))))
+ (if (not color)
+ (unless noerror
+ (user-error "No stone at %s" pos))
+ (cl-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)))
+ (cl-case (or reaction gnugo-undo-reaction)
+ (play (turn))
+ (play! (let ((wheel (gnugo-get :wheel)))
+ (cl-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 (cl-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
+ (cl-loop
with ok = (if full
(mvno (car end))
(+ 2 (mvno (car mem))))
todo))))
until (eq mem (cdr ls))
finally do
- (loop
+ (cl-loop
for (userp pos) in todo
do (progn
(gnugo-push-move userp pos)
(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
result (gnugo-query "final_score %d" seed))
(cond ((string= "Chinese" (gnugo--root-prop :RU))
(dolist (group live)
- (incf (if (gnugo--blackp (caar group))
- b-terr
- w-terr)
- (length (cdr group))))
+ (cl-incf (if (gnugo--blackp (caar group))
+ b-terr
+ w-terr)
+ (length (cdr group))))
(dolist (group dead)
- (incf (if (gnugo--blackp (caar group))
- w-terr
- b-terr)
- (length (cdr group))))
+ (cl-incf (if (gnugo--blackp (caar group))
+ w-terr
+ b-terr)
+ (length (cdr group))))
(push (format "%s%d %s = %3.1f\n" b= b-terr terr b-terr) blurb)
(push (format "%s%d %s + %3.1f %s = %3.1f\n" w=
w-terr terr komi 'komi (+ w-terr komi))
blurb))
(t
(dolist (group dead)
- (incf (if (gnugo--blackp (caar group))
- w-terr
- b-terr)
- (* 2 (length (cdr group)))))
+ (cl-incf (if (gnugo--blackp (caar group))
+ w-terr
+ b-terr)
+ (* 2 (length (cdr group)))))
(push (format "%s%d %s + %s %s = %3.1f\n" b=
b-terr terr
b-capt capt
(cl-flet
((yep (pretty moment)
(push (format-time-string
- (concat pretty ": %Y-%m-%d %H:%M:%S %z\n")
+ (concat pretty ": %F %T %z\n")
moment)
blurb)))
(yep "Game start" beg)
(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.
- (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--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))))
+ (gnugo--climb-towards-root
+ (if (numberp count)
+ count
+ (car-safe count))))
+
+(define-minor-mode gnugo-image-display-mode
+ "If enabled, display the board using images.
+See function `display-images-p' and variable `gnugo-xpms'."
+ :variable
+ ((gnugo-get :display-using-images)
+ .
+ (lambda (bool)
+ (unless (eq bool (gnugo-get :display-using-images))
+ (gnugo-toggle-image-display)
+ (save-excursion (gnugo-refresh))))))
+
+(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
(defun gnugo-switch-to-another ()
"Switch to another GNU Go game buffer (if any)."
(interactive)
- (loop for buf in (cdr (buffer-list))
- if (gnugo-board-buffer-p buf)
- return (progn
- (bury-buffer)
- (switch-to-buffer buf))
- finally do (message "(only one)")))
+ (cl-loop
+ for buf in (cdr (buffer-list))
+ if (gnugo-board-buffer-p buf)
+ return (progn
+ (bury-buffer)
+ (switch-to-buffer buf))
+ finally do (message "(only one)")))
(defun gnugo-comment (node comment)
"Add to NODE a COMMENT (string) property.
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
- (destructuring-bind (gcolor ucolor &optional color . suggestion)
- (list* (gnugo-get :gnugo-color)
- (gnugo-get :user-color)
- (gnugo-get :waiting))
- (assert (not suggestion))
- (when (string= last-mover gcolor)
- (gnugo--ERR-wait gcolor "Sorry, too soon"))
- (when (timerp abd)
- (cancel-timer abd))
- (gnugo--forget :abd)
- (unless color
- (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
;;;---------------------------------------------------------------------------
;;; Major mode for interacting with a GNUGO subprocess
-(put 'gnugo-board-mode 'mode-class 'special)
-(defun gnugo-board-mode ()
+(define-derived-mode gnugo-board-mode special-mode "GNUGO Board"
"Major mode for playing GNU Go.
Entering this mode runs the normal hook `gnugo-board-mode-hook'.
-In this mode, keys do not self insert.
-
-\\{gnugo-board-mode-map}"
+In this mode, keys do not self insert."
(buffer-disable-undo) ; todo: undo undo undoing
- (kill-all-local-variables)
- (use-local-map gnugo-board-mode-map)
- (set (make-local-variable 'font-lock-defaults)
- '(gnugo-font-lock-keywords t))
- (setq major-mode 'gnugo-board-mode
- mode-name "GNUGO Board"
+ (setq font-lock-defaults '(gnugo-font-lock-keywords t)
truncate-lines t)
(add-hook 'kill-buffer-hook 'gnugo-cleanup nil t)
(set (make-local-variable 'gnugo-state)
(gnugo--mkht :size (1- 42)))
- (add-to-invisibility-spec :nogrid)
- (run-hooks 'gnugo-board-mode-hook))
+ (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))
+ (gnugo-put :obarray (make-vector 31 nil))
+ (add-to-invisibility-spec :nogrid))
;;;---------------------------------------------------------------------------
;;; Entry point
;;;###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))
(if (string= "" sel)
(car all)
(assoc sel all))))))
+ ;; sanity check
+ (unless (executable-find gnugo-program)
+ (user-error "Invalid `gnugo-program': %S" gnugo-program))
;; set up a new board
(switch-to-buffer (generate-new-buffer "(Uninitialized GNUGO Board)"))
(gnugo-board-mode)
- (let ((name (if (string-match "[ ]" gnugo-program)
- (let ((p (substring gnugo-program 0 (match-beginning 0)))
- (o (substring gnugo-program (match-end 0)))
- (h (or (car gnugo-option-history) "")))
- (when (string-match "--mode" 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))))
- (push (concat o " " h) gnugo-option-history))
- p)
- gnugo-program))
- (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 (cl-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) name
- "--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)
+ :DT (format-time-string "%F")
+ :RU (if (member "--chinese-rules" args)
"Chinese"
"Japanese")
- :AP (cons "gnugo.el" gnugo-version)
:KM komi)
(let ((ub (gnugo--blackp user-color)))
(r! (if ub :PW :PB) (concat "GNU Go " (gnugo-query "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
-(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)
- ("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)
- (mapc (lambda (pair)
- (define-key gnugo-board-mode-map (car pair) (cdr pair)))
- '(("?" . describe-mode)
- ("S" . gnugo-request-suggestion)
- ("\C-m" . gnugo-move)
- (" " . gnugo-move)
- ("P" . gnugo-pass)
- ("R" . gnugo-resign)
- ("q" . gnugo-quit)
- ("Q" . gnugo-leave-me-alone)
- ("U" . gnugo-fancy-undo)
- ("\M-u" . gnugo-undo-one-move)
- ("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)
- ("h" . gnugo-move-history)
- ("L" . gnugo-frolic-in-the-leaves)
- ("i" . gnugo-toggle-image-display-command)
- ("w" . gnugo-worm-stones)
- ("W" . gnugo-worm-data)
- ("d" . gnugo-dragon-stones)
- ("D" . gnugo-dragon-data)
- ("g" . gnugo-toggle-grid)
- ("!" . gnugo-estimate-score)
- (":" . gnugo-command)
- (";" . gnugo-command)
- ("=" . gnugo-describe-position)
- ("s" . gnugo-write-sgf-file)
- ("\C-x\C-s" . gnugo-write-sgf-file)
- ("\C-x\C-w" . gnugo-write-sgf-file)
- ("l" . gnugo-read-sgf-file)
- ("F" . gnugo-display-final-score)
- ("A" . gnugo-switch-to-another)
- ("C" . gnugo-comment)
- ("\C-c\C-a" . gnugo-toggle-abdication)
- ;; mouse
- ([(down-mouse-1)] . gnugo-mouse-move)
- ([(down-mouse-2)] . gnugo-mouse-move) ; mitigate accidents
- ([(down-mouse-3)] . gnugo-mouse-pass)
- ;; delving into the curiosities
- ("\C-c\C-p" . gnugo-describe-internal-properties))))
-
(unless (get 'help :gnugo-gtp-command-spec)
(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)))
+ (validpos (s &optional go)
+ (let ((pos (upcase s)))
+ (cl-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
(goto-char (point-min))
(save-excursion
(while (re-search-forward "^ *[*] \\([a-zA-Z_]+\\)\\(:.*\\)*\n"
- (point-max) t)
+ nil t)
(unless pad
(setq pad (make-string (- (match-beginning 1)
(match-beginning 0))
(when (setq output (plist-get spec :output))
(if (functionp output)
(note "handles the output specially")
- (case output
+ (cl-case output
(:discard (note "discards the output"))
(:message (note "displays the output in the echo area")))))
(when (eq sel cur)
- (setq found (match-beginning 0))))))
- (cond (found (goto-char found))
+ (setq found (make-marker))
+ (set-marker found (match-beginning 0))))))
+ (cond (found (goto-char found) (set-marker found nil))
((not sel))
(t (message "(no such command: %s)" sel)))))
(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)
(specs (or (get 'gnugo/sgf-*r4-properties* :specs)
(put 'gnugo/sgf-*r4-properties* :specs
(mapcar (lambda (full)
- (cons (car full) (cdddr full)))
+ (cons (car full) (cl-cdddr full)))
gnugo/sgf-*r4-properties*))))
SZ)
(cl-labels
((sw () (skip-chars-forward " \t\n"))
(x (end preserve-whitespace)
(let ((beg (point))
- (endp (case end
+ (endp (cl-case end
(:end (lambda (char) (= ?\] char)))
(:mid (lambda (char) (= ?\: char)))
(t (lambda (char) (or (= ?\: char)
(one (type end) (let ((s (progn
(forward-char 1)
(x end (eq 'text type)))))
- (case type
+ (cl-case type
((stone point move)
;; blech, begone bu"tt"-ugly blatherings
;; (but bide brobdingnagian boards)...
;; probably this assumption is consistent
;; w/ the SGF authors' desire to make the
;; parsing easy, but you never know...
- (cons v (one (cdaddr spec) :end)))))
+ (cons v (one (cl-cdaddr spec) :end)))))
(t (cons (one (car spec) :mid)
(one (cdr spec) :end)))))
(short (who) (when (eobp)
(forward-char 1)
t))
(NODE () (when (seek-into ?\;)
- (loop with prop
- while (setq prop (PROP))
- collect (progn
- (when (eq :SZ (car prop))
- (setq SZ (cdr prop)))
- prop))))
+ (cl-loop
+ with prop
+ while (setq prop (PROP))
+ collect (progn
+ (when (eq :SZ (car prop))
+ (setq SZ (cdr prop)))
+ prop))))
(TREE (parent mnum)
(let ((ls parent)
prev node)
;; singular
(list ls)
;; multiple
- (loop while (seek ?\()
- append (TREE ls mnum)))
+ (cl-loop
+ while (seek ?\()
+ append (TREE ls mnum)))
(seek-into ?\))))))
(with-temp-buffer
(if (not data-p)
(insert-file-contents file-or-data)
(insert file-or-data)
(goto-char (point-min)))
- (loop while (morep)
- collect (let* ((mnum (gnugo--mkht :weakness 'key))
- (ends (TREE nil mnum))
- (root (car (last (car ends)))))
- (vector (apply 'vector ends)
- mnum
- root)))))))
+ (cl-loop
+ while (morep)
+ 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)
(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)))
+ (cl-cdddr full)))
gnugo/sgf-*r4-properties*))
p name v spec)
(cl-labels
((esc (composed fmt arg)
(mapconcat (lambda (c)
- (case c
+ (cl-case c
;; ‘?\[’ is not strictly required
;; but neither is it forbidden.
((?\[ ?\] ?\\) (format "\\%c" c))
(t
(>>one v) (>>nl))))
(>>node (node)
- (loop initially (insert ";")
- for prop in node
- do (>>prop prop)))
+ (cl-loop
+ initially (insert ";")
+ for prop in node
+ do (>>prop prop)))
(>>tree (tree)
(unless (zerop (current-column))
(newline))
(insert ")")))
(with-temp-buffer
(dolist (tree collection)
- ;; 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
+ (cl-loop
with rh ; rectified history
with bp ; branch point
for node in stack