[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[elpa] master 6160089: * externals-list: Convert gnugo to :external
|
From: |
Stefan Monnier |
|
Subject: |
[elpa] master 6160089: * externals-list: Convert gnugo to :external |
|
Date: |
Sun, 29 Nov 2020 14:52:00 -0500 (EST) |
branch: master
commit 61600893f3f33e3c80650332e472f0a1aa66857f
Author: Stefan Monnier <monnier@iro.umontreal.ca>
Commit: Stefan Monnier <monnier@iro.umontreal.ca>
* externals-list: Convert gnugo to :external
---
externals-list | 11 +-
packages/gnugo/.dir-locals.el | 5 -
packages/gnugo/HACKING | 86 --
packages/gnugo/NEWS | 240 ----
packages/gnugo/README | 6 -
packages/gnugo/THANKS | 13 -
packages/gnugo/gnugo-frolic.el | 509 -------
packages/gnugo/gnugo-imgen.el | 258 ----
packages/gnugo/gnugo.el | 2866 ----------------------------------------
9 files changed, 6 insertions(+), 3988 deletions(-)
diff --git a/externals-list b/externals-list
index e918af2..9b2b310 100644
--- a/externals-list
+++ b/externals-list
@@ -91,7 +91,7 @@
("f90-interface-browser" :external "https://github.com/wence-/f90-iface";)
("flymake" :core "lisp/progmodes/flymake.el")
("frog-menu" :external "https://github.com/clemera/frog-menu";)
- ("fsm" :external nil)
+ ("fsm" :external nil)
("gcmh" :external "https://gitlab.com/koral/gcmh";)
("ggtags" :external "https://github.com/leoliu/ggtags";)
("gited" :external nil)
@@ -99,6 +99,7 @@
("gnome-c-style" :external "https://github.com/ueno/gnome-c-style.git";)
("gnorb" :external nil) ;; Was "https://github.com/girzel/gnorb";
("gnu-elpa" :external nil)
+ ("gnugo" :external nil)
("gpastel" :external
"https://gitlab.petton.fr/DamienCassou/gpastel";)
("greader" :external
"https://gitlab.com/michelangelo-rodriguez/greader";)
("guess-language" :external
"https://github.com/tmalsburg/guess-language.el";)
@@ -115,7 +116,7 @@
("leaf" :external "https://github.com/conao3/leaf.el";)
("let-alist" :core "lisp/emacs-lisp/let-alist.el")
("lmc" :external nil)
- ("load-dir" :external nil)
+ ("load-dir" :external nil)
("map" :core "lisp/emacs-lisp/map.el")
("markchars" :external nil)
("math-symbol-lists" :external
"https://github.com/vspinu/math-symbol-lists.git";)
@@ -130,13 +131,14 @@
("names" :external "http://github.com/Malabarba/names";)
("nhexl-mode" :external nil)
("nlinum" :external nil)
+ ("ntlm" :core "lisp/net/ntlm.el")
("num3-mode" :external nil)
("objed" :external "https://github.com/clemera/objed";)
("omn-mode" :external nil)
+ ("on-screen" :external
"https://github.com/michael-heerdegen/on-screen.el.git";)
+ ;;FIXME:("org" :external ??) ;; Need to introduce snapshots!!
("orgalist" :external nil)
("org-edna" :external
"https://savannah.nongnu.org/projects/org-edna-el";) ;URL?
- ("ntlm" :core "lisp/net/ntlm.el")
- ("on-screen" :external
"https://github.com/michael-heerdegen/on-screen.el.git";)
("pabbrev" :external "https://github.com/phillord/pabbrev.git";)
("parsec" :external
"https://github.com/cute-jumper/parsec.el.git";)
("peg" :external) ;Was in
"https://github.com/ellerh/peg.el";
@@ -154,7 +156,6 @@
;; -- -- pspp-mode.el
("pspp-mode" :external nil) ;; Was
"https://git.sv.gnu.org/r/pspp.git";
("python" :core "lisp/progmodes/python.el")
- ;;FIXME:("org" :external ??) ;; Need to introduce snapshots!!
("rbit" :external nil)
("rcirc-color" :external nil)
("realgud" :external "https://github.com/realgud/realgud";)
diff --git a/packages/gnugo/.dir-locals.el b/packages/gnugo/.dir-locals.el
deleted file mode 100644
index 8941f58..0000000
--- a/packages/gnugo/.dir-locals.el
+++ /dev/null
@@ -1,5 +0,0 @@
-;;; .dir-locals.el
-
-((emacs-lisp-mode . ((indent-tabs-mode . nil))))
-
-;;; .dir-locals.el ends here
diff --git a/packages/gnugo/HACKING b/packages/gnugo/HACKING
deleted file mode 100644
index f2b0f4e..0000000
--- a/packages/gnugo/HACKING
+++ /dev/null
@@ -1,86 +0,0 @@
-HACKING gnugo -*- org -*-
-
-This file is both a guide for newcomers and a todo list for oldstayers.
-
-* next
-*** newbie support
-***** "don't panic" button :-D
-***** on gnugo.el load, check
[[file:gnugo.el::defvar.gnugo-program][gnugo-program]], set "ready" state
-***** rat concessions :-/
-***** (?) ootb ‘gnugo-image-display-mode’ in ‘gnugo-start-game-hook’
-* fix bugs
-*** empty tree from many back/forw
-***** intermittent, grr
-***** manifests as ‘()’ (empty list) in .sgf (on write)
-*** {next,previous}-line weirdness in the presence of images
-*** no error-handling in SGF parsing
-* performance
-*** ‘compare-strings’ approach too clever/slow :-/
-*** cache frolic fruits
-* ideas / wishlist
-*** wrap GTP ‘loadsgf’ completely
-*** revamp image support
-***** DONE zonk ‘require’
-***** define simple API
-*** talk GTP over the network
- (?) pending [[wrap GTP ‘loadsgf’ completely]]
-*** make gnugo (the external program) support query (read-only) thread
-*** extend GNUGO Board mode to manage another subprocess for analysis only
-*** command to label a position
-*** SGF tree traversal
-***** DONE monkey mind
-***** TODO monkey body
-*** "undo undo undoing"
-***** integrate Emacs undo, GTP undo, subgame branching
-***** (?) use [[file:../undo-tree/][../undo-tree/]]
-*** make buffer name format configurable (but enforce uniqueness)
-*** more tilde escapes for
[[file:gnugo.el::defvar.gnugo-mode-line][gnugo-mode-line]]
-*** make veneration configurable (see also [[SVG display]])
-*** animation finery
-***** make more configurable
-***** lift same-color-stones-only restriction
-***** allow sequencing rather than lock-step
-***** include sound
-*** plunder el-go (grok [[info:eieio.info][EIEIO]] first)
-***** SVG display
- pending [[revamp image support]]
-***** (?) SGF support
-******* IR compat
-******* error handling
-***** (?) other "backends"
- pending [[talk GTP over the network]]
-*** [your hacking ideas here!]
-* tested with (newest first)
- | Emacs | GNU Go |
- |-----------+--------|
- | 26.0.50.6 | 3.8 |
- | 24.3.50.3 | 3.8 |
- | ? | 3.6 |
- | ? | 3.4 |
- | ? | 3.3.15 |
- | 22.0.50 | ? |
- | 21.3 | ? |
- |-----------+--------|
- | <l> | <l> |
-* ChangeLog discipline
-*** based on [[info:standards#Change%20Logs][GNU Coding Standards]]
-*** commit-message format
-***** basic: TITLE LF LF [DISCUSSION...] LF LF CLASSIC
-***** short: TITLE-FRAGMENT "; nfc." [LF LF DISCUSSION...]
-*** don't bother w/ ChangeLog for "short" commit-message format
-* copyright policy
-*** update every year, unconditionally
-*** (if (< 2 (- END BEGIN)) RANGE INDIVIDUAL)
-* other conventions: see [[file:.dir-locals.el][.dir-locals.el]]
-* NEWS nostalgia
-(with-current-buffer (find-file "NEWS")
- (highlight-phrase "[0-9][.][0-9][.][0-9]+\\|[0-9]+[.][.][0-9]+"
- 'hi-red-b))
-* etc
-#+odd
-
-
-Copyright (C) 2014-2020 Free Software Foundation, Inc.
-
-Copying and distribution of this file, with or without modification,
-are permitted provided the copyright notice and this notice are preserved.
diff --git a/packages/gnugo/NEWS b/packages/gnugo/NEWS
deleted file mode 100644
index c35de50..0000000
--- a/packages/gnugo/NEWS
+++ /dev/null
@@ -1,240 +0,0 @@
-NEWS for gnugo.el (et al)
-See the end for copying conditions.
-
-NB: "RCS: X..Y " means that the particular release includes
- changes in the RCS repo, revision 1.X through 1.Y (inclusive).
-
-
-- 3.1.1 | 2020-10-24
- - bugfix: use ‘cursor-intangible-mode’ properly
- - new func: gnugo-imgen-fit-window-height/no-grid-bottom
- - more docstrings
-
-- 3.1.0 | 2017-02-17
- - THANKS file includes pre-ELPA people
- - bugfix: refresh no longer clobbers dead-group indication
- - echo area messages (normal and error) more conventional
- - ‘C’ (gnugo-comment) defaults to root node if no played stone at point
- - ‘C-c C-p’ (gnugo-describe-internal-properties) output more spacious
- - ‘C-u F’ (gnugo-display-final-score) stores additional SGF properties
- - ‘TB’ -- Black Territory
- - ‘TW’ -- White Territory
- - ‘MA’ -- Mark (to indicate seki stones)
- - ‘DD’ -- Dim Points (to indicate dead stones)
- - game-over seki groups (if any) indicated on board
- - changes to programming interface
- - dropped data structures (unused => NOT backward-incompatible)
- - ‘gnugo-board-mode-syntax-table’
- - ‘gnugo-board-mode-abbrev-table’
- - game-over "group" formalized: ‘((CPROP [OVERLAY[...]]) POS[...])’
- - game-over data includes seki groups
- - ‘gnugo-goto-pos’ returns buffer position
- - new abstraction: ‘gnugo-aqr’
-
-- 3.0.2 | 2017-02-05
- - portability fix (Emacs 25.1): use Cursor Intangible mode, if available
- - verse meter fix (for those who read source code)
- - new THANKS file
-
-- 3.0.1 | 2017-01-15
- - cleaner quoting in docstrings
- - portabilty fixes (Emacs 25.1)
-
-- 3.0.0 | 2014-07-22
- - bugfixes
- - on write, use ‘\’ to escape certain chars
- - preserve whitespace for value type ‘text’
- - don't special-case property value type ‘none’
- - handle subtrees on write
- - display "resign" as "resign" in move history (amazing!)
- - avoid clobbering SGF property ‘EV’ on resignation
- - follow main line in subtrees on read
- - for ‘F’ forced PASS moves, keep subproc informed as well
- - proper support for ‘-l FILENAME’ / ‘--infile FILENAME’
- - dropped support for ‘gnugo-program’ of form "PROGRAM OPTIONS..."
- - dropped command: ‘t’ (gnugo-toggle-dead-group)
- - changes to ‘gnugo-xpms’
- - now a normal var, and not a feature
- - value can be a function to compute XPMs
- - ‘gnugo-image-display-mode’ replaces ‘gnugo-toggle-image-display-command’
- - ‘gnugo-grid-mode’ replaces ‘gnugo-toggle-grid’
- - PASS for SZ <= 19 normalized to "" on read, written as ""
- - ‘=’ also displays move number of the stone (if any) at that position
- - ‘C-u F’ adds the (abbreviated) blurb as a comment to the last node
- - new keybinding for ‘gnugo-undo-one-move’: M-u
- - you can play a move for GNU Go, e.g., after ‘M-u’
- - ‘gnugo-undo-one-move’ can optionally arrange for you to play next
- - new command: ‘S’ (gnugo-request-suggestion)
- - new command: ‘C’ (gnugo-comment)
- - new command: ‘o’ (gnugo-oops)
- - new command: ‘O’ (gnugo-okay)
- - new command: ‘L’ (gnugo-frolic-in-the-leaves)
- - new command: ‘C-c C-a’ (gnugo-assist-mode)
- - new command: ‘C-c C-z’ (gnugo-zombie-mode)
- - new var: gnugo-undo-reaction
- - new major mode: GNUGO Frolic (gnugo-frolic-mode)
- - separate feature/file: ‘gnugo-frolic’
- - ‘gnugo-frolic-in-the-leaves’ autoloaded
- - new support for dynamic XPM generation
- - separate feature/file: ‘gnugo-imgen’
- - func ‘gnugo-imgen-create-xpms’ suitable for ‘gnugo-xpms’ (see above)
- - GNUGO Board mode now derived from Special mode
- - position arg validated for direct GTP commands ‘undo’, ‘gg-undo’
- - undo commands no longer signal error on overkill
- - SGF prop ‘AP’ set only for modified gametrees
- - SGF I/O commands change ‘default-directory’
- - performance improvements
- - of interest to hackers (see source, BI => backward incompatible)
- - dropped var: ‘gnugo-inhibit-refresh’ (BI)
- - ‘gnugo/sgf-read-file’ renamed to ‘gnugo/sgf-create’ and enhanced
- - ‘:sgf-gametree’ internal representation inverted (BI)
- - ‘gnugo-magic-undo’ internalized
- - new func: ‘gnugo-current-player’
- - new hook: ‘gnugo-start-game-hook’
- - ‘gnugo-board-mode-hook’ now unsuitable for prop munging (BI)
- - changes to ‘gnugo-move-history’
- - dropped ‘(gnugo-move-history 'count)’ (BI)
- - returns last two moves w/ RSEL ‘two’
- - returns position of last placed stone w/ RSEL ‘bpos’ + 2nd arg COLOR
-
-- 2.3.1 | 2014-02-27
- - portability fixes
-
-- 2.3.0 | 2014-02-24
- - now part of ELPA, tweaked for GNU Emacs 24.x
- - dropped support for XEmacs and older Emacs
- - use ‘user-error’ for user errors
- - bugfixes
- - handle sudden jump in captured stones correctly
- - rename hook-communication var w/ "gnugo-" prefix
- - (w/ images) grid top/bottom row spacing
- - on SGF save/load indicate buffer not modified
- - documentation improvements
- - version numbering scheme documented: MAJOR.MINOR.PATCH
- - keybinding constructs for ‘gnugo’ and ‘gnugo-board-mode’
- - message for worm/dragon animation avoids underscore
- - new commands
- - ‘A’ (gnugo-switch-to-another)
- - ‘_’ and ‘M-_’ (gnugo-boss-is-near) -- was ‘bury-buffer’
- - new keybinding for ‘gnugo-undo-two-moves’: DEL
-
-- 2.2.14 | 2008-03-03
- - start error message w/ a capital letter
- - use ‘(error "%s" X)’ instead of ‘(error X)’
- - improve ‘gnugo-animation-string’ docstring
-
-- 2.2.13 | 2006-04-10
- - grid (letters and numbers) visibility can be toggled
- - display bug workaround
- - performance improvements
-
-- 2.2.12 | 2006-04-06
- - bugfix: handle "" as "PASS"
-
-- 2.2.11 | 2005-04-06
- - new mode-line specifier: ‘~m’
- - directory no longer accepted as SGF "file name"
-
-- 2.2.10 | 2005-02-04
- - bugfix: detect "game over" more precisely
- - new command: ‘C-c C-p’ (gnugo-describe-internal-properties)
- - don't include comment in sgf write
- - set ‘AP’ (application) property in gametree
-
-- 2.2.9 | 2004-12-29
- - backward-portability fix
-
-- 2.2.8 | 2004-11-15
- - new command: ‘h’ (gnugo-move-history)
- - improve font-lock support
- - support "count of moves" SPEC via prefix-arg to ‘U’
-
-- 2.2.7 | 2004-11-10
- - bugfix: inform backend of PASS
- - new command: ‘u’ (gnugo-undo-two-moves)
-
-- 2.2.6 | 2004-11-05
- - new commands
- - ‘l’ (gnugo-read-sgf-file)
- - ‘U’ (lambda that calls ‘gnugo-magic-undo’)
- - doc improvements
- - make some load-time actions one-shot
-
-- 2.2.5 | 2004-11-02
- - bugfix: make load-time actions referentially-transparent
- - require Emacs w/ ‘gethash’, ‘puthash’, ‘make-hash-table’
-
-- 2.2.4 | 2004-11-01
- - backward-portability fixes
-
-- 2.2.3 | 2004-10-30
- - backward-portability fixes
- - new command: ‘R’ (gnugo-resign)
-
-- 2.2.2 | 2004-10-29
- - backward-portability fixes
-
-- 2.2.1 | 2004-09-07
- - SGF bugfix: parse float correctly (for komi)
- - new command: ‘F’ (gnugo-display-final-score)
- - font-locking for "X", "O", "[xo]"
-
-- 2.2.0 | 2004-08-30
- - uncluttered, letters and numbers hidden, board centered
- - buffer name shows last move and current player
- - mode-line customization (var ‘gnugo-mode-line’)
- - new commands
- - ‘=’ -- display current position in echo area
- - ‘s’ (gnugo-write-sgf-file)
- - program option customization (var ‘gnugo-program’)
- - new hooks
- - ‘gnugo-post-move-hook’
- - ‘gnugo-board-mode-hook’
- - multiple independent buffers/games
- - XPM set can be changed on the fly (global and/or local)
- - RCS: 25..26 (1.24-1.26 diff posted 2003-01-28)
-
-- 2.1.0 | 2003-01-10
- - doc fixes
- - add XPM image support
- - new keybinding: ‘;’ (gnugo-command)
- - new commands:
- - ‘i’ -- toggle image display
- - ‘mouse-down-1’ (gnugo-mouse-move)
- - ‘mouse-down-3’ (gnugo-mouse-pass)
- - ‘gnugo-command’ rewrite
- - RCS: 19..24
-
-- 2.0.1 | 2002-11-16
- - more docstrings
- - say "GNU Go" instead of "GNU GO"
- - reverse output order of captured stones
- - new commands: ‘_’ and ‘M-_’ (bury-buffer)
- - simplified buffer management
- - RCS: 15..18
-
-- 2.0.0 | 2002-11-15
- - rewrite to use Go Text Protocol
- - bugfix: don't set process coding system
- - handle change in process status
- - new user var: ‘gnugo-option-history’
- - use calculated screen columns
- - improve error handling in ‘gnugo-cleanup’
- - new command: ‘:’ (gnugo-command)
- - resume game if in progress, w/ confirmation
- - new command: ‘M-_’ (gnugo-bury)
- - autoload gnugo.el on command ‘gnugo’
- - doc improvements
- - RCS: 1..14
-
-
- Local Variables:
- mode: outline
- outline-regexp: "\\([ ][ ]\\)*- "
- End:
-
-_____________________________________________________________________
-Copyright (C) 2014-2020 Free Software Foundation, Inc.
-
-Copying and distribution of this file, with or without modification,
-are permitted provided the copyright notice and this notice are preserved.
diff --git a/packages/gnugo/README b/packages/gnugo/README
deleted file mode 100644
index 897feab..0000000
--- a/packages/gnugo/README
+++ /dev/null
@@ -1,6 +0,0 @@
-This directory contains gnugo.el and other files.
-These work w/ GNU Go:
-
- http://www.gnu.org/software/gnugo
-
-and any other program that speaks the Go Text Protocol.
diff --git a/packages/gnugo/THANKS b/packages/gnugo/THANKS
deleted file mode 100644
index dd994dd..0000000
--- a/packages/gnugo/THANKS
+++ /dev/null
@@ -1,13 +0,0 @@
-These people have helped to improve gnugo.el (et al).
-
- Stefan Monnier
- Paul Eggert
- Juanma Barranquero
- Mike FABIAN
- Len Trigg
- Gunnar Farnebäck
- Douglas Ridgway
- Daniel Bump
-
-If you are not here, but should be, that's a bug -- please accept
-our apologies for the oversight, and report it, so we can DTRT!
diff --git a/packages/gnugo/gnugo-frolic.el b/packages/gnugo/gnugo-frolic.el
deleted file mode 100644
index 4129971..0000000
--- a/packages/gnugo/gnugo-frolic.el
+++ /dev/null
@@ -1,509 +0,0 @@
-;;; gnugo-frolic.el --- gametree in a buffer -*- lexical-binding: t -*-
-
-;; Copyright (C) 2014-2020 Free Software Foundation, Inc.
-
-;; Author: Thien-Thi Nguyen <ttn@gnu.org>
-;; Maintainer: Thien-Thi Nguyen <ttn@gnu.org>
-
-;; 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
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Code:
-
-(require 'cl-lib)
-(require 'gnugo)
-(require 'ascii-art-to-unicode) ; for `aa2u'
-
-(defvar gnugo-frolic-mode-map
- (let ((map (make-sparse-keymap)))
- (suppress-keymap map)
- (mapc (lambda (pair)
- (define-key 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)
- ("t" . gnugo-frolic-tip-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)))
- map)
- "Keymap for GNUGO Frolic mode.")
-
-(defvar gnugo-frolic-parent-buffer nil)
-(defvar gnugo-frolic-origin nil)
-
-(define-derived-mode gnugo-frolic-mode special-mode "GNUGO Frolic"
- "A special mode for manipulating a GNUGO gametree."
- (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))))))
-
-;;;###autoload
-(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 (cl-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
- (cl-loop
- for bx below width
- do (cl-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)
- (cl-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
- (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))
- (cl-loop
- with props
- for n ; move number
- from max-move-num downto 1
- do (setq props (list 'n n))
- do
- (cl-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 `(bx ,bx ,@props))
- (ok (when node
- (= bx (on node))))
- (comment (when ok
- (gnugo-aqr :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)
- (cl-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)
- ;; (omit . [VAR...])
- ;; Invalid elements blissfully ignored. :-D
- (let* ((tree (gnugo-get :sgf-gametree))
- (ends (gnugo--tree-ends tree))
- (width (length ends))
- (monkey (gnugo-get :monkey))
- (line (cl-case (gnugo-aqr '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")))
- (cl-loop
- with omit = (gnugo-aqr '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))
- `(cl-destructuring-bind
- ,(cl-loop
- with omit = (gnugo-aqr '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)))
- (cl-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 (cl-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))))
- (cl-loop
- while (not (= line stop))
- do (cl-loop
- do (progn
- (forward-line direction)
- (cl-incf line direction))
- until (get-text-property (point) 'n))
- until (zerop (cl-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-frolic-tip-move ()
- "Move to the tip of the current branch."
- (interactive)
- (gnugo--awakened ((omit line bidx monkey width)
- require-valid-branch)
- (goto-char (point-max))
- (let ((mnum (gnugo--tree-mnum tree))
- (node (car (aref ends a))))
- (re-search-backward (format "^%3d" (gethash node mnum)))
- (gnugo--move-to-bcol a))))
-
-;;;---------------------------------------------------------------------------
-;;; that's it
-
-(provide 'gnugo-frolic)
-
-;;; gnugo-frolic.el ends here
diff --git a/packages/gnugo/gnugo-imgen.el b/packages/gnugo/gnugo-imgen.el
deleted file mode 100644
index 4044256..0000000
--- a/packages/gnugo/gnugo-imgen.el
+++ /dev/null
@@ -1,258 +0,0 @@
-;;; gnugo-imgen.el --- image generation -*- lexical-binding: t -*-
-
-;; Copyright (C) 2014-2020 Free Software Foundation, Inc.
-
-;; Author: Thien-Thi Nguyen <ttn@gnu.org>
-;; Maintainer: Thien-Thi Nguyen <ttn@gnu.org>
-
-;; 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
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; This file provides func `gnugo-imgen-create-xpms', suitable as
-;; value for `gnugo-xpms', and several variables to configure it:
-;;
-;; `gnugo-imgen-styles'
-;; `gnugo-imgen-style'
-;; `gnugo-imgen-sizing-function'
-;;
-;; There is also one command: `gnugo-imgen-clear-cache'.
-
-;;; Code:
-
-(require 'xpm)
-(require 'xpm-m2z)
-(require 'cl-lib)
-
-(defvar gnugo-imgen-styles
- '((d-bump ; thanks
- :background "#FFFFC7C75252"
- :grid-lines "#000000000000"
- :circ-edges "#C6C6C3C3C6C6"
- :white-fill "#FFFFFFFFFFFF"
- :black-fill "#000000000000")
- (ttn ; this guy must live in a cave
- :background "#000000000000"
- :grid-lines "#AAAA88885555"
- :circ-edges "#888888888888"
- :white-fill "#CCCCCCCCCCCC"
- :black-fill "#444444444444"))
- "Alist of styles suitable for `gnugo-imgen-create-xpms'.
-The key is a symbol naming the style. The value is a plist.
-Here is a list of recognized keywords and their meanings:
-
- :background -- string that names a color in XPM format, such as
- :grid-lines \"#000000000000\" or \"black\"; the special string
- :circ-edges \"None\" makes that component transparent
- :white-fill
- :black-fill
-
-All keywords are required and color values cannot be nil.
-This restriction may be lifted in the future.")
-
-(defvar gnugo-imgen-style nil
- "Which style in `gnugo-imgen-styles' to use.
-If nil, `gnugo-imgen-create-xpms' defaults to the first one.")
-
-(defvar gnugo-imgen-sizing-function 'gnugo-imgen-fit-window-height
- "Function to compute XPM image size from board size.
-This is called with one arg, integer BOARD-SIZE, and should return
-a number (float or integer), the number of pixels for the side of
-a square position on the board. A value less than 8 is taken as 8.")
-
-(defvar gnugo-imgen-cache (make-hash-table :test 'equal))
-
-(defun gnugo-imgen-clear-cache ()
- "Clear the cache."
- (interactive)
- (clrhash gnugo-imgen-cache))
-
-(defun gnugo-imgen--fit (board-size ignored-grid-lines)
- (cl-destructuring-bind (L top R bot)
- (window-inside-absolute-pixel-edges)
- (ignore L R)
- (/ (float (- bot top (* (frame-char-height)
- ignored-grid-lines)))
- board-size)))
-
-(defun gnugo-imgen-fit-window-height (board-size)
- "Return the dimension (in pixels) of a square for BOARD-SIZE.
-This uses the TOP and BOTTOM components as returned by
-`window-inside-absolute-pixel-edges' and subtracts twice
-the `frame-char-height' (to leave space for the grid)."
- (gnugo-imgen--fit board-size 2))
-
-(defun gnugo-imgen-fit-window-height/no-grid-bottom (board-size)
- "Return the dimension (in pixels) of a square for BOARD-SIZE.
-This uses the TOP and BOTTOM components as returned by
-`window-inside-absolute-pixel-edges' and subtracts the
-`frame-char-height' (to leave top-line space for the grid)."
- (gnugo-imgen--fit board-size 1))
-
-(defconst gnugo-imgen-palette '((32 . :background)
- (?. . :grid-lines)
- (?X . :circ-edges)
- (?- . :black-fill)
- (?+ . :white-fill)))
-
-(defun gnugo-imgen-create-xpms-1 (square style)
- (let* ((kws (mapcar 'cdr gnugo-imgen-palette))
- (roles (mapcar 'symbol-name kws))
- (palette (cl-loop
- for px in (mapcar 'car gnugo-imgen-palette)
- for role in roles
- collect (cons px (format "s %s" role))))
- (resolved (cl-loop
- with parms = (copy-sequence style)
- for role in roles
- for kw in kws
- collect (cons role (plist-get parms kw))))
- (sq-m1 (1- square))
- (half (/ sq-m1 2.0))
- (half-m1 (truncate (- half 0.5)))
- (half-p1 (truncate (+ half 0.5)))
- (background (make-vector 10 nil))
- (foreground (make-vector 4 nil))
- rv)
- (cl-flet
- ((workbuf (n)
- (xpm-generate-buffer (format "%d_%d" n square)
- square square 1 palette))
- (replace-from (buffer)
- (erase-buffer)
- (insert-buffer-substring buffer)
- (xpm-grok t))
- (nine-from-four (N E W S)
- (list (list E S)
- (list E W S)
- (list W S)
- (list N E S)
- (list N E W S)
- (list N W S)
- (list N E )
- (list N E W )
- (list N W )))
- (mput-points (px ls)
- (dolist (coord ls)
- (apply 'xpm-put-points px coord))))
- ;; background
- (cl-loop
- for place from 1 to 9
- for parts
- in (cl-flet*
- ((vline (x y1 y2) (list (list x (cons y1 y2))))
- (v-expand (y1 y2) (append (vline half-m1 y1 y2)
- (vline half-p1 y1 y2)))
- (hline (y x1 x2) (list (list (cons x1 x2) y)))
- (h-expand (x1 x2) (append (hline half-m1 x1 x2)
- (hline half-p1 x1 x2))))
- (nine-from-four (v-expand 0 half-p1)
- (h-expand half-m1 sq-m1)
- (h-expand 0 half-p1)
- (v-expand half-m1 sq-m1)))
- do (aset background place
- (with-current-buffer (workbuf place)
- (dolist (part parts)
- (mput-points ?. part))
- (current-buffer))))
- ;; foreground
- (cl-flet
- ((circ (radius)
- (xpm-m2z-circle half half radius)))
- (cl-loop
- with stone = (circ (truncate half))
- with minim = (circ (/ square 9))
- for n below 4
- do (aset foreground n
- (with-current-buffer (workbuf n)
- (cl-flet
- ((rast (form b w)
- (xpm-raster form ?X
- (if (> 2 n)
- b
- w))))
- (if (cl-evenp n)
- (rast stone ?- ?+)
- (replace-from (aref foreground (1- n)))
- (rast minim ?+ ?-))
- (current-buffer))))))
- ;; do it
- (cl-flet
- ((ok (place type finish)
- (goto-char 25)
- (delete-char (- (skip-chars-forward "^1-9")))
- (delete-char 1)
- (insert (format "%s%d" type place))
- (push (cons (cons type place)
- (funcall finish
- :ascent 'center
- :color-symbols resolved))
- rv)))
- (with-current-buffer (workbuf 5)
- (replace-from (aref background 5))
- (xpm-raster
- ;; yes, using an ellipse is bizarre; no, we don't mind;
- ;; maybe, ‘artist-ellipse-generate-quadrant’ is stable.
- (xpm-m2z-ellipse half half 4 4.5)
- ?. t)
- (ok 5 'hoshi 'xpm-finish))
- (cl-loop
- for place from 1 to 9
- for decor in (let ((friends (cons half-m1 half-p1)))
- (nine-from-four (list friends 0)
- (list sq-m1 friends)
- (list 0 friends)
- (list friends sq-m1)))
- do (with-current-buffer (aref background place)
- (ok place 'empty 'xpm-finish))
- do (cl-flet
- ((decorate (px)
- (mput-points px decor)))
- (cl-loop
- for n below 4
- for type in '(bmoku bpmoku wmoku wpmoku)
- do (with-current-buffer (aref foreground n)
- (decorate ?.)
- (ok place type 'xpm-as-xpm)
- (decorate 32)))))
- (mapc 'kill-buffer foreground)
- (nreverse rv)))))
-
-;;;###autoload
-(defun gnugo-imgen-create-xpms (board-size)
- "Return a list of XPM images suitable for BOARD-SIZE.
-The size and style of the images are determined by
-`gnugo-imgen-sizing-function' (rounded down to an even number)
-and `gnugo-imgen-style', respectively. See `gnugo-xpms'.
-
-The returned list is cached; see also `gnugo-imgen-clear-cache'."
- (let* ((square (let ((n (funcall gnugo-imgen-sizing-function
- board-size)))
- (unless (numberp n)
- (error "Invalid BOARD-SIZE: %s" board-size))
- (max 8 (logand (lognot 1) (truncate n)))))
- (style (or (unless gnugo-imgen-style (cdar gnugo-imgen-styles))
- (cdr (assq gnugo-imgen-style gnugo-imgen-styles))
- (error "No style selected")))
- (key (cons square style)))
- (or (gethash key gnugo-imgen-cache)
- (puthash key (gnugo-imgen-create-xpms-1 square style)
- gnugo-imgen-cache))))
-
-;;;---------------------------------------------------------------------------
-;;; that's it
-
-(provide 'gnugo-imgen)
-
-;;; gnugo-imgen.el ends here
diff --git a/packages/gnugo/gnugo.el b/packages/gnugo/gnugo.el
deleted file mode 100644
index 5dbc06a..0000000
--- a/packages/gnugo/gnugo.el
+++ /dev/null
@@ -1,2866 +0,0 @@
-;;; gnugo.el --- play GNU Go in a buffer -*- lexical-binding: t -*-
-
-;; Copyright (C) 2014-2020 Free Software Foundation, Inc.
-
-;; Author: Thien-Thi Nguyen <ttn@gnu.org>
-;; Maintainer: Thien-Thi Nguyen <ttn@gnu.org>
-;; Version: 3.1.1
-;; 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
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; Playing
-;; -------
-;;
-;; This file provides the command `gnugo' which allows you to play the game of
-;; go against the external program "gnugo" (http://www.gnu.org/software/gnugo)
-;; in a dedicated Emacs buffer, or to resume a game in progress. NOTE: In
-;; this file, to avoid confusion w/ elisp vars and funcs, we use the term "GNU
-;; Go" to refer to the process object created by running the external program.
-;;
-;; At the start of a new game, you can pass additional command-line arguments
-;; to GNU Go to specify level, board size, color, komi, handicap, etc. By
-;; default GNU Go plays at level 10, board size 19, color white, and zero for
-;; both komi and handicap.
-;;
-;; To play a stone, move the cursor to the desired vertice and type `SPC' or
-;; `RET'; to pass, `P' (note: uppercase); to quit, `q'; to undo one of your
-;; moves (as well as a possibly intervening move by GNU Go), `u'. To undo
-;; back through an arbitrary stone that you played, place the cursor on a
-;; stone and type `U' (note: uppercase).
-;;
-;; There are a great many other commands. Other keybindings are described in
-;; the `gnugo-board-mode' documentation, which you may view with the command
-;; `describe-mode' (normally `C-h m') in that buffer. The buffer name shows
-;; the last move and who is currently to play. Capture counts and other info
-;; are shown on the mode line immediately following the major mode name.
-;;
-;; While GNU Go is pondering its next move, certain commands that rely on its
-;; assistence will result in a "still waiting" error. Do not be alarmed; that
-;; is normal. When it is your turn again you may retry the command. In the
-;; meantime, you can use Emacs for other tasks, or start an entirely new game
-;; with `C-u M-x gnugo'. (NOTE: A new game will slow down all games. :-)
-;;
-;; If GNU Go should crash during a game the mode line will show "no process".
-;; Please report the event to the GNU Go maintainers so that they can improve
-;; the program.
-;;
-;;
-;; Meta-Playing (aka Customizing)
-;; ------------------------------
-;;
-;; Customization is presently limited to
-;; vars: `gnugo-program'
-;; `gnugo-animation-string'
-;; `gnugo-mode-line'
-;; `gnugo-X-face' `gnugo-O-face' `gnugo-grid-face'
-;; `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 keymaps: `gnugo-board-mode-map'
-;; `gnugo-frolic-mode-map'
-;;
-;;
-;; Meta-Meta-Playing (aka Hacking)
-;; -------------------------------
-;;
-;; <http://git.sv.gnu.org/cgit/emacs/elpa.git/tree/packages/gnugo/>
-
-;;; Code:
-
-(require 'cl-lib) ; use the source luke!
-(require 'time-date) ; for `time-subtract'
-
-;;;---------------------------------------------------------------------------
-;;; Political arts
-
-(defconst gnugo-version "3.1.1"
- "Version of gnugo.el currently loaded.
-This follows a MAJOR.MINOR.PATCH scheme.")
-
-;;;---------------------------------------------------------------------------
-;;; Variables for the uninquisitive programmer
-
-(defvar gnugo-program "gnugo"
- "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-start-game-hook nil
- "Normal hook run immediately before the first move of the game.
-To find out who is to move first, use `gnugo-current-player'.
-See also `gnugo-board-mode'.")
-
-(defvar gnugo-post-move-hook nil
- "Normal hook run after a move and before the board is refreshed.
-Initially, when `run-hooks' is called, the current buffer is the GNUGO
-Board buffer of the game. Hook functions that switch buffers must take
-care not to call (directly or indirectly through some other function)
-`gnugo-put' or `gnugo-get' after the switch.")
-
-(defvar gnugo-animation-string
- (let ((jam "*#") (blink " #") (spin "-\\|/") (yada "*-*!"))
- (concat jam jam jam jam jam
- ;; "SECRET MESSAGE HERE"
- blink blink blink blink blink blink blink blink
- ;; Playing go is like fighting ignorance: when you think you have
- ;; surrounded something by knowing it very well it often turns
- ;; out that in the time you spent deepening this understanding,
- ;; other areas of ignorance have surrounded you.
- spin spin spin spin spin spin spin spin spin
- ;; Playing go is not like fighting ignorance: what one person
- ;; knows many people may come to know; knowledge does not build
- ;; solely move by move. Wisdom, on the other hand...
- yada yada yada))
- "String whose individual characters are used for animation.
-Specifically, the commands `gnugo-worm-stones' and `gnugo-dragon-stones'
-render the stones in their respective result groups as the first character
-in the string, then the next, and so on.")
-
-(defvar gnugo-mode-line "~b ~w :~m :~u"
- "A `mode-line-format'-compliant value for GNUGO Board mode.
-If a single string, the following special escape sequences are
-replaced with their associated information:
- ~b,~w black,white captures (a number)
- ~p current player (black or white)
- ~m move number
- ~t time waiting for the current move
- ~u time taken for the Ultimate (most recent) move
-The times are in seconds, or \"-\" if that information is not available.
-For ~t, the value is a snapshot, use `gnugo-refresh' to update it.")
-
-(defvar gnugo-X-face 'font-lock-string-face
- "Name of face to use for X (black) stones.")
-
-(defvar gnugo-O-face 'font-lock-builtin-face
- "Name of face to use for O (white) stones.")
-
-(defvar gnugo-grid-face 'default
- "Name of face to use for the grid (A B C ... 1 2 3 ...).")
-
-(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
-
-(defconst gnugo-font-lock-keywords
- '(("X" . gnugo-X-face)
- ("O" . gnugo-O-face))
- "Font lock keywords for `gnugo-board-mode'.")
-
-(defvar gnugo-option-history nil
- "History list of options for `gnugo' invocation.")
-
-(defvar gnugo-state nil) ; hint: C-c C-p
-
-(defvar gnugo-btw nil)
-
-;;;---------------------------------------------------------------------------
-;;; Support functions
-
-(defsubst gnugo-aqr (key alist)
- "Essentially: (cdr (assq KEY ALIST))
-This is like Scheme ‘assq-ref’ but with reversed arguments.
-The name was chosen to occupy the same space as \"cdr (assq\":
- (cdr (assq KEY ALIST))
- (gnugo-aqr KEY ALIST)
-to minimize reindentation noise. [Surely Emacs must
-provide something like this, somewhere, by now? --ttn]"
- (cdr (assq key alist)))
-
-(defsubst gnugo--mkht (&rest etc)
- (apply 'make-hash-table :test 'eq etc))
-
-(defsubst gnugo--compare-strings (s1 beg1 s2 beg2)
- (compare-strings s1 beg1 nil s2 beg2 nil))
-
-(defun gnugo-put (key value)
- "Associate move/game/board-specific property KEY with VALUE.
-
-There are many properties, each named by a keyword, that record and control
-how gnugo.el manages each game. Each GNUGO Board buffer has its own set
-of properties, stored in the hash table `gnugo-state'. Here we document
-some of the more stable properties. You may wish to use them as part of
-a `gnugo-post-move-hook' function, for example. Be careful to preserve
-the current buffer as `gnugo-state' is made into a buffer-local variable.
-NOTE: In the following, \"see foo\" actually means \"see foo source or
-you may never really understand to any degree of personal satisfaction\".
-
- :proc -- subprocess named \"gnugo\", \"gnugo<1>\" and so forth
-
- :diamond -- the part of the subprocess name after \"gnugo\", may be \"\"
-
- :game-over -- nil until game over at which time its value is set to the
- alist ((live GROUP ...) (seki GROUP ...) (dead GROUP ...))
-
- :sgf-collection -- after a `loadsgf' command, entire parse tree of file,
- a simple list of one or more gametrees, updated in
- conjunction w/ :sgf-gametree and :monkey
-
- :sgf-gametree -- one of the gametrees in :sgf-collection
-
- :monkey -- vector of two elements:
- MEM, a pointer to one of the branches in the gametree;
- BIDX, the index of the \"current branch\"
-
- :gnugo-color -- either \"black\" or \"white\"
- :user-color
- :last-mover
-
- :last-waiting -- seconds and time value, respectively; see `gnugo-push-move'
- :waiting-start
-
- :black-captures -- these are strings since gnugo.el doesn't do anything
- :white-captures w/ the information besides display it in the mode line
-
- :display-using-images -- XPMs, to be precise; see functions `gnugo-yy',
- `gnugo-image-display-mode' and `gnugo-refresh',
- as well as gnugo-xpms.el (available elsewhere)
-
- :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
- `gnugo-image-display-mode', `gnugo-yy' and `gnugo-yang'
-
- :paren-ov -- a pair (left and right) of overlays shuffled about to indicate
- the last move; only one is used when displaying using images
-
- :last-user-bpos -- board position; keep the hapless human happy
-
-As things stabilize probably more info will be added to this docstring."
- (declare (indent 1))
- (puthash key value gnugo-state))
-
-(defun gnugo-get (key)
- "Return the move/game/board-specific value for KEY.
-See `gnugo-put'."
- (gethash key gnugo-state))
-
-(defun gnugo--forget (&rest keys)
- (dolist (key keys)
- (remhash key gnugo-state)))
-
-(defsubst gnugo--tree-mnum (tree)
- (aref tree 1))
-
-(defsubst gnugo--tree-ends (tree)
- (aref tree 0))
-
-(defsubst gnugo--set-tree-ends (tree ls)
- (aset tree 0 (apply 'vector ls))
- (gnugo--tree-ends tree))
-
-(defun gnugo--root-node (&optional tree)
- (aref (or tree (gnugo-get :sgf-gametree))
- 2))
-
-(defun gnugo-describe-internal-properties ()
- "Pretty-print `gnugo-state' properties in another buffer.
-Handle the big, slow-to-render, and/or uninteresting ones specially."
- (interactive)
- (let ((buf (current-buffer))
- (d (gnugo-get :diamond))
- (acc (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*"
- d)))
- (erase-buffer)
- (emacs-lisp-mode)
- (setq truncate-lines t)
- (insert ";;; " (message "%d properties" (length acc)))
- (save-excursion
- (cl-loop
- with standard-output = (current-buffer)
- for (key . val) in acc
- do (progn
- (unless (bolp)
- (newline))
- (print key)
- (pp val)))
- (goto-char (point-min))
- (let ((rx (format "overlay from \\([0-9]+\\).+\n%s\\s-+"
- (if (string= "" d)
- ".+\n"
- ""))))
- (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))
- (insert (format " %S" pos))))))))
-
-(defun gnugo-board-buffer-p (&optional buffer)
- "Return non-nil if BUFFER is a GNUGO Board buffer."
- (eq 'gnugo-board-mode
- (buffer-local-value
- 'major-mode
- (or buffer (current-buffer)))))
-
-(defun gnugo-board-user-play-ok-p (&optional buffer)
- "Return non-nil if BUFFER is a GNUGO Board buffer ready for a user move."
- (with-current-buffer (or buffer (current-buffer))
- (and gnugo-state (not (gnugo-get :waiting)))))
-
-(defsubst gnugo--prop-blackp (object)
- (eq :B object))
-
-(defsubst gnugo--blackp (string)
- (string= "black" string))
-
-(defun gnugo-other (color)
- "If COLOR is \"black\", return \"white\", otherwise \"black\"."
- (if (gnugo--blackp color) "white" "black"))
-
-(defun gnugo-current-player ()
- "Return the current player, either \"black\" or \"white\"."
- (gnugo-other (gnugo-get :last-mover)))
-
-(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!"))
- (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)))
- (when (memq status '(exit signal))
- (let ((buf (process-buffer proc)))
- (when (buffer-live-p buf)
- (with-current-buffer buf
- (setq mode-line-process
- (list " [%s ("
- (propertize (car (split-string string))
- 'face 'font-lock-warning-face)
- ")]"))
- (when (eq proc (gnugo-get :proc))
- (gnugo--forget :proc))))))))
-
-(defun gnugo--begin-exchange (proc filter line)
- (declare (indent 2)) ; good time, for a rime
- ; nice style, for a wile...
- (set-process-filter proc filter)
- (process-send-string proc line)
- (process-send-string proc "\n"))
-
-(defun gnugo--q (fmt &rest args)
- "Send formatted command \"FMT ARGS...\"; wait for / return response.
-The response is a string whose first two characters indicate the
-status of the command. See also `gnugo-query'."
- (let ((slow (gnugo-get :waiting))
- (proc (gnugo-get :proc)))
- (when slow
- (user-error "Sorry, still waiting for %s to %s"
- (car slow) (if (cdr slow)
- "receive a suggestion"
- "play")))
- (process-put proc :incomplete t)
- (process-put proc :srs "") ; synchronous return stash
- (gnugo--begin-exchange
- proc (lambda (proc string)
- (let ((full (concat (process-get proc :srs)
- string)))
- (process-put proc :srs full)
- (unless (numberp (gnugo--compare-strings
- full (max 0 (- (length full)
- 2))
- "\n\n" nil))
- (process-put proc :incomplete nil))))
- (if (null args)
- fmt
- (apply #'format fmt args)))
- (while (process-get proc :incomplete)
- (accept-process-output proc 30))
- (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
-to the status indicator in the Go Text Protocol). Use this function
-when you are sure the command cannot fail."
- (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)
- "Apply `gnugo-query' to args; split its rv (return list of strings)."
- (split-string (apply 'gnugo-query message-format args)))
-
-(defsubst gnugo--count-query (fmt &rest args)
- (length (apply 'gnugo-lsquery fmt args)))
-
-(defsubst gnugo--root-prop (prop &optional tree)
- (gnugo-aqr prop (gnugo--root-node tree)))
-
-(defun gnugo--set-root-prop (prop value &optional tree)
- (let* ((root (gnugo--root-node tree))
- (cur (assq prop root)))
- (if cur
- (setcdr cur value)
- (push (cons prop value)
- (cdr (last root))))))
-
-(defun gnugo-goto-pos (pos)
- "Move point to board position POS, a letter-number string.
-Return final buffer position (i.e., point)."
- (goto-char (point-min))
- (forward-line (- (1+ (gnugo-get :SZ))
- (string-to-number (substring pos 1))))
- (forward-char 1)
- (forward-char (+ (if (= 32 (following-char)) 1 2)
- (* 2 (- (let ((letter (aref pos 0)))
- (if (> ?I letter)
- letter
- (1- letter)))
- ?A))))
- (point))
-
-(defun gnugo-f (id)
- (intern (if (symbolp id)
- (symbol-name id)
- id)
- (gnugo-get :obarray)))
-
-(defun gnugo-yang (c)
- "Return the \"image type information\" corresponding to character C.
-C is one of the four characters used in the ASCII representation
-of a game board -- ?+ (U+2B PLUS SIGN), ?. (U+2E FULL STOP), ?X
-and ?O (U+58 and U+4F, LATIN CAPITAL LETTER X and O, respectively).
-For example, here is a 5x5 board with two stones placed:
-
- . . . . .
- . O . + . (white at B4)
- . . + . .
- . + . + X (black at E2)
- . . . . .
-
-The image type information consists of a single symbol for ?. and ?+
-and a pair (SANS-POINT . WITH-POINT) for ?X and ?O. Both SANS-POINT
-and WITH-POINT are symbols. For other C, return nil."
- (gnugo-aqr c '((?+ . hoshi)
- (?. . empty)
- (?X . (bmoku . bpmoku))
- (?O . (wmoku . wpmoku)))))
-
-(defun gnugo-yy (yin yang &optional momentaryp)
- "Return a symbol made by formatting YIN (an integer) and YANG.
-The returned symbol has the format N-SYMBOL.
-
-If YANG is a symbol, use it directly. Otherwise, YANG must be a pair.
-If optional arg MOMENTARYP is non-nil, use the `cdr' of YANG.
-Otherwise, use the `car' of YANG. See `gnugo-yang'."
- (gnugo-f (format "%d-%s"
- yin (cond ((symbolp yang) yang)
- (momentaryp (cdr yang))
- (t (car yang))))))
-
-(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)))))
-
-(defconst gnugo--intangible (if (fboundp 'cursor-intangible-mode)
- 'cursor-intangible
- 'intangible)
- "Text property that controls intangibility.")
-
-(defun gnugo--propertize-board-buffer ()
- (erase-buffer)
- (insert (substring (gnugo--q "showboard") 3))
- (let* ((grid-props (list 'invisible :nogrid
- 'font-lock-face gnugo-grid-face))
- (%gpad (gnugo-f 'gpad))
- (%gspc (gnugo-f 'gspc))
- (%lpad (gnugo-f 'lpad))
- (%rpad (gnugo-f 'rpad))
- (ispc-props (list 'category (gnugo-f 'ispc) 'rear-nonsticky t))
- (size (gnugo-get :SZ))
- (size-string (number-to-string size)))
- (goto-char (point-min))
- (put-text-property (point) (1+ (point)) 'category (gnugo-f 'tpad))
- (skip-chars-forward " ")
- (put-text-property (1- (point)) (point) 'category %gpad)
- (put-text-property (point) (line-end-position) 'category %gspc)
- (forward-line 1)
- (add-text-properties (1+ (point-min)) (1- (point)) grid-props)
- (while (looking-at "\\s-*\\([0-9]+\\)[ ]")
- (let* ((row (match-string-no-properties 1))
- (edge (match-end 0))
- (other-edge (+ edge (* 2 size) -1))
- (right-empty (+ other-edge (length row) 1))
- (top-p (string= size-string row))
- (bot-p (string= "1" row)))
- (let* ((nL (- edge 1 (length size-string)))
- (nR (- edge 1))
- (ov (make-overlay nL nR (current-buffer) t)))
- (add-text-properties nL nR grid-props)
- ;; We redundantly set `invisible' in the overlay to workaround
- ;; a display bug whereby text *following* the overlaid text is
- ;; displayed with the face of the overlaid text, but only when
- ;; that text is invisible (i.e., `:nogrid' in invisibility spec).
- ;; This has something to do w/ the bletcherous `before-string'.
- (overlay-put ov 'invisible :nogrid)
- (overlay-put ov 'category %lpad))
- (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))
- row))
- (yin (let ((A-p (= edge p))
- (Z-p (= (1- other-edge) p)))
- (cond ((and top-p A-p) 1)
- ((and top-p Z-p) 3)
- ((and bot-p A-p) 7)
- ((and bot-p Z-p) 9)
- (top-p 2)
- (bot-p 8)
- (A-p 4)
- (Z-p 6)
- (t 5))))
- (yang (gnugo-yang (char-after p))))
- (add-text-properties p (1+ p)
- `(gnugo-position
- ,position
- gnugo-yin
- ,yin
- gnugo-yang
- ,yang
- category
- ,(gnugo-yy yin yang)
- front-sticky
- (gnugo-position gnugo-yin))))
- (unless (= (1- other-edge) p)
- (add-text-properties (1+ p) (+ 2 p) ispc-props)
- (put-text-property p (+ 2 p) gnugo--intangible ival)))
- (add-text-properties (1+ other-edge) right-empty grid-props)
- (goto-char right-empty)
- (when (looking-at "\\s-+\\(WH\\|BL\\).*capt.* \\([0-9]+\\).*$")
- (let ((prop (if (string= "WH" (match-string 1))
- :white-captures
- :black-captures))
- (beg (match-beginning 2))
- (end (match-end 2)))
- (put-text-property beg end :gnugo-cf (cons (- end beg) prop))
- (gnugo-put prop (match-string-no-properties 2))))
- (put-text-property right-empty (line-end-position) 'category %rpad)
- (forward-line 1)))
- (add-text-properties (1- (point)) (point-max) grid-props)
- (skip-chars-forward " ")
- (put-text-property (1- (point)) (point) 'category %gpad)
- (put-text-property (point) (line-end-position)
- 'category %gspc)))
-
-(defun gnugo--merge-showboard-results ()
- (let ((aft (substring (gnugo--q "showboard") 3))
- (adj 1) ; string to buffer position adjustment
-
- (sync "[0-9]* stones$")
- ;; Note: `sync' used to start w/ "[0-9]+", but that is too
- ;; restrictive a condition that fails in the case of:
- ;;
- ;; (before)
- ;; ... WHITE has captured 1 stones
- ;; ^
- ;; (after)
- ;; ... WHITE has captured 14 stones
- ;; ^
- ;;
- ;; where the after count has more digits than the before count,
- ;; but shares the same leading digits. In this case, the result
- ;; of `compare-strings' points to the SPC following the before
- ;; count (indicated by caret in this example).
-
- (bef (buffer-substring-no-properties (point-min) (point-max)))
- (bef-start 0) (bef-idx 0)
- (aft-start 0) (aft-idx 0)
- 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)))
- (setq aft-sync-backtrack nil
- inc (if (cl-minusp mis)
- (- (+ 1 mis))
- (- mis 1))
- bef-idx (+ bef-start inc)
- aft-idx (+ aft-start inc)
- bef-start (if (eq bef-idx (string-match sync bef bef-idx))
- (match-end 0)
- (1+ bef-idx))
- aft-start (if (and (eq aft-idx (string-match sync aft aft-idx))
- (let ((peek (1- aft-idx)))
- (while (not (= 32 (aref aft peek)))
- (setq peek (1- peek)))
- (setq aft-sync-backtrack (1+ peek))))
- (match-end 0)
- (1+ aft-idx))
- cut (+ bef-idx adj
- (if aft-sync-backtrack
- (- aft-sync-backtrack aft-idx)
- 0)))
- (goto-char cut)
- (if aft-sync-backtrack
- (let* ((asb aft-sync-backtrack)
- (l-p (get-text-property cut :gnugo-cf))
- (old-len (car l-p))
- (capprop (cdr l-p))
- (keep (text-properties-at cut)))
- (setq new (substring aft asb (string-match " " aft asb)))
- (plist-put keep :gnugo-cf (cons (length new) capprop))
- (gnugo-put capprop new)
- (delete-char old-len)
- (insert (apply 'propertize new keep))
- (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))
- (yang (gnugo-yang new)))
- (add-text-properties cut (1+ cut)
- `(gnugo-yang
- ,yang
- category
- ,(gnugo-yy yin yang))))
- (delete-char 1)
- ;; Do this last to avoid complications w/ font lock and overlays
- ;; (this also means we cannot include `intangible' in `front-sticky').
- ;; This is necessary even for ‘cursor-intangible’; if we omit it, the
- ;; cursor can (incorrectly) enter the text displayed by ‘:paren-ov’.
- ;; TODO: Revisit later to see if that still holds.
- (when (setq very-strange (get-text-property (1+ cut)
gnugo--intangible))
- (put-text-property cut (1+ cut) gnugo--intangible very-strange))))))
-
-(defsubst gnugo--move-prop (node)
- (or (assq :B node)
- (assq :W node)))
-
-(defun gnugo--as-pos-func ()
- (let ((size (gnugo-get :SZ)))
- ;; rv
- (lambda (cc)
- (if (string= "" cc)
- "PASS"
- (let ((col (aref cc 0)))
- (format "%c%d"
- (+ ?A (- (if (> ?i col) col (1+ col)) ?a))
- (- size (- (aref cc 1) ?a))))))))
-
-(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)\"
-followed by the space-separated list of moves. When called
-interactively with a prefix arg (i.e., RSEL is (4)), display
-similarly, but suffix with the mover (either \":B\" or \":W\").
-RSEL may also be a symbol that selects what to return:
- 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))
- (mem (aref monkey 0))
- (as-pos (gnugo--as-pos-func))
- acc node mprop move)
- (cl-flet*
- ((as-pos-maybe (x) (if (gnugo--resignp x)
- x
- (funcall as-pos x)))
- (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))
- move)
- acc)))
- (nn () (next nil))
- (tell () (message "(%d moves) %s"
- (length acc)
- (mapconcat 'identity (nreverse acc) " ")))
- (finish (byp) (while mem (next byp)) (tell)))
- (pcase rsel
- (`(4) (finish t))
- (`nil (finish nil))
- (`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)))))
-
-(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--no-regrets (monkey ends)
- (eq (aref ends (aref monkey 1))
- (aref monkey 0)))
-
-(defun gnugo--as-cc-func ()
- (let ((size (gnugo-get :SZ)))
- (lambda (pos)
- (let* ((col (aref pos 0))
- (one (+ ?a (- col (if (< ?H col) 1 0) ?A)))
- (two (+ ?a (- size (string-to-number
- (substring pos 1))))))
- (format "%c%c" one two)))))
-
-(defun gnugo--decorate (node &rest plist)
- (cl-loop
- with tp = (last node)
- with fruit
- while plist
- do (setf
- fruit (list
- ;; No OoE worries, here. "The first step in evaluating a
- ;; function call is to evaluate the remaining elements of the
- ;; list from left to right." (info "(elisp) Function Forms")
- (cons
- (pop plist)
- (pop plist)))
- (cdr tp) fruit
- tp fruit)))
-
-(defun gnugo-close-game (end-time resign)
- (gnugo-put :game-end-time end-time)
- (let ((now (or end-time (current-time))))
- (gnugo-put :scoring-seed (logior (ash (logand (car now) 255) 16)
- (cadr now))))
- (gnugo-put :game-over
- (cl-flet
- ;; Q: What form does a game-over "group" take?
- ;; A: GROUP = (GHEAD POSITION[...])
- ;; GHEAD = (CPROP [OVERLAY[...]])
- ;; CPROP = ‘:B’ or ‘:W’
- ((group (color positions)
- (cl-assert positions) ; one or more
- (cons (list (gnugo--prop<-color color))
- (sort positions #'string<))))
- (if (or (eq t resign)
- (and (stringp resign)
- (string-match "[BW][+][Rr]esign" resign)))
- ;; Hmmm, treating resignation specially seems kind of pointless.
- ;; TODO: Choose one: (a) rationalize; (b) decruft.
- `((live ,@(cl-flet
- ((ls (color) (mapcar
- (lambda (x)
- (group color (split-string x)))
- (split-string
- (gnugo-query "worm_stones %s" color)
- "\n"))))
- (append (ls "black")
- (ls "white"))))
- (seki)
- (dead))
- (cl-loop
- with flat-seki = (gnugo-lsquery "final_status_list seki")
- with dd = (gnugo-query "dragon_data")
- with start = 0
- with (live seki dead)
- while (string-match "\\(.+\\):\n[^ ]+[ ]+\\(black\\|white\\)\n"
- dd start)
- do (let* ((mem (match-string 1 dd))
- (ent (group (match-string 2 dd)
- (gnugo-lsquery "dragon_stones %s"
- mem))))
- (string-match "\nstatus[ ]+\\(\\(ALIVE\\)\\|[A-Z]+\\)\n"
- dd start)
- (cond ((member mem flat-seki)
- (push ent seki))
- ((match-string 2 dd)
- (push ent live))
- (t
- (push ent dead)))
- (setq start (match-end 0)))
- finally return
- `((live ,@live)
- (seki ,@seki)
- (dead ,@dead)))))))
-
-(defun gnugo--unclose-game ()
- (gnugo--forget :game-over ; all those in -close-game
- :scoring-seed
- :game-end-time)
- (let* ((root (gnugo--root-node))
- (cur (assq :RE root)))
- (when cur
- (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)
- (let* ((simple (booleanp who))
- (ucolor (gnugo-get :user-color))
- (color (if simple
- (if who
- ucolor
- (gnugo-get :gnugo-color))
- who))
- (start (gnugo-get :waiting-start))
- (now (current-time))
- (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
- (gnugo--q/ue "play %s %s" color move))
- (unless passp
- (gnugo--merge-showboard-results))
- (gnugo-put :last-mover color)
- (when (if simple
- who
- (string= ucolor color))
- (gnugo-put :last-user-bpos (and (not passp) (not resignp) move)))
- ;; update :sgf-gametree and :monkey
- (let* ((property (gnugo--prop<-color color))
- (pair (cons property (cond (resignp move)
- (passp "")
- (t (funcall (gnugo--as-cc-func)
- move)))))
- (fruit (list pair))
- (monkey (gnugo-get :monkey))
- (mem (aref monkey 0))
- (tip (car mem))
- (tree (gnugo-get :sgf-gametree))
- (ends (gnugo--tree-ends tree))
- (mnum (gnugo--tree-mnum tree))
- (count (length ends))
- (tip-move-num (gethash tip mnum))
- (bidx (aref monkey 1)))
- ;; Detect déjà-vu. That is, when placing "A", avoid:
- ;;
- ;; X---Y---A new
- ;; \
- ;; --A---B old
- ;;
- ;; (such "variations" do not actually vary!) in favor of:
- ;;
- ;; X---Y---A new
- ;; \
- ;; --B old
- ;;
- ;; This linear search loses for multiple ‘old’ w/ "A",
- ;; a very unusual (but not invalid, sigh) situation.
- (cl-loop
- with (bx previous)
- for i
- ;; Start with latest / highest likelihood for hit.
- ;; (See "to the right" comment, below.)
- from (if (gnugo--no-regrets monkey ends)
- 1
- 0)
- below count
- if (setq bx (mod (+ bidx i) count)
- previous
- (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)
- (cl-rotatef (aref ends bidx)
- (aref ends bx)))
- (setq mem previous))
- ;; no => construct
- finally do
- (progn
- (unless (gnugo--no-regrets monkey ends)
- (setq ends (gnugo--set-tree-ends
- tree (let ((ls (append ends nil)))
- ;; copy old to the right of new
- (push mem (nthcdr bidx ls))
- ls))))
- (puthash fruit (1+ (gethash tip mnum)) mnum)
- (push fruit mem)
- (aset ends bidx mem)))
- (setf (aref monkey 0) mem))
- (when start
- (gnugo-put :last-waiting (cadr (time-subtract now start))))
- (when donep
- (gnugo-close-game now resignp))
- (gnugo-put :waiting-start (and (not donep) now))
- donep))
-
-(defun gnugo-venerate (yin yang)
- (let* ((fg-yy (gnugo-yy yin yang))
- (fg-disp (or (get fg-yy 'display)
- (get fg-yy 'do-not-display)))
- (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)))
- (bg-data (plist-get (cdr bg-disp) :data))
- (bop (lambda (s)
- (let* ((start 0)
- (ncolors
- (when (string-match "\\([0-9]+\\)\\s-+[0-9]+\"," s)
- (setq start (match-end 0))
- (string-to-number (match-string 1 s)))))
- (while (and (not (cl-minusp ncolors))
- (string-match ",\n" s start))
- (setq start (match-end 0)
- ncolors (1- ncolors)))
- (string-match "\"" s start)
- (match-end 0))))
- (new (copy-sequence fg-data))
- (lx (length fg-data))
- (sx (funcall bop fg-data))
- (sb (funcall bop bg-data))
- (color-key (aref new sx))) ; blech, heuristic
- (while (< sx lx)
- (when (and (not (= color-key (aref new sx)))
- (cl-plusp (random 4)))
- (aset new sx (aref bg-data sb)))
- (cl-incf sx)
- (cl-incf sb))
- (apply 'create-image new 'xpm t
- :ascent 'center (when c-symbs
- (list :color-symbols
- c-symbs)))))
-
-(defsubst gnugo--zonk-ovs (ovs)
- (mapc 'delete-overlay ovs))
-
-(defun gnugo-refresh (&optional nocache)
- "Update GNUGO Board buffer display.
-While a game is in progress, parenthesize the last-played stone (no parens
-for pass). If the buffer is currently displayed in the selected window,
-recenter the board (presuming there is extra space in the window). Update
-the mode line. Lastly, move point to the last position played by the user,
-if that move was not a pass.
-
-Prefix arg NOCACHE requests complete reconstruction of the display, which may
-be slow. (This should normally be unnecessary; specify it only if the display
-seems corrupted.) NOCACHE is silently ignored when GNU Go is thinking about
-its move."
- (interactive "P")
- (let* ((move (gnugo-move-history 'car))
- (game-over (gnugo-get :game-over))
- (using-images (gnugo-get :display-using-images))
- (inhibit-read-only t)
- window last)
- (when (and nocache (not (gnugo-get :waiting)))
- ;; (search-forward "pall of death")
- (dolist (group (apply #'append (mapcar #'cdr game-over)))
- (gnugo--zonk-ovs (cdar group))
- (setcdr (car group) nil))
- (gnugo--propertize-board-buffer))
- ;; last move
- (when move
- (cl-destructuring-bind (l-ov . r-ov) (gnugo-get :paren-ov)
- (if (member move '("PASS" "resign"))
- (gnugo--zonk-ovs (list l-ov r-ov))
- (let* ((p (gnugo-goto-pos move))
- (hspec (gnugo-get :highlight-last-move-spec))
- (display-value (nth 0 hspec))
- (l-offset (nth 1 hspec))
- (l-new-pos (+ p l-offset))
- (r-action (nth 2 hspec)))
- (overlay-put l-ov 'display
- (if (functionp display-value)
- (funcall display-value p)
- display-value))
- (move-overlay l-ov l-new-pos (1+ l-new-pos))
- (if r-action
- (funcall r-action r-ov)
- (move-overlay r-ov (+ l-new-pos 2) (+ l-new-pos 3)))))))
- ;; buffer name
- (rename-buffer (concat (gnugo-get :diamond)
- (if game-over
- (format "%s(game over)"
- (if (gnugo--resignp move)
- (concat move "ation ")
- ""))
- (format "%s(%s to play)"
- (if move (concat move " ") "")
- (gnugo-current-player)))))
- ;; pall of death
- (when game-over
- (cl-destructuring-bind (live seki dead)
- (mapcar (lambda (sel)
- (gnugo-aqr sel game-over))
- '(live seki dead))
- (dolist (head (mapcar #'car live))
- (gnugo--zonk-ovs (cdr head))
- (setcdr head nil))
- (cl-flet
- ((P (groups face respect)
- (cl-loop
- for (head . positions) in groups
- unless (cdr head)
- do (setcdr
- head
- (cl-loop
- with b/w = (gnugo--prop-blackp (car head))
- with yang = (if using-images
- (gnugo-yang (if b/w ?X ?O))
- (propertize (if b/w "x" "o")
- 'face face))
- for pos in (mapcar #'gnugo-goto-pos positions)
- collect
- (let ((ov (make-overlay pos (1+ pos))))
- (overlay-put
- ov 'display
- (if using-images
- ;; respect the dead individually; it takes more
- ;; time but that's not a problem (for them)
- (funcall respect (get-text-property
- pos 'gnugo-yin)
- yang)
- yang))
- ov))))))
- (P seki 'font-lock-type-face
- (lambda (yin yang)
- (get (gnugo-yy yin yang t)
- 'display)))
- (P dead 'font-lock-warning-face
- #'gnugo-venerate))))
- ;; window update
- (when (setq window (get-buffer-window (current-buffer)))
- (let* ((gridp (not (memq :nogrid buffer-invisibility-spec)))
- (size (gnugo-get :SZ))
- (under10p (< size 10))
- (mul (gnugo-get :mul))
- (h (- (truncate (- (window-height window)
- (* size (cdr mul))
- (if gridp 2 0))
- 2)
- (if gridp 0 1)))
- (edges (window-edges window))
- (right-w-edge (nth 2 edges))
- (avail-width (- right-w-edge (nth 0 edges)))
- (wmul (car mul))
- (imagesp (symbol-plist (gnugo-f 'ispc)))
- (w (/ (- avail-width
- (* size wmul)
- (if imagesp
- 0
- (1- size))
- 2 ; between board and grid
- (if gridp
- (if under10p 2 4)
- 0))
- 2.0)))
- (dolist (pair `((tpad . ,(if (and h (cl-plusp h))
- `(display ,(make-string h 10))
- '(invisible :nogrid)))
- (gpad . (display
- (space :align-to
- ,(+ w
- 2.0
- (cond (imagesp (+ (* 0.5 wmul)
- (if under10p
- -0.5
- 0.5)))
- (under10p 0)
- (t 1))))))
- (gspc . ,(when imagesp
- `(display
- (space-width
- ,(-
- ;; DWR: image width alone => OBOE!
- ;;- wmul
- ;; NB: ‘(* wmul cw)’ is the same
- ;; as ‘(car (image-size ... t))’.
- (let ((cw (frame-char-width)))
- (/ (+ 1.0 (* wmul cw))
- cw))
- 1.0)))))
- (lpad . ,(let ((d `(display (space :align-to ,w))))
- ;; We distinguish between these cases to
- ;; workaround a display bug whereby the
- ;; `before-string' is omitted entirely (not
- ;; rendered) when interacting w/ the text
- ;; mode last-move left-paren for moves in
- ;; column A.
- (if gridp
- `(before-string
- ,(apply 'propertize " " d))
- d)))
- (rpad . (display
- (space :align-to ,(1- avail-width))))))
- (setplist (gnugo-f (car pair)) (cdr pair)))))
- ;; mode line update
- (let ((cur (gnugo-get :mode-line)))
- (unless (equal cur gnugo-mode-line)
- (setq cur gnugo-mode-line)
- (gnugo-put :mode-line cur)
- (gnugo-put :mode-line-form
- (if (consp cur)
- cur
- (let (v refs varlist)
- (cl-flet
- ((R (re rep)
- (setq cur (replace-regexp-in-string
- re rep cur t t))))
- (R "%" "%%") ; hygiene
- (R "~[bwpmtu]"
- (lambda (match)
- (prog1 "%s"
- (push (setq v (intern match))
- refs)
- (cl-pushnew
- (list
- v
- (cl-case v
- (~b '(or (gnugo-get :black-captures) 0))
- (~w '(or (gnugo-get :white-captures) 0))
- (~p '(gnugo-current-player))
- (~t '(let ((ws (gnugo-get :waiting-start)))
- (if ws
- (cadr (time-since ws))
- "-")))
- (~u '(or (gnugo-get :last-waiting) "-"))
- (~m '(let ((tree (gnugo-get :sgf-gametree))
- (monkey (gnugo-get :monkey)))
- (gethash (car (aref monkey 0))
- (gnugo--tree-mnum tree)
- ;; should be unnecessary
- "?")))))
- varlist :key 'car)))))
- `(let ,varlist
- (format ,cur ,@(nreverse refs)))))))
- (let ((form (gnugo-get :mode-line-form)))
- (setq mode-line-process
- (and form
- ;; this dynamicism is nice but excessive in its wantonness
- ;;- `(" [" (:eval ,form) "]")
- ;; this dynamicism is ok because the user triggers it
- (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--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
-
-(defun gnugo--rename-buffer-portion (&optional back)
- (let ((old "to play")
- (new "waiting for suggestion"))
- (when back
- (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)
- (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
- (progn
- (gnugo--rename-buffer-portion t)
- (unless (or (gnugo--passp full)
- (eq 'nowarp suggestion))
- (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))
- (gnugo--begin-exchange
- (gnugo-get :proc) 'gnugo-get-move-insertion-filter
- ;; We used to use ‘genmove’ here, but that forced asymmetry in
- ;; downstream handling, an impediment to GNU Go vs GNU Go fun.
- (concat "reg_genmove " color))
- (accept-process-output))
-
-(defun gnugo-cleanup ()
- (when (gnugo-board-buffer-p)
- (unless (zerop (buffer-size))
- (message "Thank you for playing GNU Go."))
- (setq gnugo-state nil)))
-
-(defun gnugo-position ()
- (or (get-text-property (point) 'gnugo-position)
- (user-error "Not a proper position point")))
-
-(defun gnugo-request-suggestion (&optional nowarp)
- "Request a move suggestion from GNU Go.
-After some time (during which you can do other stuff),
-Emacs displays the suggestion in the echo area and warps the
-cursor to the suggested position. Prefix arg inhibits warp."
- (interactive "P")
- (gnugo-gate t)
- (gnugo--rename-buffer-portion)
- (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)
- ;; 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.
-The position is computed from current point.
-Signal error if done out-of-turn or if game-over.
-To start a game try M-x gnugo."
- (interactive)
- (gnugo--user-play (gnugo-position)))
-
-(defun gnugo-mouse-move (e)
- "Do `gnugo-move' at mouse location."
- (interactive "@e")
- (mouse-set-point e)
- (when (memq (following-char) '(?. ?+))
- (gnugo-move)))
-
-(defun gnugo-pass ()
- "Make a pass on the GNUGO Board buffer.
-Signal error if done out-of-turn or if game-over.
-To start a game try M-x gnugo."
- (interactive)
- (gnugo--user-play "PASS"))
-
-(defun gnugo-mouse-pass (e)
- "Do `gnugo-pass' at mouse location."
- (interactive "@e")
- (mouse-set-point e)
- (gnugo-pass))
-
-(defun gnugo-resign ()
- (interactive)
- (gnugo-gate t)
- (if (not (y-or-n-p "Resign? "))
- (message "(not resigning)")
- (gnugo-push-move t "resign")
- (gnugo-refresh)))
-
-(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)
- (unless (memq (following-char) '(?X ?O))
- (user-error "No stone at %s" pos))
- (setq blurb (message "Computing %s stones ..." w/d)
- stones (gnugo-lsquery "%s_stones %s" w/d pos))
- (message "%s %s in group" blurb (length stones))
- (setplist (gnugo-f 'anim) nil)
- (let* ((spec (if (gnugo-get :display-using-images)
- (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
- (mapcar (lambda (pos)
- (let* ((p (gnugo-goto-pos pos))
- (ov (make-overlay p (1+ p))))
- (overlay-put ov 'category (gnugo-f 'anim))
- (overlay-put ov 'priority most-positive-fixnum)
- ov))
- stones))))
- (setplist (gnugo-f 'anim) (cons 'display cell))
- (while (and (cdr spec) ; let last linger lest levity lost
- (sit-for 0.08675309)) ; jenny jenny i got your number...
- (setcar cell (setq spec (cdr spec)))
- ;; Force redisplay of overlays.
- (set-buffer-modified-p orig-b-m-p))
- (sit-for 5)
- (gnugo--zonk-ovs ovs)
- 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)
- (erase-buffer)
- (insert data))
- (message "Computing %s ... done" command))
-
-(defun gnugo-worm-stones ()
- "In the GNUGO Board buffer, animate \"worm\" at current position.
-Signal error if done out-of-turn or if game-over.
-See variable `gnugo-animation-string' for customization."
- (interactive)
- (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-display-group-data "worm_data" "*gnugo worm data*"))
-
-(defun gnugo-dragon-stones ()
- "In the GNUGO Board buffer, animate \"dragon\" at current position.
-Signal error if done out-of-turn or if game-over.
-See variable `gnugo-animation-string' for customization."
- (interactive)
- (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-display-group-data "dragon_data" "*gnugo dragon data*"))
-
-(defun gnugo-estimate-score ()
- "Display estimated score of a game of GNU Go.
-Output includes number of stones on the board and number of stones
-captured by each player, and the estimate of who has the advantage (and
-by how many stones)."
- (interactive)
- (message "Est.score ...")
- (let ((black (gnugo--count-query "list_stones black"))
- (white (gnugo--count-query "list_stones white"))
- (black-captures (gnugo-query "captures black"))
- (white-captures (gnugo-query "captures white"))
- (est (gnugo-query "estimate_score")))
- ;; might as well update this
- (gnugo-put :black-captures black-captures)
- (gnugo-put :white-captures white-captures)
- (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."
- (interactive "FWrite game as SGF file: ")
- (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)
- (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
- "as before"
- "NOTE: this is a switch!")))
-
-(defsubst gnugo--nodep (x)
- (keywordp (caar x)))
-
-(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)
- (let ((tree (nth (or sel 0) collection)))
- (gnugo-put :sgf-gametree tree)
- (gnugo-put :monkey (vector
- ;; mem
- (aref (gnugo--tree-ends tree) 0)
- ;; bidx
- 0))
- tree))
-
-(defun gnugo-read-sgf-file (filename)
- "Load the first game tree from FILENAME, a file in SGF format."
- (interactive "fSGF file to load: ")
- (when (file-directory-p filename)
- (user-error "Cannot load a directory (try a filename with extension
.sgf)"))
- (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'
- (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)
- (unless samep
- (gnugo-put :gnugo-color wait)
- (gnugo-put :user-color play))
- (setq coll (gnugo/sgf-create filename)
- tree (gnugo--plant-and-climb
- coll (let ((n (length coll)))
- ;; This is better:
- ;; (if (= 1 n)
- ;; 0
- ;; (let* ((q (format "Which game? (1-%d)" n))
- ;; (choice (1- (read-number q 1))))
- ;; (if (and (< -1 choice) (< choice n))
- ;; choice
- ;; (message "(Selecting the first game)")
- ;; 0)))
- ;; but this is what we use (for now) to accomodate
- ;; (aka faithfully mimic) GTP `loadsgf' limitations:
- (unless (= 1 n)
- (message "(Selecting the first game)"))
- 0)))
- ;; This is deliberately undocumented for now.
- (gnugo--SZ! (gnugo--root-prop :SZ tree))
- (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)
- (gnugo--ok-file filename)
- (gnugo--who-is-who wait play samep)))
-
-(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)
- (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)))
- (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 (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
- (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-get :center-position)))
- (gnugo-refresh t)
- (unless (or keep remorseful)
- (aset ends (aref monkey 1) (aref monkey 0)))
- (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).
-Do not schedule a move by GNU Go even if it is GNU Go's turn to play.
-Prefix arg ME-NEXT means to arrange for you to play
-the color of the next move (and GNU Go the opposite).
-This is useful after loading an SGF file whose last
-move was done by the color you prefer to play:
- \\[gnugo-read-sgf-file] FILENAME RET
- C-u \\[gnugo-undo-one-move]
-
-See also `gnugo-undo-two-moves'."
- (interactive "P")
- (gnugo-gate)
- (when me-next
- (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--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--climb-towards-root 0))
-
-(defun gnugo-oops (&optional position)
- "Like `gnugo-undo-two-moves', but keep the undone moves.
-The kept moves become a sub-gametree (variation) when play resumes.
-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--climb-towards-root (unless position
- 0)
- nil t))
-
-(defun gnugo-okay (&optional full)
- "Redo a pair of undone moves.
-Prefix arg means to redo all the undone moves."
- (interactive "P")
- (gnugo-gate)
- (let* ((tree (gnugo-get :sgf-gametree))
- (ends (gnugo--tree-ends tree))
- (monkey (gnugo-get :monkey)))
- (if (gnugo--no-regrets monkey ends)
- (message "Oop ack!")
- (let* ((as-pos (gnugo--as-pos-func))
- (mnum (gnugo--tree-mnum tree))
- (mem (aref monkey 0))
- (bidx (aref monkey 1))
- (end (aref ends bidx))
- (ucolor (gnugo-get :user-color))
- (uprop (gnugo--prop<-color ucolor)))
- (cl-flet
- ((mvno (node) (gethash node mnum)))
- (cl-loop
- with ok = (if full
- (mvno (car end))
- (+ 2 (mvno (car mem))))
- with (node move todo)
- for ls on end
- do (progn
- (setq node (car ls)
- move (gnugo--move-prop node))
- (when (and move (>= ok (mvno node)))
- (let ((userp (eq uprop (car move))))
- (push (list userp
- (funcall as-pos (cdr move)))
- todo))))
- until (eq mem (cdr ls))
- finally do
- (cl-loop
- for (userp pos) in todo
- do (progn
- (gnugo-push-move userp pos)
- (gnugo-refresh)
- (redisplay)))))))))
-
-(defun gnugo-display-final-score (&optional comment)
- "Display final score and other info in another buffer (when game over).
-If the game is still ongoing, Emacs asks if you wish to stop play (by
-making sure two \"pass\" moves are played consecutively, if necessary).
-Also, add the `RE' (Result) SGF property to the root node of the game tree.
-Prefix arg means to attach to the last move the SGF properties:
- TB -- Black Territory
- TW -- White Territory
- MA -- Mark (to indicate seki stones)
- DD -- Dim Points (to indicate dead stones)
-each of which is a non-empty list of positions, as well as the final
-score text (slightly compacted) as a comment."
- (interactive "P")
- (let ((game-over (gnugo-get :game-over)))
- (unless (or game-over
- (and (not (gnugo-get :waiting))
- (y-or-n-p "Game still in play. Stop play now? ")))
- (user-error "Sorry, game still in play"))
- (unless game-over
- (cl-flet
- ((pass (userp)
- (message "Playing PASS for %s ..."
- (gnugo-get (if userp :user-color :gnugo-color)))
- (sit-for 1)
- (gnugo-push-move userp "PASS")))
- (unless (pass t)
- (pass nil)))
- (gnugo-refresh)
- (sit-for 3)))
- (let ((b= " Black = ")
- (w= " White = ")
- (res (when (gnugo--resignp (gnugo-move-history 'car))
- (gnugo-get :last-mover)))
- (seed (gnugo-get :scoring-seed))
- blurb result)
- (if res
- (setq blurb (list
- (format "%s wins.\n"
- (substring (if (= ?b (aref res 0)) w= b=)
- 3 8))
- "The game is over.\n"
- (format "Resignation by %s.\n" res))
- result (concat (upcase (substring (gnugo-other res) 0 1))
- "+Resign"))
- (message "Computing final score ...")
- (let* ((g-over (gnugo-get :game-over))
- (live (gnugo-aqr 'live g-over))
- (dead (gnugo-aqr 'dead g-over))
- (terr-q (format "final_status_list %%s_territory %d" seed))
- (terr "territory")
- (capt "captures")
- (b-terr (gnugo--count-query terr-q "black"))
- (w-terr (gnugo--count-query terr-q "white"))
- (b-capt (string-to-number (gnugo-get :black-captures)))
- (w-capt (string-to-number (gnugo-get :white-captures)))
- (komi (gnugo--root-prop :KM)))
- (setq blurb (list "The game is over. Final score:\n")
- result (gnugo-query "final_score %d" seed))
- (cond ((string= "Chinese" (gnugo--root-prop :RU))
- (dolist (group live)
- (cl-incf (if (gnugo--prop-blackp (caar group))
- b-terr
- w-terr)
- (length (cdr group))))
- (dolist (group dead)
- (cl-incf (if (gnugo--prop-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)
- (cl-incf (if (gnugo--prop-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
- (+ b-terr b-capt))
- blurb)
- (push (format "%s%d %s + %s %s + %3.1f %s = %3.1f\n" w=
- w-terr terr
- w-capt capt
- komi 'komi
- (+ w-terr w-capt komi))
- blurb)))
- (push (if (string= "0" result)
- "The game is a draw.\n"
- (format "%s wins by %s.\n"
- (substring (if (= ?B (aref result 0)) b= w=) 3 8)
- (substring result 2)))
- blurb)
- (message "Computing final score ... done")))
- ;; extra info
- (let ((beg (gnugo-get :game-start-time))
- (end (gnugo-get :game-end-time)))
- (when end
- (push "\n" blurb)
- (cl-flet
- ((yep (pretty moment)
- (push (format-time-string
- (concat pretty ": %F %T %z\n")
- moment)
- blurb)))
- (yep "Game start" beg)
- (yep " end" end))))
- (setq blurb (apply 'concat (nreverse blurb)))
- (gnugo--set-root-prop :RE result)
- (when comment
- (let ((node (car (aref (gnugo-get :monkey) 0))))
- (cl-loop
- for (prop . what) in '((:TB . black_territory)
- (:TW . white_territory)
- (:MA . seki)
- (:DD . dead))
- do (let ((ls (gnugo-lsquery "final_status_list %s %s"
- what seed)))
- (delq (assq prop node) node)
- (when ls
- (gnugo--decorate
- node prop (mapcar (gnugo--as-cc-func)
- ls)))))
- (gnugo--decorate
- (delq (assq :C node) node)
- :C
- (with-temp-buffer ; lame
- (insert blurb)
- (when (search-backward "\n\nGame start:" nil t)
- (delete-region (point) (point-max)))
- (cl-flet
- ((rep (old new)
- (goto-char (point-min))
- (while (search-forward old nil t)
- (replace-match new))))
- (rep "The game is over. " "")
- (rep "territory" "T")
- (rep "captures" "C")
- (rep "komi" "K"))
- (buffer-string)))))
- (switch-to-buffer (format "%s*GNUGO Final Score*" (gnugo-get :diamond)))
- (erase-buffer)
- (insert blurb)))
-
-(defun gnugo-quit ()
- "Kill the current buffer, assumed to be in GNUGO Board mode, maybe.
-If the game is not over, ask for confirmation first."
- (interactive)
- (if (or (gnugo-get :game-over)
- (y-or-n-p "Quit? "))
- (kill-buffer nil)
- (message "(not quitting)")))
-
-(defun gnugo-leave-me-alone ()
- "Kill the current buffer unconditionally."
- (interactive)
- (kill-buffer nil))
-
-(defun gnugo-fancy-undo (count)
- "Rewind the game tree in various ways.
-Prefix arg COUNT means to undo that many moves.
-Otherwise, undo repeatedly up to and including the move
-which placed the stone at point."
- (interactive "P")
- (gnugo--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))
- (unless (display-images-p)
- (user-error "Sorry, display does not support images"))
- (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)))
- (mapc (let ((act (if bool
- 'display
- 'do-not-display)))
- (lambda (yy)
- (setcar (symbol-plist yy) act)))
- (or (gnugo-get :all-yy)
- (gnugo-put :all-yy
- (prog1 (mapcar (lambda (ent)
- (let* ((k (car ent))
- (yy (gnugo-yy (cdr k) (car k))))
- (setplist yy `(not-yet ,(cdr ent)))
- yy))
- (gnugo-get :xpms))
- (gnugo-put :imul
- (image-size (get (gnugo-yy 5 (gnugo-yang ?+))
- 'not-yet)))))))
- (setplist (gnugo-f 'ispc) (and bool '(display (space :width 0))))
- (gnugo-put :highlight-last-move-spec
- (if bool
- `(,(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)))
- (gnugo-put :mul (if bool
- (gnugo-get :imul)
- '(1 . 1)))
- (gnugo-put :display-using-images bool)
- (save-excursion (gnugo-refresh t))))))
-
-(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 t)))
- (message
- "%s%s" pos
- (or (when node
- (let* ((tree (gnugo-get :sgf-gametree))
- (mnum (gnugo--tree-mnum tree))
- (move-num (gethash node mnum)))
- (format " (move %d)" move-num)))
- ""))))
-
-(defun gnugo-switch-to-another ()
- "Switch to another GNU Go game buffer (if any)."
- (interactive)
- (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.
-Interactively, NODE is the one corresponding to the stone at point,
-or the root node if there is no played stone at point, and any
-previous comment is inserted as the initial-input (see `read-string').
-
-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 t)
- (gnugo--root-node))))
- (list node
- (read-string (format "Comment for %s: "
- (if (eq node (gnugo--root-node))
- "root node"
- (gnugo-describe-position)))
- (gnugo-aqr :C node)))))
- (setq node (delq (assq :C node) node))
- (unless (zerop (length comment))
- (gnugo--decorate node :C comment)))
-
-(defun gnugo--struggle (prop updn)
- (unless (eq updn (gnugo--:karma prop)) ; drudgery avoidance
- (let ((color (gnugo-get prop)))
- (if updn
- ;; enable
- (gnugo-gate)
- ;; disable
- (let ((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 'neath 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
-
-;; GTP commands entered by the user are never issued directly to GNU Go;
-;; instead, their behavior and output are controlled by the property
-;; `:gnugo-gtp-command-spec' hung off of each (interned/symbolic) command.
-;; The value of this property is a sub-plist, w/ sub-properties as follows:
-;;
-;; :full -- completely interpret the command string; the value is a
-;; func that takes the list of words derived from splitting the
-;; command string (minus the command) and handles everything.
-;;
-;; :output -- either a keyword specifying the preferred output method:
-;; :message -- show output in minibuffer
-;; :discard -- sometimes you just don't care;
-;; or a function that takes one arg, the output string, and
-;; handles it completely. default is to switch to buffer
-;; "*gnugo command output*" if the output has a newline,
-;; otherwise use `message'.
-;;
-;; :post-thunk -- run after output processing (at the very end).
-
-(defun gnugo-command (command)
- "Send the Go Text Protocol COMMAND (a string) to GNU Go.
-Output and Emacs behavior depend on which command is given (some
-commands are handled completely by Emacs w/o using the subprocess;
-some commands have their output displayed in specially prepared
-buffers or in the echo area; some commands are instrumented to do
-gnugo.el-specific housekeeping).
-
-For example, for the command \"help\", Emacs visits the
-GTP command reference info page.
-
-NOTE: At this time, GTP command handling specification is still
- incomplete. Thus, some commands WILL confuse gnugo.el."
- (interactive "sCommand: ")
- (if (string= "" command)
- (message "(no command given)")
- (let* ((split (split-string command))
- (cmd (intern (car split)))
- (spec (get cmd :gnugo-gtp-command-spec))
- (full (plist-get spec :full)))
- (if full
- (funcall full (cdr split))
- (message "Doing %s ..." command)
- (let* ((ans (gnugo--q command))
- (where (plist-get spec :output)))
- (if (string-match "unknown.command" ans)
- (message "%s" ans)
- (cond ((functionp where) (funcall where ans))
- ((eq :discard where) (message ""))
- ((or (eq :message where)
- (not (string-match "\n" ans)))
- (message "%s" ans))
- (t (switch-to-buffer "*gnugo command output*")
- (erase-buffer)
- (insert ans)
- (message "Doing %s ... done" command)))
- (let ((thunk (plist-get spec :post-thunk)))
- (when thunk (funcall thunk)))))))))
-
-;;;---------------------------------------------------------------------------
-;;; Major mode for interacting with a GNUGO subprocess
-
-(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 (see `gnugo-board-mode-map')."
- ;; hint: (search-forward "define-key gnugo-board-mode-map")
- :syntax-table nil
- :abbrev-table nil
- (buffer-disable-undo) ; todo: undo undo undoing
- (setq font-lock-defaults '(gnugo-font-lock-keywords t)
- truncate-lines t)
- (add-hook 'kill-buffer-hook 'gnugo-cleanup nil t)
-
- ;; Previously, we used ‘(eq gnugo--intangible 'cursor-intangible)’
- ;; here, but (a) this is a bit quicker; and (b) we want to placate
- ;; Emacs 24, which blurts out a "not known to be defined" warning.
- ;; (Apparently it cannot infer equivalence of the two conditions.)
- (if (fboundp 'cursor-intangible-mode)
- (cursor-intangible-mode 1)
- ;; Make sure ‘intangible’ DTRT in this buffer.
- (setq-local inhibit-point-motion-hooks nil))
-
- (setq-local gnugo-state (gnugo--mkht :size (1- 42)))
- (setq-local 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.
-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.
-
-Before starting, Emacs queries you for additional command-line
-options (Emacs supplies \"--mode gtp --quiet\" automatically).
-
-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'.
-
-\\<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))
- (when (gnugo-board-buffer-p buf)
- (push (cons (buffer-name buf) buf) acc)))
- acc))
- (n (length all)))
- (if (and (not new-game)
- (cl-plusp n)
- (y-or-n-p (format "GNU Go game%s in progress, resume play? "
- (if (= 1 n) "" "s"))))
- ;; resume
- (switch-to-buffer
- (cdr (if (= 1 n)
- (car all)
- (let ((sel (completing-read "Which one? " all nil t)))
- (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* ((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)
- (gnugo-put :proc proc)
- (set-process-sentinel proc 'gnugo-sentinel)
- ;; Emacs is too protective sometimes, blech.
- (set-process-query-on-exit-flag proc nil)
- (gnugo-put :diamond (substring (process-name proc) 5))
- (gnugo-put :gnugo-color (gnugo-other user-color))
- (if filename
- (gnugo-read-sgf-file (expand-file-name filename))
- (cl-flet
- ((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 "%F")
- :RU (if (member "--chinese-rules" args)
- "Chinese"
- "Japanese")
- :KM komi)
- (let ((ub (gnugo--blackp user-color)))
- (r! (if ub :PW :PB) (concat "GNU Go " (gnugo-query "version"))
- (if ub :PB :PW) (user-full-name)))
- (unless (zerop handicap)
- (r! :HA handicap
- :AB (mapcar (gnugo--as-cc-func)
- (gnugo-lsquery "fixed_handicap %d"
- handicap)))))))
- (gnugo-put :waiting-start (current-time))
- (gnugo-refresh t)
- (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)))
- (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)
- (gnugo--turn-the-wheel)))))
-
-;;;---------------------------------------------------------------------------
-;;; Load-time actions
-
-(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
- (jam cmd (car ls) (cadr ls))
- (setq ls (cddr ls)))))))
- (cl-macrolet ((deffull (who &body body)
- (declare (indent 1))
- `(defgtp ',who :full (lambda (sel)
- ,@body))))
-
- (deffull help
- (info "(gnugo)GTP command reference")
- (when sel (setq sel (intern (car sel))))
- (let (buffer-read-only pad cur spec output found)
- (cl-flet
- ((note (s) (insert pad "[NOTE: gnugo.el " s ".]\n")))
- (goto-char (point-min))
- (save-excursion
- (while (re-search-forward "^ *[*] \\([a-zA-Z_]+\\)\\(:.*\\)*\n"
- nil t)
- (unless pad
- (setq pad (make-string (- (match-beginning 1)
- (match-beginning 0))
- 32)))
- (when (plist-get
- (setq spec
- (get (setq cur (intern (match-string 1)))
- :gnugo-gtp-command-spec))
- :full)
- (note "handles this command completely"))
- (when (setq output (plist-get spec :output))
- (if (functionp output)
- (note "handles the output specially")
- (cl-case output
- (:discard (note "discards the output"))
- (:message (note "displays the output in the echo
area")))))
- (when (eq sel cur)
- (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)))))
-
- (deffull final_score
- ;; Explicit ignorance avoids byte-compiler warning.
- (ignore sel)
- (gnugo-display-final-score))
-
- (defgtp '(boardsize
- clear_board
- fixed_handicap)
- :output :discard
- :post-thunk (lambda ()
- (gnugo--unclose-game)
- (gnugo--forget :last-mover)
- ;; ugh
- (gnugo--SZ! (gnugo--nquery "query_boardsize"))
- (gnugo-refresh t)))
-
- (deffull loadsgf
- (gnugo-read-sgf-file (car sel)))
-
- (deffull (undo gg-undo)
- (gnugo--climb-towards-root
- (let (n)
- (cond ((not sel) 1)
- ((cl-plusp (setq n (string-to-number (car sel)))) n)
- (t (validpos (car sel) t)))))))))
-
-;; Respect user customizations; try not to clobber the keymap on reload.
-;; This (top-level, conditionalized, late-in-file) form is not "idiomatic",
-;; but it does avoid forward references [which are ugly, IMHO --ttn].
-;; TODO: Link to emacs-devel thread, here.
-;;
-;; hacker override: (define-key gnugo-board-mode-map "?" nil)
-(unless (eq 'describe-mode (lookup-key gnugo-board-mode-map "?"))
- (cl-loop
- for (key binding . _)
- on '("?" 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)
- by #'cddr
- do (define-key gnugo-board-mode-map key binding)))
-
-(provide 'gnugo)
-
-
-;;;---------------------------------------------------------------------------
-;;; The remainder of this file defines a simplified SGF-handling library.
-;;; When/if it should start to attain generality, it should be split off into
-;;; a separate file (probably named sgf.el) w/ funcs and vars renamed sans the
-;;; "gnugo/" prefix.
-
-(defconst gnugo/sgf-*r4-properties*
- '((AB "Add Black" setup list stone)
- (AE "Add Empty" game list point)
- (AN "Annotation" game simpletext)
- (AP "Application" root (simpletext . simpletext))
- (AR "Arrow" - list (point . point))
- (AS "Who adds stones" - simpletext) ; (LOA)
- (AW "Add White" setup list stone)
- (B "Black" move move)
- (BL "Black time left" move real)
- (BM "Bad move" move double)
- (BR "Black rank" game simpletext)
- (BT "Black team" game simpletext)
- (C "Comment" - text)
- (CA "Charset" root simpletext)
- (CP "Copyright" game simpletext)
- (CR "Circle" - list point)
- (DD "Dim points" - elist point) ; (inherit)
- (DM "Even position" - double)
- (DO "Doubtful" move none)
- (DT "Date" game simpletext)
- (EV "Event" game simpletext)
- (FF "Fileformat" root [number (1 . 4)])
- (FG "Figure" - (or none (number . simpletext)))
- (GB "Good for Black" - double)
- (GC "Game comment" game text)
- (GM "Game" root [number (1 . 20)])
- (GN "Game name" game simpletext)
- (GW "Good for White" - double)
- (HA "Handicap" game number) ; (Go)
- (HO "Hotspot" - double)
- (IP "Initial pos." game simpletext) ; (LOA)
- (IT "Interesting" move none)
- (IY "Invert Y-axis" game simpletext) ; (LOA)
- (KM "Komi" game real) ; (Go)
- (KO "Ko" move none)
- (LB "Label" - list (point . simpletext))
- (LN "Line" - list (point . point))
- (MA "Mark" - list point)
- (MN "set move number" move number)
- (N "Nodename" - simpletext)
- (OB "OtStones Black" move number)
- (ON "Opening" game text)
- (OT "Overtime" game simpletext)
- (OW "OtStones White" move number)
- (PB "Player Black" game simpletext)
- (PC "Place" game simpletext)
- (PL "Player to play" setup color)
- (PM "Print move mode" - number) ; (inherit)
- (PW "Player White" game simpletext)
- (RE "Result" game simpletext)
- (RO "Round" game simpletext)
- (RU "Rules" game simpletext)
- (SE "Markup" - point) ; (LOA)
- (SL "Selected" - list point)
- (SO "Source" game simpletext)
- (SQ "Square" - list point)
- (ST "Style" root [number (0 . 3)])
- (SU "Setup type" game simpletext) ; (LOA)
- (SZ "Size" root (or number (number . number)))
- (TB "Territory Black" - elist point) ; (Go)
- (TE "Tesuji" move double)
- (TM "Timelimit" game real)
- (TR "Triangle" - list point)
- (TW "Territory White" - elist point) ; (Go)
- (UC "Unclear pos" - double)
- (US "User" game simpletext)
- (V "Value" - real)
- (VW "View" - elist point) ; (inherit)
- (W "White" move move)
- (WL "White time left" move real)
- (WR "White rank" game simpletext)
- (WT "White team" game simpletext)
- (LT "Lose on time" setup simpletext))
- ;; r4-specific notes
- ;; - changed: DT FG LB RE RU SZ
- ;; - added: AP AR AS DD IP IY LN OT PM SE SQ ST SU VW
- "List of SGF[4] properties, each of the form (PROP NAME CONTEXT SPEC...).")
-
-(defun gnugo/sgf-create (file-or-data &optional data-p)
- "Return the SGF[4] collection parsed from FILE-OR-DATA.
-FILE-OR-DATA is a file name or SGF[4] data.
-Optional arg DATA-P non-nil means FILE-OR-DATA is
-a string containing SGF[4] data.
-A collection is a list of gametrees, each a vector of four elements:
-
- ENDS -- a vector of node lists, with shared tails
- (last element of all the lists is the root node)
-
- MNUM -- `eq' hash: node to move numbers; non-\"move\" nodes
- have a move number of the previous \"move\" node (or zero)
-
- ROOT -- the root node"
- ;; Arg names inspired by `create-image', despite -P being frowned upon.
- (let ((keywords (or (get 'gnugo/sgf-*r4-properties* :keywords)
- (put 'gnugo/sgf-*r4-properties* :keywords
- (mapcar (lambda (full)
- (cons (car full)
- (intern (format ":%s" (car full)))))
- gnugo/sgf-*r4-properties*))))
- (specs (or (get 'gnugo/sgf-*r4-properties* :specs)
- (put 'gnugo/sgf-*r4-properties* :specs
- (mapcar (lambda (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 (cl-case end
- (:end (lambda (char) (= ?\] char)))
- (:mid (lambda (char) (= ?\: char)))
- (t (lambda (char) (or (= ?\: char)
- (= ?\] char))))))
- c)
- (while (not (funcall endp (setq c (following-char))))
- (cond ((= ?\\ c)
- (delete-char 1)
- (if (eolp)
- (kill-line 1)
- (forward-char 1)))
- ((unless preserve-whitespace
- (looking-at "\\s-+"))
- (delete-region (point) (match-end 0))
- (insert " "))
- (t (forward-char 1))))
- (buffer-substring-no-properties beg (point))))
- (one (type end) (let ((s (progn
- (forward-char 1)
- (x end (eq 'text type)))))
- (cl-case type
- ((stone point move)
- ;; blech, begone bu"tt"-ugly blatherings
- ;; (but bide brobdingnagian boards)...
- (if (and (string= "tt" s)
- SZ
- (>= 19 SZ))
- ""
- s))
- ((simpletext color) s)
- ((number real double) (string-to-number s))
- ((text) s)
- ((none) "")
- (t (error "Unhandled type: %S" type)))))
- (val (spec) (cond ((symbolp spec)
- (one spec :end))
- ((vectorp spec)
- ;; todo: check range here.
- (one (aref spec 0) :end))
- ((eq 'or (car spec))
- (let ((v (one (cadr spec) t)))
- (if (= ?\] (following-char))
- v
- (forward-char 1)
- ;; todo: this assumes `spec' has the form
- ;; (or foo (foo . bar))
- ;; i.e., foo is not rescanned. e.g., `SZ'.
- ;; probably this assumption is consistent
- ;; w/ the SGF authors' desire to make the
- ;; parsing easy, but you never know...
- (cons v (one (cl-cdaddr spec) :end)))))
- (t (cons (one (car spec) :mid)
- (one (cdr spec) :end)))))
- (short (who) (when (eobp)
- (error "Unexpected EOF while reading %s" who)))
- (atvalp () (= ?\[ (following-char)))
- (PROP () (let (name spec ltype)
- (sw) (short 'property)
- (when (looking-at "[A-Z]")
- (setq name (read (current-buffer))
- spec (gnugo-aqr name specs))
- (sw)
- (cons
- (gnugo-aqr name keywords)
- (prog1 (if (= 1 (length spec))
- (val (car spec))
- (unless (memq (setq ltype (car spec))
- '(elist list))
- (error "Bad spec: %S" spec))
- (if (and (eq 'elist ltype) (sw)
- (not (atvalp)))
- nil
- (let ((type (cadr spec))
- mo ls)
- (while (and (sw) (atvalp)
- (setq mo (val type)))
- (push mo ls)
- (forward-char 1))
- (forward-char -1)
- (nreverse ls))))
- (forward-char 1))))))
- (morep () (and (sw) (not (eobp))))
- (seek (c) (and (morep) (= c (following-char))))
- (seek-into (c) (when (seek c)
- (forward-char 1)
- t))
- (NODE () (when (seek-into ?\;)
- (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)
- (seek-into ?\()
- (while (seek ?\;)
- (setq prev (car ls)
- node (NODE))
- (puthash node (+ (if (gnugo--move-prop node)
- 1
- 0)
- (gethash prev mnum 0))
- mnum)
- (push node
- ls))
- (prog1
- (if (not (seek ?\())
- ;; singular
- (list ls)
- ;; multiple
- (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)))
- (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))
- (specs (mapcar (lambda (full)
- (cons (intern (format ":%s" (car full)))
- (cl-cdddr full)))
- gnugo/sgf-*r4-properties*))
- p name v spec)
- (cl-labels
- ((esc (composed val)
- (mapconcat (lambda (c)
- (cl-case c
- ;; ‘?\[’ is not strictly required
- ;; but neither is it forbidden.
- ((?\[ ?\] ?\\) (format "\\%c" c))
- (?: (concat (if composed "\\" "") ":"))
- (t (string c))))
- ;; ‘string-to-list’ unnecessary; ‘mapconcat’ DTRT
- (if (stringp val)
- val
- (format "%s" val))
- ""))
- (>>one (v) (insert "[" (esc nil v)
- "]"))
- (>>two (v) (insert "[" (esc t (car v))
- ":" (esc t (cdr v))
- "]"))
- (>>nl () (cond ((memq name aft-newline-appreciated)
- (insert "\n"))
- ((< 60 (current-column))
- (save-excursion
- (goto-char p)
- (insert "\n")))))
- (>>prop (prop)
- (setq p (point)
- name (car prop)
- v (cdr prop))
- (insert (substring (symbol-name name) 1))
- (cond ((not v))
- ((and (consp v)
- (setq spec (gnugo-aqr name specs))
- (memq (car spec)
- '(list elist)))
- (>>nl)
- (let ((>> (if (consp (cadr spec))
- #'>>two
- #'>>one)))
- (dolist (little-v v)
- (setq p (point))
- (funcall >> little-v)
- (>>nl))))
- ((consp v)
- (>>two v) (>>nl))
- (t
- (>>one v) (>>nl))))
- (>>node (node)
- (cl-loop
- initially (insert ";")
- for prop in node
- do (>>prop prop)))
- (>>tree (tree)
- (unless (zerop (current-column))
- (newline))
- (insert "(")
- (dolist (x tree)
- (funcall (if (gnugo--nodep x)
- #'>>node
- #'>>tree)
- x))
- (insert ")")))
- (with-temp-buffer
- (dolist (tree collection)
- ;; write it out
- (let ((ht (gnugo--mkht))
- (leaves (append (gnugo--tree-ends tree) nil)))
- (cl-flet
- ((hang (stack)
- (cl-loop
- with rh ; rectified history
- with bp ; branch point
- for node in stack
- until (setq bp (gethash node ht))
- do (puthash node
- (push node rh) ; good for now: ½τ
- ht)
- finally return
- (if (not bp)
- ;; first run: main line
- rh
- ;; subsequent runs: grafts (value discarded)
- (setcdr bp (nconc
- ;; Maintain order of ‘leaves’.
- (let ((was (cdr bp)))
- (if (gnugo--nodep (car was))
- (list was)
- was))
- (list rh)))))))
- (setq tree (hang (pop leaves)))
- (mapc #'hang leaves)
- (>>tree tree))))
- (newline)
- (write-file filename)))))
-
-;;; gnugo.el ends here
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [elpa] master 6160089: * externals-list: Convert gnugo to :external,
Stefan Monnier <=