;; 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.")
For more information on GTP and GNU Go, please visit:
<http://www.gnu.org/software/gnugo>")
-(defvar gnugo-board-mode-map nil
+(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)
;;;---------------------------------------------------------------------------
`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
(dolist (key keys)
(remhash key gnugo-state)))
-(defun gnugo--instant-karma (color add/del)
- (assert (string= color (gnugo-get :user-color)))
- (setq gnugo-btw (when add/del
- " Abd"))
- (force-mode-line-update))
-
(defsubst gnugo--tree-mnum (tree)
(aref tree 1))
(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))
(defsubst gnugo--prop<-color (color)
(if (gnugo--blackp color) :B :W))
-(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))
-
(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!"))
- (destructuring-bind (&optional color . suggestion)
+ (cl-destructuring-bind (&optional color . suggestion)
(gnugo-get :waiting)
(when color
- (apply 'gnugo--ERR-wait
+ (apply 'user-error
+ "%s -- please wait for \"(%s to play)\""
(if suggestion
- (list color
- "Still thinking")
- (list (gnugo-other color)
- "Not your turn yet")))))
- (gnugo--gate-game-over in-progress-p))
+ (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)))
(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))
(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)
(`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)))
+ (`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)
(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)))
(format "%c%c" one two)))))
(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)))
+ (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)
;;
;; 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.
(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)
(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))
(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))))))
(full (gnugo-put :get-move-string (concat so-far string))))
(when (string-match "^= \\(.+\\)\n\n" full)
(setq full (match-string 1 full)) ; POS or "PASS"
- (destructuring-bind (color . suggestion)
+ (cl-destructuring-bind (color . suggestion)
(gnugo-get :waiting)
(gnugo--forget :get-move-string
:waiting)
(eq 'nowarp suggestion))
(gnugo-goto-pos full))
(gnugo--display-suggestion color full))
- (let* ((donep (gnugo-push-move color full))
- (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-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 ()
'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)
;; 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* ((gcolor (gnugo-get :gnugo-color))
- (userp (string= gcolor (gnugo-get :last-mover)))
- (donep (gnugo-push-move userp pos-or-pass))
- (buf (current-buffer)))
- (gnugo--finish-move buf)
- (when (and userp (not donep))
- (with-current-buffer buf
- (gnugo-get-move gcolor)))))
+ (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
(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--mem-with-played-stone (pos &optional noerror)
- (let ((color (case (following-char)
+ (let ((color (cl-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 noalt keep)
+ (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)
+ (gnugo--assist-state t)
(let* ((user-color (gnugo-get :user-color))
(monkey (gnugo-get :monkey))
(tree (gnugo-get :sgf-gametree))
2)
spec)
(aref monkey 0))
- (let* ((pos (if (stringp spec)
- spec
- (gnugo-position)))
- (hmm (gnugo--mem-with-played-stone pos)))
- ;; todo: relax ‘gnugo--user-play’ then lift restriction
- (unless (eq (gnugo--prop<-color user-color)
- (car (gnugo--move-prop (car hmm))))
- (user-error "%s not occupied by %s"
- pos user-color))
- (cdr hmm)))))
+ (cdr (gnugo--mem-with-played-stone
+ (if (stringp spec)
+ spec
+ (gnugo-position)))))))
(when (gnugo-get :game-over)
(gnugo--unclose-game))
(while (and (not (eq stop (aref monkey 0)))
(gnugo-refresh) ; this
(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).
(gnugo-gate)
(when me-next
(let* ((play (gnugo-get :last-mover))
- (wait (gnugo-other play)))
- (gnugo--who-is-who wait play (string= play (gnugo-get :user-color)))
+ (wait (gnugo-other play))
+ (samep (string= play (gnugo-get :user-color))))
(gnugo-put :user-color play)
- (gnugo-put :gnugo-color wait)))
- (gnugo--climb-towards-root 1 t))
+ (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--climb-towards-root 0))
(defun gnugo-oops (&optional position)
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--climb-towards-root (unless position
0)
nil t))
(ucolor (gnugo-get :user-color))
(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)
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)
which placed the stone at point."
(interactive "P")
(gnugo--climb-towards-root
- (cond ((numberp count) count)
- ((consp count) (car count)))))
-
-(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)))
+ (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-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.
(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.
-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')."
- (interactive)
- (let ((u (gnugo-get :user-color))
- (last-mover (gnugo-get :last-mover))
- (abd (gnugo-get :abd)))
- (if abd
+(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))
- (waiting (gnugo-get :waiting))
- (userp (string= last-mover gcolor)))
- (when (timerp abd)
- (cancel-timer abd))
- (gnugo--forget :abd)
- (when (and userp waiting)
+ (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 u)))
+ (gnugo-move-history 'bpos color)))
'nowarp))
- (gnugo--display-suggestion u "forthcoming")
- (sleep-for 2))
- (unless (or userp waiting)
- (gnugo-get-move gcolor)))
- ;; enable
- (gnugo-gate t)
- (gnugo-put :abd t)
- (gnugo-get-move (gnugo-other last-mover)))
- (gnugo--instant-karma u (not abd))))
+ (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
(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
(setq font-lock-defaults '(gnugo-font-lock-keywords t)
truncate-lines t)
(overlay-put ov 'display ")")
ov)))
(gnugo-put :mul '(1 . 1))
+ (gnugo-put :obarray (make-vector 31 nil))
(add-to-invisibility-spec :nogrid))
;;;---------------------------------------------------------------------------
(gnugo-board-mode)
(let* ((filename nil)
(user-color "black")
- (args (loop
+ (args (cl-loop
with ls = (split-string
;; todo: grok ‘gnugo --help’; completion
(read-string
(when (and (zerop handicap) actually)
(setq handicap (string-to-number (cadr actually)))))
(r! :SZ board-size
- :DT (format-time-string "%Y-%m-%d")
+ :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"))
(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 (and (not (gnugo-get :game-over))
- (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-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)
- ("\C-c\C-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))
(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))))
+ (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))
(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)))))
(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