| 1 | ;;; gnugo.el |
| 2 | ;;; |
| 3 | ;;; This is GNU Go, a Go program. Contact gnugo@gnu.org, or see |
| 4 | ;;; http://www.gnu.org/software/gnugo/ for more information. |
| 5 | ;;; |
| 6 | ;;; Copyright (C) 1999, 2000, 2002, 2003, 2004, 2005, 2006, 2007 |
| 7 | ;;; and 2008 by the Free Software Foundation. |
| 8 | ;;; |
| 9 | ;;; This program is free software; you can redistribute it and/or |
| 10 | ;;; modify it under the terms of the GNU General Public License |
| 11 | ;;; as published by the Free Software Foundation - version 3 |
| 12 | ;;; or (at your option) any later version. |
| 13 | ;;; |
| 14 | ;;; This program is distributed in the hope that it will be |
| 15 | ;;; useful, but WITHOUT ANY WARRANTY; without even the implied |
| 16 | ;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR |
| 17 | ;;; PURPOSE. See the GNU General Public License in file COPYING |
| 18 | ;;; for more details. |
| 19 | ;;; |
| 20 | ;;; You should have received a copy of the GNU General Public |
| 21 | ;;; License along with this program; if not, write to the Free |
| 22 | ;;; Software Foundation, Inc., 51 Franklin Street, Fifth Floor, |
| 23 | ;;; Boston, MA 02111, USA. |
| 24 | ;;; |
| 25 | ;;; This Emacs mode for GNU Go may work with Emacs 20.x but |
| 26 | ;;; the graphical display requires Emacs 21.x. |
| 27 | ;;; |
| 28 | ;;; Maintainer: Thien-Thi Nguyen |
| 29 | ;;; |
| 30 | ;;; Rel:standalone-gnugo-el-2-2-8 |
| 31 | ;;; |
| 32 | ;;; Description: Run GNU Go in a buffer. |
| 33 | |
| 34 | ;;; Commentary: |
| 35 | |
| 36 | ;; Playing |
| 37 | ;; ------- |
| 38 | ;; |
| 39 | ;; This file provides the command `gnugo' which allows you to play the game of |
| 40 | ;; go against the external program "gnugo" (http://www.gnu.org/software/gnugo) |
| 41 | ;; in a dedicated Emacs buffer, or to resume a game in progress. NOTE: In |
| 42 | ;; this file, to avoid confusion w/ elisp vars and funcs, we use the term "GNU |
| 43 | ;; Go" to refer to the process object created by running the external program. |
| 44 | ;; |
| 45 | ;; At the start of a new game, you can pass additional command-line arguments |
| 46 | ;; to GNU Go to specify level, board size, color, komi, handicap, etc. By |
| 47 | ;; default GNU Go plays at level 10, board size 19, color white, and zero for |
| 48 | ;; both komi and handicap. |
| 49 | ;; |
| 50 | ;; To play a stone, move the cursor to the desired vertice and type `SPC' or |
| 51 | ;; `RET'; to pass, `P' (note: uppercase); to quit, `q'; to undo one of your |
| 52 | ;; moves (as well as a possibly intervening move by GNU Go), `u'. To undo |
| 53 | ;; back through an arbitrary stone that you played, place the cursor on a |
| 54 | ;; stone and type `U' (note: uppercase). Other keybindings are described in |
| 55 | ;; the `gnugo-board-mode' documentation, which you may view with the command |
| 56 | ;; `describe-mode' (normally `C-h m') in that buffer. The buffer name shows |
| 57 | ;; the last move and who is currently to play. Capture counts and other info |
| 58 | ;; are shown on the mode line immediately following the major mode name. |
| 59 | ;; |
| 60 | ;; While GNU Go is pondering its next move, certain commands that rely on its |
| 61 | ;; assistence will result in a "still waiting" error. Do not be alarmed; that |
| 62 | ;; is normal. When it is your turn again you may retry the command. In the |
| 63 | ;; meantime, you can use Emacs for other tasks, or start an entirely new game |
| 64 | ;; with `C-u M-x gnugo'. (NOTE: A new game will slow down all games. :-) |
| 65 | ;; |
| 66 | ;; If GNU Go should crash during a game the mode line will show "no process". |
| 67 | ;; Please report the event to the GNU Go maintainers so that they can improve |
| 68 | ;; the program. |
| 69 | ;; |
| 70 | ;; This code was tested with: |
| 71 | ;; - GNU Emacs: 21.3 / 21.3.50 (from CVS) |
| 72 | ;; - GNU Go: 3.3.15 / 3.4 / 3.6-pre3 |
| 73 | ;; |
| 74 | ;; |
| 75 | ;; Meta-Playing (aka Customizing) |
| 76 | ;; ------------------------------ |
| 77 | ;; |
| 78 | ;; Customization is presently limited to |
| 79 | ;; vars: `gnugo-program' |
| 80 | ;; `gnugo-animation-string' |
| 81 | ;; `gnugo-mode-line' |
| 82 | ;; `gnugo-xpms' |
| 83 | ;; normal hooks: `gnugo-board-mode-hook' |
| 84 | ;; `gnugo-post-move-hook' |
| 85 | ;; and the keymap: `gnugo-board-mode-map' |
| 86 | ;; |
| 87 | ;; The variable `gnugo-xpms' is a special case. To set it you need to load |
| 88 | ;; gnugo-xpms.el (http://www.emacswiki.org) or some other library w/ congruent |
| 89 | ;; interface. |
| 90 | ;; |
| 91 | ;; |
| 92 | ;; Meta-Meta-Playing (aka Hacking) |
| 93 | ;; ------------------------------- |
| 94 | ;; |
| 95 | ;; You may wish to first fix the bugs: |
| 96 | ;; - `gnugo-toggle-dead-group' only half-complete; see docstring for details |
| 97 | ;; - probably sgf handling is not 100% to spec (excuse: written w/o spec!) |
| 98 | ;; - subprocess should provide scoring details, gnugo.el not yet blissful |
| 99 | ;; - no move history and sgf tree re-init in the case of mid-session loadsgf |
| 100 | ;; |
| 101 | ;; Otherwise (we can live w/ some bugs), here are some ideas: |
| 102 | ;; - talk GTP over the network |
| 103 | ;; - "assist minor mode" (see gnugo-extra.el for work in progress) |
| 104 | ;; - using assist minor mode, gnugo-v-gnugo (ibid) |
| 105 | ;; - extract GNU Go Board mode and sgf stuff into sgf.el; make gnugo.el use it |
| 106 | ;; - make gnugo (the external program) support query (read-only) thread |
| 107 | ;; so as to be able to lift "still waiting" restriction |
| 108 | ;; - alternatively, extend GNU Go Board mode to manage another subprocess |
| 109 | ;; dedicated to analysis (no genmove) |
| 110 | ;; - command `C' to add a comment to the sgf tree |
| 111 | ;; - command `C-u =' to label a position |
| 112 | ;; - sgf tree display, traversal (belongs in sgf.el); review game history |
| 113 | ;; in another buffer; branch subgame tree at arbitrary point |
| 114 | ;; - subgame branch matriculation (maturity: child leaves the family) |
| 115 | ;; - dribble the sgf tree |
| 116 | ;; - "undo undo undoing"; integrate Emacs undo, GTP undo, subgame branching |
| 117 | ;; - make buffer name format configurable (but enforce uniqueness) |
| 118 | ;; - more tilde escapes for `gnugo-mode-line' |
| 119 | ;; - make veneration configurable |
| 120 | ;; - make animation more configurable; lift same-color-stones-only |
| 121 | ;; restriction; allow sequencing rather than lock-step; include sound |
| 122 | ;; - [your hacking ideas here] |
| 123 | ;; |
| 124 | ;; Some gnugo.el hackers update http://www.emacswiki.org -- check it out! |
| 125 | ;; |
| 126 | ;; |
| 127 | ;; History |
| 128 | ;; ------- |
| 129 | ;; |
| 130 | ;; Originally gnugo.el was written to interact w/ "gnugo --mode text" and then |
| 131 | ;; "gnugo --mode emacs" as the subprocess. Those versions were released as |
| 132 | ;; 1.x, w/ x < 14. In Novemeber 2002, gnugo.el was changed to interact w/ |
| 133 | ;; "gnugo --mode gtp", but was released as 1.14 through 1.26, even though the |
| 134 | ;; proper versions should be 2.0.x for "--mode gtp", and 2.1.x for XPM image |
| 135 | ;; support. (Sorry about the confusion.) |
| 136 | ;; |
| 137 | ;; Thus we arrive at at the current version. The first gnugo.el to be |
| 138 | ;; released w/ a `gnugo-version' variable is "2.2.0". The versioning scheme |
| 139 | ;; is strictly monotonically increasing numbers and dots, no letters or other |
| 140 | ;; suffixes (and none of this even/odd crap). Here we list, aside from the |
| 141 | ;; bugfixes, some of the notable changes introduced in each released version: |
| 142 | ;; |
| 143 | ;; 2.2.x -- uncluttered, letters and numbers hidden, board centered |
| 144 | ;; buffer name shows last move and current player |
| 145 | ;; mode-line customization (var `gnugo-mode-line') |
| 146 | ;; new commands: `=', `h', `s', `F', `R', `l', `U' |
| 147 | ;; program option customization (var `gnugo-program') |
| 148 | ;; new hooks (vars `gnugo-post-move-hook', `gnugo-board-mode-hook') |
| 149 | ;; multiple independent buffers/games |
| 150 | ;; XPM set can be changed on the fly (global and/or local) |
| 151 | ;; font-locking for "X", "O", "[xo]" |
| 152 | ;; undo by N moves, by "move pair", or by board position |
| 153 | ;; |
| 154 | ;; |
| 155 | ;; History Predicted |
| 156 | ;; ----------------- |
| 157 | ;; |
| 158 | ;; If you are an elisp programmer, this section might not apply to you; |
| 159 | ;; the GPL allows you to define the future of the code you receive under |
| 160 | ;; its terms, as long as you do not deny that freedom to subsequent users. |
| 161 | ;; |
| 162 | ;; For users who are not elisp programmers, you can look forward to gradual |
| 163 | ;; refinement in 2.x, splitting into gnugo.el and sgf.el in 3.x, and then |
| 164 | ;; eventual merging into GNU Emacs for 4.x (if RMS gives it the thumbs-up). |
| 165 | ;; If it is not accepted into Emacs at that time, a new maintainer will be |
| 166 | ;; sought. In any case, it will no longer be bundled w/ ttn-pers-elisp. |
| 167 | |
| 168 | ;;; Code: |
| 169 | |
| 170 | (require 'cl) ; use the source luke! |
| 171 | (ignore-errors (require 'time-date)) ; for `time-subtract' |
| 172 | |
| 173 | |
| 174 | ;;; ========================================================================== |
| 175 | |
| 176 | ; Modifications to gnugo.el-2.2.8: |
| 177 | ; |
| 178 | ; * Grid display implemented |
| 179 | ; * SGF handling improved |
| 180 | ; * Undo and Redo related enhancements |
| 181 | ; * Primitive edit mode |
| 182 | ; * Regression view mode |
| 183 | |
| 184 | ;;;--------------------------------------------------------------------------- |
| 185 | ;;; Political arts |
| 186 | |
| 187 | (defconst gnugo-version "2.2.8.b5" |
| 188 | "Version of gnugo.el currently loaded. |
| 189 | Note that more than two dots in the value indicates \"pre-release\", |
| 190 | or \"alpha\" or \"hackers-invited-all-else-beware\"; use at your own risk! |
| 191 | The more dots the more courage/foolishness you must find to continue. |
| 192 | See source code for a history of what means what version-wise.") |
| 193 | |
| 194 | ;;;--------------------------------------------------------------------------- |
| 195 | ;;; Variables for the uninquisitive programmer |
| 196 | |
| 197 | (defvar gnugo-program "gnugo" |
| 198 | "*Command to start an external program that speaks GTP, such as \"gnugo\". |
| 199 | The value may also be in the form \"PROGRAM OPTIONS...\" in which case the |
| 200 | the command `gnugo' will prefix OPTIONS in its default offering when it |
| 201 | queries you for additional options. It is an error for \"--mode\" to appear |
| 202 | in OPTIONS. |
| 203 | |
| 204 | For more information on GTP and GNU Go, feel free to visit: |
| 205 | http://www.gnu.org/software/gnugo") |
| 206 | |
| 207 | (defvar gnugo-board-mode-map nil |
| 208 | "Keymap for GNU Go Board mode.") |
| 209 | |
| 210 | (defvar gnugo-board-mode-hook nil |
| 211 | "*Hook run when entering GNU Go Board mode.") |
| 212 | |
| 213 | (defvar gnugo-post-move-hook nil |
| 214 | "*Normal hook run after a move and before the board is refreshed. |
| 215 | Hook functions can prevent the call to `gnugo-refresh' by evaluating: |
| 216 | (setq inhibit-gnugo-refresh t) |
| 217 | Initially, when `run-hooks' is called, the current buffer is the GNU Go |
| 218 | Board buffer of the game. Hook functions that switch buffers must take |
| 219 | care not to call (directly or indirectly through some other function) |
| 220 | `gnugo-put' or `gnugo-get' after the switch.") |
| 221 | |
| 222 | (defvar gnugo-animation-string |
| 223 | (let ((jam "*#") (blink " #") (spin "-\\|/") (yada "*-*!")) |
| 224 | (concat jam jam jam jam jam |
| 225 | ;; "SECRET MESSAGE HERE" |
| 226 | blink blink blink blink blink blink blink blink |
| 227 | ;; Playing go is like fighting ignorance: when you think you have |
| 228 | ;; surrounded something by knowing it very well it often turns |
| 229 | ;; out that in the time you spent deepening this understanding, |
| 230 | ;; other areas of ignorance have surrounded you. |
| 231 | spin spin spin spin spin spin spin spin spin |
| 232 | ;; Playing go is not like fighting ignorance: what one person |
| 233 | ;; knows many people may come to know; knowledge does not build |
| 234 | ;; solely move by move. Wisdom, on the other hand... |
| 235 | yada yada yada)) |
| 236 | "*String whose individual characters are used for animation. |
| 237 | Specifically, the `gnugo-worm-stones' and `gnugo-dragon-stones' commands |
| 238 | render the stones in their respective (computed) groups as the first |
| 239 | character in the string, then the next, and so on until the string (and/or |
| 240 | the viewer) is exhausted.") |
| 241 | |
| 242 | (defvar gnugo-mode-line "~b ~w :~m ~n :~u" |
| 243 | "*A `mode-line-format'-compliant value for GNU Go Board mode. |
| 244 | If a single string, the following special escape sequences are |
| 245 | replaced with their associated information: |
| 246 | ~b,~w black,white captures (a number) |
| 247 | ~p current player (black or white) |
| 248 | ~m move number |
| 249 | ~n size of undo stack |
| 250 | ~t time waiting for the current move |
| 251 | ~u time taken for the Ultimate (most recent) move |
| 252 | The times are in seconds, or \"-\" if that information is not available. |
| 253 | For ~t, the value is a snapshot, use `gnugo-refresh' to update it.") |
| 254 | |
| 255 | (defvar gnugo-font-lock-keywords |
| 256 | '(("X" . font-lock-string-face) |
| 257 | ("O" . font-lock-builtin-face)) |
| 258 | "*Font lock keywords for `gnugo-board-mode'.") |
| 259 | |
| 260 | ;;;--------------------------------------------------------------------------- |
| 261 | ;;; Variables for the inquisitive programmer |
| 262 | |
| 263 | (defvar gnugo-option-history nil) |
| 264 | |
| 265 | (defvar gnugo-state nil) ; (let ((proc (get-process "gnugo"))) |
| 266 | ; (when proc |
| 267 | ; (with-current-buffer (process-buffer proc) |
| 268 | ; (when (hash-table-p gnugo-state) |
| 269 | ; (let (acc) |
| 270 | ; (maphash (lambda (&rest args) |
| 271 | ; (setq acc (cons args acc))) |
| 272 | ; gnugo-state) |
| 273 | ; (reverse acc)))))) |
| 274 | |
| 275 | (defvar gnugo-regression-directory nil) |
| 276 | |
| 277 | (eval-when-compile |
| 278 | (defvar gnugo-xpms nil)) |
| 279 | |
| 280 | ;;;--------------------------------------------------------------------------- |
| 281 | ;;; In case Emacs is lacking |
| 282 | |
| 283 | (unless (fboundp 'delete-dups) |
| 284 | (defun delete-dups (list) ; from repo 2004-10-29 |
| 285 | "Destructively remove `equal' duplicates from LIST. |
| 286 | Store the result in LIST and return it. LIST must be a proper list. |
| 287 | Of several `equal' occurrences of an element in LIST, the first |
| 288 | one is kept." |
| 289 | (let ((tail list)) |
| 290 | (while tail |
| 291 | (setcdr tail (delete (car tail) (cdr tail))) |
| 292 | (setq tail (cdr tail)))) |
| 293 | list)) |
| 294 | |
| 295 | (unless (fboundp 'time-subtract) |
| 296 | (defun time-subtract (t1 t2) ; from repo 2004-10-29 |
| 297 | "Subtract two time values. |
| 298 | Return the difference in the format of a time value." |
| 299 | (let ((borrow (< (cadr t1) (cadr t2)))) |
| 300 | (list (- (car t1) (car t2) (if borrow 1 0)) |
| 301 | (- (+ (if borrow 65536 0) (cadr t1)) (cadr t2)))))) |
| 302 | |
| 303 | ;;;--------------------------------------------------------------------------- |
| 304 | ;;; Support functions |
| 305 | |
| 306 | (put 'gnugo-put 'lisp-indent-function 1) |
| 307 | (defun gnugo-put (key value) (puthash key value gnugo-state)) |
| 308 | (defun gnugo-get (key) (gethash key gnugo-state)) |
| 309 | |
| 310 | (let ((docs "Put or get move/game/board-specific properties. |
| 311 | \(This docstring is shared by `gnugo-put' and `gnugo-get'.\) |
| 312 | |
| 313 | There are many properties, each named by a keyword, that record and control |
| 314 | how gnugo.el manages each game. Each GNU Go Board buffer has its own set |
| 315 | of properties, stored in the hash table `gnugo-state'. Here we document |
| 316 | some of the more stable properties. You may wish to use them as part of |
| 317 | a `gnugo-post-move-hook' function, for example. Be careful to preserve |
| 318 | the current buffer as `gnugo-state' is made into a buffer-local variable. |
| 319 | NOTE: In the following, \"see foo\" actually means \"see foo source or |
| 320 | you may never really understand to any degree of personal satisfaction\". |
| 321 | |
| 322 | :proc -- subprocess named \"gnugo\", \"gnugo<1>\" and so forth |
| 323 | |
| 324 | :diamond -- the part of the subprocess name after \"gnugo\", may be \"\" |
| 325 | |
| 326 | :board-size -- numbers; see `gnugo-board-mode' |
| 327 | :handicap |
| 328 | :komi |
| 329 | |
| 330 | :game-over -- nil until game over at which time its value is set to |
| 331 | the alist `((live GROUP ...) (dead GROUP ...))' |
| 332 | |
| 333 | :sgf-tree -- the (very simple) list of nodes, each node a list of |
| 334 | properties of the form `(:XY . VALUE)'; see functions |
| 335 | `gnugo-push-move', `gnugo-note' and `gnugo-write-sgf-file' |
| 336 | :future-history -- an undo stack (so moves undone may be redone) |
| 337 | |
| 338 | :gnugo-color -- either \"black\" or \"white\" |
| 339 | :user-color |
| 340 | :last-mover |
| 341 | |
| 342 | :last-waiting -- seconds and time value, respectively; see `gnugo-push-move' |
| 343 | :waiting-start |
| 344 | |
| 345 | :black-captures -- these are strings since gnugo.el doesn't do anything |
| 346 | :white-captures w/ the information besides display it in the mode line; |
| 347 | gory details in functions `gnugo-propertize-board-buffer' |
| 348 | and `gnugo-merge-showboard-results' (almost more effort |
| 349 | than they are worth!) |
| 350 | |
| 351 | :display-using-images -- XPMs, to be precise; see functions `gnugo-yy', |
| 352 | `gnugo-toggle-image-display' and `gnugo-refresh', |
| 353 | as well as gnugo-xpms.el (available elsewhere) |
| 354 | :show-grid -- display the grid |
| 355 | |
| 356 | :all-yy -- list of 46 keywords used as the `category' text property |
| 357 | (so that their plists, typically w/ property `display' or |
| 358 | `do-not-display') are consulted by the Emacs display engine; |
| 359 | 46 = 9 places * (4 moku + 1 empty) + 1 hoshi; see functions |
| 360 | `gnugo-toggle-image-display', `gnugo-yy' and `gnugo-yang' |
| 361 | |
| 362 | :lparen-ov -- overlays shuffled about to indicate the last move; only |
| 363 | :rparen-ov one is used when displaying using images |
| 364 | |
| 365 | :last-user-bpos -- board position; keep the hapless human happy |
| 366 | |
| 367 | If you browse the source you will see a form for extracting all the |
| 368 | properties from `gnugo-state' (even those not documented here). As |
| 369 | things stabilize probably more of them will be added to this docstring.")) |
| 370 | (put 'gnugo-put 'function-documentation docs) |
| 371 | (put 'gnugo-get 'function-documentation docs)) |
| 372 | |
| 373 | (defun gnugo-board-buffer-p (&optional buffer) |
| 374 | "Return non-nil if BUFFER is a GNU Go Board buffer." |
| 375 | (with-current-buffer (or buffer (current-buffer)) gnugo-state)) |
| 376 | |
| 377 | (defun gnugo-board-user-play-ok-p (&optional buffer) |
| 378 | "Return non-nil if BUFFER is a GNU Go Board buffer ready for a user move." |
| 379 | (with-current-buffer (or buffer (current-buffer)) |
| 380 | (and gnugo-state (not (gnugo-get :waitingp))))) |
| 381 | |
| 382 | (defun gnugo-other (color) |
| 383 | (if (string= "black" color) "white" "black")) |
| 384 | |
| 385 | (defun gnugo-gate (&optional in-progress-p) |
| 386 | (unless (gnugo-board-buffer-p) |
| 387 | (error "Wrong buffer -- try M-x gnugo")) |
| 388 | (unless (gnugo-get :proc) |
| 389 | (error "No \"gnugo\" process!")) |
| 390 | (when (gnugo-get :waitingp) |
| 391 | (error "Not your turn yet -- please wait for \"\(%s to play\)\"" |
| 392 | (gnugo-get :user-color))) |
| 393 | (when (and (gnugo-get :game-over) in-progress-p) |
| 394 | (error "Sorry, game over"))) |
| 395 | |
| 396 | (defun gnugo-sentinel (proc string) |
| 397 | (let ((status (process-status proc))) |
| 398 | (when (or (eq status 'exit) |
| 399 | (eq status 'signal)) |
| 400 | (let ((buf (process-buffer proc))) |
| 401 | (when (buffer-live-p buf) |
| 402 | (with-current-buffer buf |
| 403 | (setq mode-line-process '( " [%s]")) |
| 404 | (when (eq proc (gnugo-get :proc)) |
| 405 | (gnugo-put :proc nil)))))))) |
| 406 | |
| 407 | (defun gnugo-send-line (line) |
| 408 | (process-send-string (gnugo-get :proc) (concat line "\n"))) |
| 409 | |
| 410 | (defun gnugo-synchronous-send/return (message) |
| 411 | "Return (TIME . STRING) where TIME is that returned by `current-time' and |
| 412 | STRING omits the two trailing newlines. See also `gnugo-query'." |
| 413 | (when (gnugo-get :waitingp) |
| 414 | (error "Sorry, still waiting for %s to play" (gnugo-get :gnugo-color))) |
| 415 | (gnugo-put :sync-return "") |
| 416 | (let ((proc (gnugo-get :proc))) |
| 417 | (set-process-filter |
| 418 | proc (lambda (proc string) |
| 419 | (let* ((so-far (gnugo-get :sync-return)) |
| 420 | (start (max 0 (- (length so-far) 2))) ; backtrack a little |
| 421 | (full (gnugo-put :sync-return (concat so-far string)))) |
| 422 | (when (string-match "\n\n" full start) |
| 423 | (gnugo-put :sync-return |
| 424 | (cons (current-time) (substring full 0 -2))))))) |
| 425 | (gnugo-send-line message) |
| 426 | (let (rv) |
| 427 | ;; type change => break |
| 428 | (while (stringp (setq rv (gnugo-get :sync-return))) |
| 429 | (accept-process-output proc)) |
| 430 | (gnugo-put :sync-return "") |
| 431 | rv))) |
| 432 | |
| 433 | (defun gnugo-query (message-format &rest args) |
| 434 | "Return cleaned-up value of a call to `gnugo-synchronous-send/return', q.v. |
| 435 | The TIME portion is omitted as well as the first two characters of the STRING |
| 436 | portion (corresponding to the status indicator in the Go Text Protocol). Use |
| 437 | this function when you are sure the command cannot fail. The first arg is |
| 438 | a format string applied to the rest of the args." |
| 439 | (substring (cdr (gnugo-synchronous-send/return |
| 440 | (apply 'format message-format args))) |
| 441 | 2)) |
| 442 | |
| 443 | (defun gnugo-goto-pos (pos) |
| 444 | "Move point to board position POS, a letter-number string." |
| 445 | (unless (string= pos "PASS") |
| 446 | (goto-char (point-min)) |
| 447 | (forward-line (- (+ 2 (gnugo-get :board-size)) |
| 448 | (string-to-number (substring pos 1)))) |
| 449 | (forward-char 2) |
| 450 | (forward-char (+ (if (= 32 (following-char)) 1 2) |
| 451 | (* 2 (- (let ((letter (aref pos 0))) |
| 452 | (if (> ?I letter) |
| 453 | letter |
| 454 | (1- letter))) |
| 455 | ?A)))))) |
| 456 | |
| 457 | (defun gnugo-f (frag) |
| 458 | (intern (format ":gnugo-%s%s-props" (gnugo-get :diamond) frag))) |
| 459 | |
| 460 | (defun gnugo-yang (c) |
| 461 | (case c |
| 462 | (?+ 'hoshi) |
| 463 | (?. 'empty) |
| 464 | (?X '(bmoku . bpmoku)) |
| 465 | (?O '(wmoku . wpmoku)) |
| 466 | (t (error "badness")))) |
| 467 | |
| 468 | (defun gnugo-yy (yin yang &optional momentaryp) |
| 469 | (gnugo-f (format "%d-%s" |
| 470 | yin (cond ((and (consp yang) momentaryp) (cdr yang)) |
| 471 | ((consp yang) (car yang)) |
| 472 | (t yang))))) |
| 473 | |
| 474 | (defun gnugo-toggle-image-display () |
| 475 | (unless (and (fboundp 'display-images-p) (display-images-p)) |
| 476 | (error "Display does not support images, sorry")) |
| 477 | (require 'gnugo-xpms) |
| 478 | (unless (and (boundp 'gnugo-xpms) gnugo-xpms) |
| 479 | (error "Could not load `gnugo-xpms', sorry")) |
| 480 | (let ((fresh (or (gnugo-get :local-xpms) gnugo-xpms))) |
| 481 | (unless (eq fresh (gnugo-get :xpms)) |
| 482 | (gnugo-put :xpms fresh) |
| 483 | (gnugo-put :all-yy nil))) |
| 484 | (let* ((new (not (gnugo-get :display-using-images))) |
| 485 | (act (if new 'display 'do-not-display))) |
| 486 | (mapc (lambda (yy) |
| 487 | (setcar (symbol-plist yy) act)) |
| 488 | (or (gnugo-get :all-yy) |
| 489 | (gnugo-put :all-yy |
| 490 | (prog1 (mapcar (lambda (ent) |
| 491 | (let* ((k (car ent)) |
| 492 | (yy (gnugo-yy (cdr k) (car k)))) |
| 493 | (setplist yy `(not-yet ,(cdr ent))) |
| 494 | yy)) |
| 495 | (gnugo-get :xpms)) |
| 496 | (let ((imul (image-size (get (gnugo-yy 5 (gnugo-yang ?+)) |
| 497 | 'not-yet)))) |
| 498 | (gnugo-put :w-imul (car imul)) |
| 499 | (gnugo-put :h-imul (cdr imul))))))) |
| 500 | (setplist (gnugo-f 'ispc) (and new |
| 501 | ;; `(display (space :width 0))' |
| 502 | ;; works as well, for newer emacs |
| 503 | '(invisible t))) |
| 504 | (setplist (gnugo-f 'jspc) |
| 505 | (and new `(display (space :width ,(- (gnugo-get :w-imul) 1))))) |
| 506 | (gnugo-put :highlight-last-move-spec |
| 507 | (if new |
| 508 | '((lambda (p) |
| 509 | (get (gnugo-yy (get-text-property p 'gnugo-yin) |
| 510 | (get-text-property p 'gnugo-yang) |
| 511 | t) |
| 512 | 'display)) |
| 513 | 0 delete-overlay) |
| 514 | (gnugo-get :default-highlight-last-move-spec))) |
| 515 | ;; a kludge to be reworked another time perhaps by another gnugo.el lover |
| 516 | (dolist (group (cdr (assq 'dead (gnugo-get :game-over)))) |
| 517 | (mapc 'delete-overlay (cdar group)) |
| 518 | (setcdr (car group) nil)) |
| 519 | (gnugo-put :wmul (if new (gnugo-get :w-imul) 1)) |
| 520 | (gnugo-put :hmul (if new (gnugo-get :h-imul) 1)) |
| 521 | (gnugo-put :display-using-images new))) |
| 522 | |
| 523 | (defun gnugo-toggle-grid () |
| 524 | "Turn the grid around the board on or off." |
| 525 | (interactive) |
| 526 | (gnugo-put :show-grid (not (gnugo-get :show-grid))) |
| 527 | (gnugo-refresh t)) |
| 528 | |
| 529 | (defun gnugo-propertize-grid-line (size) |
| 530 | (put-text-property (point) (+ 1 (point)) |
| 531 | 'category (gnugo-f 'lpad)) |
| 532 | (do ((p (+ 4 (point)) (+ 2 p)) (ival 'even (if (eq 'even ival) 'odd 'even))) |
| 533 | ((< (+ (* 2 size) 3 (point)) p)) |
| 534 | (add-text-properties p (1+ p) |
| 535 | `(gnugo-yin |
| 536 | ,5 |
| 537 | gnugo-yang |
| 538 | ,'empty |
| 539 | front-sticky |
| 540 | (gnugo-position gnugo-yin))) |
| 541 | (add-text-properties (- p 1) p |
| 542 | `(category |
| 543 | ,(gnugo-f 'jspc) |
| 544 | rear-nonsticky |
| 545 | t)) |
| 546 | (put-text-property (- p 2) p 'intangible ival))) |
| 547 | |
| 548 | (defun gnugo-propertize-board-buffer () |
| 549 | (erase-buffer) |
| 550 | (insert (substring (cdr (gnugo-synchronous-send/return "showboard")) 3)) |
| 551 | (let* ((size (gnugo-get :board-size)) |
| 552 | (size-string (number-to-string size))) |
| 553 | (beginning-of-buffer) |
| 554 | (insert " \n") |
| 555 | (put-text-property (point-min) (+ 1 (point-min)) 'category (gnugo-f 'tpad)) |
| 556 | (insert " ") |
| 557 | (beginning-of-line) |
| 558 | (gnugo-propertize-grid-line size) |
| 559 | (forward-line 1) |
| 560 | (insert " ") |
| 561 | (beginning-of-line) |
| 562 | (while (looking-at "\\s-*\\([0-9]+\\)[ ]") |
| 563 | (let* ((row (match-string-no-properties 1)) |
| 564 | (edge (match-end 0)) |
| 565 | (other-edge (+ edge (* 2 size) -1)) |
| 566 | (top-p (string= size-string row)) |
| 567 | (bot-p (string= "1" row))) |
| 568 | (put-text-property (point) (1+ (point)) 'category (gnugo-f 'lpad)) |
| 569 | (do ((p edge (+ 2 p)) (ival 'even (if (eq 'even ival) 'odd 'even))) |
| 570 | ((< other-edge p)) |
| 571 | (let* ((position (format "%c%s" (aref [?A ?B ?C ?D ?E ?F ?G ?H |
| 572 | ?J ?K ?L ?M ?N ?O ?P |
| 573 | ?Q ?R ?S ?T] |
| 574 | (ash (- p edge) -1)) |
| 575 | row)) |
| 576 | (yin (let ((A-p (= edge p)) |
| 577 | (Z-p (= (1- other-edge) p))) |
| 578 | (cond ((and top-p A-p) 1) |
| 579 | ((and top-p Z-p) 3) |
| 580 | ((and bot-p A-p) 7) |
| 581 | ((and bot-p Z-p) 9) |
| 582 | (top-p 2) |
| 583 | (bot-p 8) |
| 584 | (A-p 4) |
| 585 | (Z-p 6) |
| 586 | (t 5)))) |
| 587 | (yang (gnugo-yang (char-after p)))) |
| 588 | (add-text-properties p (1+ p) |
| 589 | `(gnugo-position |
| 590 | ,position |
| 591 | gnugo-yin |
| 592 | ,yin |
| 593 | gnugo-yang |
| 594 | ,yang |
| 595 | category |
| 596 | ,(gnugo-yy yin yang) |
| 597 | front-sticky |
| 598 | (gnugo-position gnugo-yin)))) |
| 599 | (unless (= (1- other-edge) p) |
| 600 | (add-text-properties (1+ p) (+ 2 p) |
| 601 | `(category |
| 602 | ,(gnugo-f 'ispc) |
| 603 | rear-nonsticky |
| 604 | t)) |
| 605 | (put-text-property p (+ 2 p) 'intangible ival))) |
| 606 | (goto-char (+ other-edge (length row) 1)) |
| 607 | (when (looking-at "\\s-+\\(WH\\|BL\\).*capt.* \\([0-9]+\\).*$") |
| 608 | (kill-line)) |
| 609 | (unless (gnugo-get :show-grid) |
| 610 | (save-excursion |
| 611 | (put-text-property (line-beginning-position) |
| 612 | (+ 3 (line-beginning-position)) |
| 613 | 'invisible t) |
| 614 | (put-text-property (+ 3 (* 2 size) (line-beginning-position)) |
| 615 | (line-end-position) |
| 616 | 'invisible t) |
| 617 | (beginning-of-buffer) |
| 618 | (forward-line 1) |
| 619 | (put-text-property (point) (line-end-position) 'invisible t) |
| 620 | (end-of-buffer) |
| 621 | (put-text-property |
| 622 | (line-beginning-position) (point) 'invisible t))) |
| 623 | (end-of-line) |
| 624 | ;(put-text-property other-edge (point) 'category (gnugo-f 'rpad)) |
| 625 | (forward-char 1) |
| 626 | (insert " ") |
| 627 | (beginning-of-line))) |
| 628 | (gnugo-propertize-grid-line size))) |
| 629 | |
| 630 | (defun gnugo-merge-showboard-results () |
| 631 | (let ((aft (substring (cdr (gnugo-synchronous-send/return "showboard")) 3)) |
| 632 | (adj 1) ; string to buffer position adjustment |
| 633 | (sync "[0-9]+ stones$") |
| 634 | (bef (buffer-substring-no-properties (point-min) (point-max))) |
| 635 | (bef-start 0) (bef-idx 0) |
| 636 | (aft-start 0) (aft-idx 0) |
| 637 | aft-sync-backtrack mis inc cut new very-strange) |
| 638 | (while (numberp (setq mis (compare-strings bef bef-start nil |
| 639 | aft aft-start nil))) |
| 640 | (setq aft-sync-backtrack nil |
| 641 | inc (if (> 0 mis) |
| 642 | (- (+ 1 mis)) |
| 643 | (- mis 1)) |
| 644 | bef-idx (+ bef-start inc) |
| 645 | aft-idx (+ aft-start inc) |
| 646 | bef-start (if (eq bef-idx (string-match sync bef bef-idx)) |
| 647 | (match-end 0) |
| 648 | (1+ bef-idx)) |
| 649 | aft-start (if (and (eq aft-idx (string-match sync aft aft-idx)) |
| 650 | (let ((peek (1- aft-idx))) |
| 651 | (while (not (= 32 (aref aft peek))) |
| 652 | (setq peek (1- peek))) |
| 653 | (setq aft-sync-backtrack (1+ peek)))) |
| 654 | (match-end 0) |
| 655 | (1+ aft-idx)) |
| 656 | cut (+ bef-idx adj |
| 657 | (if aft-sync-backtrack |
| 658 | (- aft-sync-backtrack aft-idx) |
| 659 | 0))) |
| 660 | (goto-char cut) |
| 661 | (if aft-sync-backtrack |
| 662 | (let* ((asb aft-sync-backtrack) |
| 663 | (old-len (let ((look (1+ cut))) ; fields are weird |
| 664 | (- (field-end look) (field-beginning look)))) |
| 665 | (keep (text-properties-at cut))) |
| 666 | (setq new (substring aft asb (string-match " " aft asb))) |
| 667 | (gnugo-put (get-text-property cut 'field) new) |
| 668 | (delete-char old-len) |
| 669 | (insert (apply 'propertize new keep)) |
| 670 | (setq adj (+ adj (- (length new) old-len)))) |
| 671 | (setq new (aref aft aft-idx)) |
| 672 | (insert-and-inherit (char-to-string new)) |
| 673 | (let ((yin (get-text-property cut 'gnugo-yin)) |
| 674 | (yang (gnugo-yang new))) |
| 675 | (add-text-properties cut (1+ cut) |
| 676 | `(gnugo-yang |
| 677 | ,yang |
| 678 | category |
| 679 | ,(gnugo-yy yin yang)))) |
| 680 | (delete-char 1) |
| 681 | ;; do this last to avoid complications w/ font lock |
| 682 | ;; (this also means we cannot include `intangible' in `front-sticky') |
| 683 | (when (setq very-strange (get-text-property (1+ cut) 'intangible)) |
| 684 | (put-text-property cut (1+ cut) 'intangible very-strange)))))) |
| 685 | |
| 686 | (defun gnugo-sgf-to-gtp (cc) |
| 687 | "Convert board locations from the format used by sgf to the format used by gtp." |
| 688 | (interactive) |
| 689 | (if (string= "tt" cc) |
| 690 | "PASS" |
| 691 | (let ((col (aref cc 0))) |
| 692 | (format "%c%d" |
| 693 | (+ ?A (- (if (> ?i col) col (1+ col)) ?a)) |
| 694 | (- (gnugo-get :board-size) (- (aref cc 1) ?a)))))) |
| 695 | |
| 696 | (defun gnugo-gtp-to-sgf (value) |
| 697 | "Convert board locations from the format used by gtp to the format used by sgf." |
| 698 | (interactive) |
| 699 | (if (string= "PASS" value) |
| 700 | "tt" |
| 701 | (let* ((col (aref value 0)) |
| 702 | (one (+ ?a (- (if (< ?H col) (1- col) col) ?A))) |
| 703 | (two (+ ?a (- (gnugo-get :board-size) |
| 704 | (string-to-number (substring value 1)))))) |
| 705 | (format "%c%c" one two)))) |
| 706 | |
| 707 | (defun gnugo-move-history (&optional rsel) |
| 708 | "Determine and return the game's move history. |
| 709 | Optional arg RSEL controls side effects and return value. |
| 710 | If nil, display the history in the echo area as \"(N moves)\" |
| 711 | followed by the space-separated list of moves. When called |
| 712 | interactively with a prefix arg (i.e., RSEL is `(4)'), display |
| 713 | similarly, but prefix with the mover (either \"B:\" or \"W:\"). |
| 714 | If RSEL is the symbol `car' return the most-recent move; if |
| 715 | `cadr', the next-to-most-recent move. |
| 716 | |
| 717 | For all other values of RSEL, do nothing and return nil." |
| 718 | (interactive "P") |
| 719 | (let ((size (gnugo-get :board-size)) |
| 720 | col |
| 721 | (sgf (gnugo-get :sgf-tree)) |
| 722 | acc node mprop move) |
| 723 | (flet ((as-pos (cc) (if (string= "tt" cc) |
| 724 | "PASS" |
| 725 | (setq col (aref cc 0)) |
| 726 | (format "%c%d" |
| 727 | (+ ?A (- (if (> ?i col) col (1+ col)) ?a)) |
| 728 | (- size (- (aref cc 1) ?a))))) |
| 729 | (next (propp) (when (setq node (car sgf) |
| 730 | mprop (or (assq :B node) |
| 731 | (assq :W node)) |
| 732 | move (cdr mprop)) |
| 733 | (setq move (as-pos move) |
| 734 | sgf (cdr sgf)) |
| 735 | (push (if propp |
| 736 | (propertize move :by (case (car mprop) |
| 737 | (:B "black") |
| 738 | (:W "white"))) |
| 739 | move) |
| 740 | acc)))) |
| 741 | (cond |
| 742 | ((not rsel) |
| 743 | (while (next nil)) |
| 744 | (message "(%d moves) %s" |
| 745 | (length acc) |
| 746 | (mapconcat 'identity (nreverse acc) " "))) |
| 747 | ((equal '(4) rsel) |
| 748 | (while (next t)) |
| 749 | (message "(%d moves) %s" |
| 750 | (length acc) |
| 751 | (mapconcat (lambda (x) |
| 752 | (format "%s:%s" |
| 753 | (upcase |
| 754 | (substring |
| 755 | (get-text-property 0 :by x) |
| 756 | 0 1)) |
| 757 | x)) |
| 758 | (nreverse acc) " "))) |
| 759 | ((eq 'car rsel) |
| 760 | (car (next nil))) |
| 761 | ((eq 'cadr rsel) |
| 762 | (next nil) |
| 763 | (car (next nil))))))) |
| 764 | |
| 765 | (defun gnugo-note (property value &optional new mogrifyp) |
| 766 | (when mogrifyp |
| 767 | (setq value |
| 768 | ;; todo: write sgf.el; call to it here |
| 769 | (if (string= "PASS" value) |
| 770 | "tt" |
| 771 | (let* ((col (aref value 0)) |
| 772 | (one (+ ?a (- (if (< ?H col) (1- col) col) ?A))) |
| 773 | (two (+ ?a (- (gnugo-get :board-size) |
| 774 | (string-to-number (substring value 1)))))) |
| 775 | (format "%c%c" one two))))) |
| 776 | (let ((tree (gnugo-get :sgf-tree)) |
| 777 | (pair (cons property value))) |
| 778 | (gnugo-put :sgf-tree |
| 779 | (if new |
| 780 | (cons (list pair) tree) |
| 781 | (cons (cons pair (car tree)) (cdr tree)))))) |
| 782 | |
| 783 | (defun gnugo-push-move (userp move) |
| 784 | (let* ((color (gnugo-get (if userp :user-color :gnugo-color))) |
| 785 | (start (gnugo-get :waiting-start)) |
| 786 | (now (current-time)) |
| 787 | (resignp (string= "resign" move)) |
| 788 | (passp (string= "PASS" move)) |
| 789 | (head (gnugo-move-history 'car)) |
| 790 | (onep (and head (string= "PASS" head))) |
| 791 | (donep (or resignp (and onep passp)))) |
| 792 | ; (unless passp |
| 793 | ; (gnugo-merge-showboard-results)) |
| 794 | (gnugo-put :last-mover color) |
| 795 | (when userp |
| 796 | (gnugo-put :last-user-bpos (and (not passp) (not resignp) move))) |
| 797 | (gnugo-put :future-history nil) |
| 798 | (gnugo-note (if (string= "black" color) :B :W) move t (not resignp)) |
| 799 | (when resignp |
| 800 | (gnugo-note :EV "resignation")) |
| 801 | (when start |
| 802 | (gnugo-put :last-waiting (cadr (time-subtract now start)))) |
| 803 | (when donep |
| 804 | (gnugo-put :game-end-time now) |
| 805 | (gnugo-put :scoring-seed (logior (ash (logand (car now) 255) 16) |
| 806 | (cadr now))) |
| 807 | (gnugo-put :game-over |
| 808 | (if resignp |
| 809 | (flet ((ls (color) (mapcar |
| 810 | (lambda (x) |
| 811 | (cons (list color) |
| 812 | (split-string x))) |
| 813 | (split-string |
| 814 | (gnugo-query "worm_stones %s" |
| 815 | color) |
| 816 | "\n")))) |
| 817 | (let ((live (append (ls "black") (ls "white")))) |
| 818 | `((live ,@live) |
| 819 | (dead)))) |
| 820 | (let ((dd (gnugo-query "dragon_data")) |
| 821 | (start 0) mem color ent live dead) |
| 822 | (while (string-match "\\(.+\\):\n[^ ]+[ ]+\\(black\\|white\\)\n" |
| 823 | dd start) |
| 824 | (setq mem (match-string 1 dd) |
| 825 | color (match-string 2 dd) |
| 826 | start (match-end 0) |
| 827 | ent (cons (list color) |
| 828 | (sort (split-string |
| 829 | (gnugo-query "dragon_stones %s" mem)) |
| 830 | 'string<))) |
| 831 | (string-match "\nstatus[ ]+\\(\\(ALIVE\\)\\|[A-Z]+\\)\n" |
| 832 | dd start) |
| 833 | (if (match-string 2 dd) |
| 834 | (push ent live) |
| 835 | (push ent dead)) |
| 836 | (setq start (match-end 0))) |
| 837 | `((live ,@live) |
| 838 | (dead ,@dead)))))) |
| 839 | (gnugo-put :waiting-start (and (not donep) now)) |
| 840 | (gnugo-put :black-captures (gnugo-query "captures black")) |
| 841 | (gnugo-put :white-captures (gnugo-query "captures white")) |
| 842 | (gnugo-refresh t) |
| 843 | donep)) |
| 844 | |
| 845 | (defun gnugo-toggle-edit-mode () |
| 846 | "Toggle :edit-mode. When true, GNU Go is not called to generate moves." |
| 847 | (interactive) |
| 848 | (gnugo-put :edit-mode (not (gnugo-get :edit-mode))) |
| 849 | (if (gnugo-get :edit-mode) |
| 850 | (setq mode-name "Editing SGF File") |
| 851 | (setq mode-name "Playing GNU Go")) |
| 852 | (gnugo-refresh)) |
| 853 | |
| 854 | (defun gnugo-venerate (yin yang) |
| 855 | (let* ((fg-yy (gnugo-yy yin yang)) |
| 856 | (fg-disp (or (get fg-yy 'display) |
| 857 | (get fg-yy 'do-not-display))) |
| 858 | (fg-data (plist-get (cdr fg-disp) :data)) |
| 859 | (bg-yy (gnugo-yy yin (gnugo-yang ?.))) |
| 860 | (bg-disp (or (get bg-yy 'display) |
| 861 | (get bg-yy 'do-not-display))) |
| 862 | (bg-data (plist-get (cdr bg-disp) :data)) |
| 863 | (bop (lambda (s) |
| 864 | (let* ((start 0) |
| 865 | (ncolors |
| 866 | (when (string-match "\\([0-9]+\\)\\s-+[0-9]+\"," s) |
| 867 | (setq start (match-end 0)) |
| 868 | (string-to-number (match-string 1 s))))) |
| 869 | (while (and (<= 0 ncolors) (string-match ",\n" s start)) |
| 870 | (setq start (match-end 0) |
| 871 | ncolors (1- ncolors))) |
| 872 | (string-match "\"" s start) |
| 873 | (match-end 0)))) |
| 874 | (new (copy-sequence fg-data)) |
| 875 | (lx (length fg-data)) |
| 876 | (lb (length bg-data)) |
| 877 | (sx (funcall bop fg-data)) |
| 878 | (sb (funcall bop bg-data)) |
| 879 | (color-key (aref new sx))) ; blech, heuristic |
| 880 | (while (< sx lx) |
| 881 | (when (and (not (= color-key (aref new sx))) |
| 882 | (< 0 (random 4))) |
| 883 | (aset new sx (aref bg-data sb))) |
| 884 | (incf sx) |
| 885 | (incf sb)) |
| 886 | (create-image new 'xpm t :ascent 'center))) |
| 887 | |
| 888 | (defun gnugo-refresh (&optional nocache) |
| 889 | "Update GNU Go Board buffer display. |
| 890 | While a game is in progress, parenthesize the last-played stone (no parens |
| 891 | for pass). If the buffer is currently displayed in the selected window, |
| 892 | recenter the board (presuming there is extra space in the window). Update |
| 893 | the mode line. Lastly, move point to the last position played by the user, |
| 894 | if that move was not a pass. |
| 895 | |
| 896 | Prefix arg NOCACHE requests complete reconstruction of the display, which may |
| 897 | be slow. (This should normally be unnecessary; specify it only if the display |
| 898 | seems corrupted.) NOCACHE is silently ignored when GNU Go is thinking about |
| 899 | its move." |
| 900 | (interactive "P") |
| 901 | (when (and nocache (not (gnugo-get :waitingp))) |
| 902 | (gnugo-propertize-board-buffer)) |
| 903 | (let* ((last-mover (gnugo-get :last-mover)) |
| 904 | (other (gnugo-other last-mover)) |
| 905 | (move (gnugo-move-history 'car)) |
| 906 | (game-over (gnugo-get :game-over)) |
| 907 | window last) |
| 908 | ;; last move |
| 909 | (when move |
| 910 | (let ((l-ov (gnugo-get :lparen-ov)) |
| 911 | (r-ov (gnugo-get :rparen-ov))) |
| 912 | (if (member move '("PASS" "resign")) |
| 913 | (mapc 'delete-overlay (list l-ov r-ov)) |
| 914 | (gnugo-goto-pos move) |
| 915 | (let* ((p (point)) |
| 916 | (hspec (gnugo-get :highlight-last-move-spec)) |
| 917 | (display-value (nth 0 hspec)) |
| 918 | (l-offset (nth 1 hspec)) |
| 919 | (l-new-pos (+ p l-offset)) |
| 920 | (r-action (nth 2 hspec))) |
| 921 | (overlay-put l-ov 'display |
| 922 | (if (functionp display-value) |
| 923 | (funcall display-value p) |
| 924 | display-value)) |
| 925 | (move-overlay l-ov l-new-pos (1+ l-new-pos)) |
| 926 | (if r-action |
| 927 | (funcall r-action r-ov) |
| 928 | (move-overlay r-ov (+ l-new-pos 2) (+ l-new-pos 3))))))) |
| 929 | ;; buffer name |
| 930 | (rename-buffer (concat (gnugo-get :diamond) |
| 931 | (if game-over |
| 932 | (format "%s(game over)" |
| 933 | (if (string= move "resign") |
| 934 | (concat move "ation ") |
| 935 | "")) |
| 936 | (format "%s(%s to play)" |
| 937 | (if move (concat move " ") "") |
| 938 | other)))) |
| 939 | ;; pall of death |
| 940 | (when game-over |
| 941 | (let ((live (cdr (assq 'live game-over))) |
| 942 | (dead (cdr (assq 'dead game-over))) |
| 943 | p pall) |
| 944 | (unless (eq game-over (get-text-property 1 'game-over)) |
| 945 | (dolist (group (append live dead)) |
| 946 | (dolist (pos (cdr group)) |
| 947 | (gnugo-goto-pos pos) |
| 948 | (setq p (point)) |
| 949 | (put-text-property p (1+ p) 'group group))) |
| 950 | (put-text-property 1 2 'game-over game-over)) |
| 951 | (dolist (group live) |
| 952 | (when (setq pall (cdar group)) |
| 953 | (mapc 'delete-overlay pall) |
| 954 | (setcdr (car group) nil))) |
| 955 | (dolist (group dead) |
| 956 | (unless (cdar group) |
| 957 | (let (ov pall c (color (caar group))) |
| 958 | (setq c (if (string= "black" color) "x" "o")) |
| 959 | (dolist (pos (cdr group)) |
| 960 | (gnugo-goto-pos pos) |
| 961 | (setq p (point) ov (make-overlay p (1+ p))) |
| 962 | (overlay-put |
| 963 | ov 'display |
| 964 | (if (gnugo-get :display-using-images) |
| 965 | ;; respect the dead individually; it takes more time |
| 966 | ;; but that's not a problem (for them) |
| 967 | (gnugo-venerate (get-text-property p 'gnugo-yin) |
| 968 | (gnugo-yang (aref (upcase c) 0))) |
| 969 | (propertize c 'face 'font-lock-warning-face))) |
| 970 | (push ov pall)) |
| 971 | (setcdr (car group) pall)))))) |
| 972 | ;; window update |
| 973 | (when (setq window (get-buffer-window (current-buffer))) |
| 974 | (let* ((size (gnugo-get :board-size)) |
| 975 | (h (ash (- (window-height window) |
| 976 | (round (* size (gnugo-get :hmul))) |
| 977 | 1) |
| 978 | -5)) |
| 979 | (edges (window-edges window)) |
| 980 | (right-w-edge (nth 2 edges)) |
| 981 | (avail-width (- right-w-edge (nth 0 edges))) |
| 982 | (w (/ (- avail-width |
| 983 | (+ (* size (gnugo-get :wmul)) |
| 984 | (if (symbol-plist (gnugo-f 'ispc)) |
| 985 | 0 |
| 986 | (1- size))) |
| 987 | 8) |
| 988 | 2.0))) |
| 989 | (dolist (pair `((tpad . ,(if (and h (< 0 h)) |
| 990 | `(display ,(make-string h 10)) |
| 991 | '(invisible t))) |
| 992 | (lpad . ,(if (< 0 w) |
| 993 | `(display (space :align-to ,w)) |
| 994 | '(invisible t))) |
| 995 | (rpad . (display |
| 996 | (space :align-to ,(1- avail-width)))))) |
| 997 | (setplist (gnugo-f (car pair)) (cdr pair))))) |
| 998 | ;; mode line update |
| 999 | (let ((cur (gnugo-get :mode-line))) |
| 1000 | (unless (equal cur gnugo-mode-line) |
| 1001 | (setq cur gnugo-mode-line) |
| 1002 | (gnugo-put :mode-line cur) |
| 1003 | (gnugo-put :mode-line-form |
| 1004 | (cond ((stringp cur) |
| 1005 | (setq cur (copy-sequence cur)) |
| 1006 | (let (acc cut c) |
| 1007 | (while (setq cut (string-match "~[bwmnptu]" cur)) |
| 1008 | (aset cur cut ?%) |
| 1009 | (setq cut (1+ cut) c (aref cur cut)) |
| 1010 | (aset cur cut ?s) |
| 1011 | (push |
| 1012 | `(,(intern (format "squig-%c" c)) |
| 1013 | ,(case c |
| 1014 | (?b '(or (gnugo-get :black-captures) 0)) |
| 1015 | (?w '(or (gnugo-get :white-captures) 0)) |
| 1016 | (?m '(length (cdr (gnugo-get :sgf-tree)))) |
| 1017 | (?n '(length (gnugo-get :future-history))) |
| 1018 | (?p '(gnugo-other (gnugo-get :last-mover))) |
| 1019 | (?t '(let ((ws (gnugo-get :waiting-start))) |
| 1020 | (if ws |
| 1021 | (cadr (time-since ws)) |
| 1022 | "-"))) |
| 1023 | (?u '(or (gnugo-get :last-waiting) "-")))) |
| 1024 | acc)) |
| 1025 | `(let ,(delete-dups (copy-sequence acc)) |
| 1026 | (format ,cur ,@(reverse (mapcar 'car acc)))))) |
| 1027 | (t cur)))) |
| 1028 | (let ((form (gnugo-get :mode-line-form))) |
| 1029 | (setq mode-line-process |
| 1030 | (and form |
| 1031 | ;; this dynamicism is nice but excessive in its wantonness |
| 1032 | ;;- `(" [" (:eval ,form) "]") |
| 1033 | ;; this dynamicism is ok because the user triggers it |
| 1034 | (list (format " [%s]" (eval form)))))) |
| 1035 | (force-mode-line-update)) |
| 1036 | ;; last user move |
| 1037 | (when (setq last (gnugo-get :last-user-bpos)) |
| 1038 | (gnugo-goto-pos last)))) |
| 1039 | |
| 1040 | ;;;--------------------------------------------------------------------------- |
| 1041 | ;;; Game play actions |
| 1042 | |
| 1043 | (defun gnugo-get-move-insertion-filter (proc string) |
| 1044 | (with-current-buffer (process-buffer proc) |
| 1045 | (let* ((so-far (gnugo-get :get-move-string)) |
| 1046 | (full (gnugo-put :get-move-string (concat so-far string)))) |
| 1047 | (when (string-match "^= \\(.+\\)\n\n" full) |
| 1048 | (let ((pos-or-pass (match-string 1 full))) |
| 1049 | (gnugo-put :get-move-string nil) |
| 1050 | (gnugo-put :waitingp nil) |
| 1051 | (gnugo-push-move nil pos-or-pass) |
| 1052 | (let ((buf (current-buffer))) |
| 1053 | (let (inhibit-gnugo-refresh) |
| 1054 | (run-hooks 'gnugo-post-move-hook) |
| 1055 | (unless inhibit-gnugo-refresh |
| 1056 | (with-current-buffer buf |
| 1057 | (gnugo-refresh)))))))))) |
| 1058 | |
| 1059 | (defun gnugo-get-move (color) |
| 1060 | (gnugo-put :waitingp t) |
| 1061 | (set-process-filter (gnugo-get :proc) 'gnugo-get-move-insertion-filter) |
| 1062 | (gnugo-send-line (concat "genmove " color)) |
| 1063 | (accept-process-output)) |
| 1064 | |
| 1065 | (defun gnugo-cleanup () |
| 1066 | (when (gnugo-board-buffer-p) |
| 1067 | (unless (= 0 (buffer-size)) |
| 1068 | (message "Thank you for playing GNU Go.")) |
| 1069 | (mapc (lambda (sym) |
| 1070 | (setplist sym nil) ; "...is next to fordliness." --Huxley |
| 1071 | (unintern sym)) |
| 1072 | (append (gnugo-get :all-yy) |
| 1073 | (mapcar 'gnugo-f |
| 1074 | '(anim |
| 1075 | tpad |
| 1076 | lpad |
| 1077 | rpad |
| 1078 | ispc |
| 1079 | jspc)))) |
| 1080 | (setq gnugo-state nil))) |
| 1081 | |
| 1082 | (defun gnugo-position () |
| 1083 | (or (get-text-property (point) 'gnugo-position) |
| 1084 | (error "Not a proper position point"))) |
| 1085 | |
| 1086 | (defun gnugo-move () |
| 1087 | "Make a move on the GNU Go Board buffer. |
| 1088 | The position is computed from current point. |
| 1089 | Signal error if done out-of-turn or if game-over. |
| 1090 | To start a game try M-x gnugo." |
| 1091 | (interactive) |
| 1092 | (gnugo-gate t) |
| 1093 | (let* ((buf (current-buffer)) |
| 1094 | (pos (gnugo-position)) |
| 1095 | (move (format "play %s %s" (gnugo-get :user-color) pos)) |
| 1096 | (accept (cdr (gnugo-synchronous-send/return move)))) |
| 1097 | (unless (= ?= (aref accept 0)) |
| 1098 | (error accept)) |
| 1099 | (gnugo-push-move t pos) ; value always nil for non-pass move |
| 1100 | (let (inhibit-gnugo-refresh) |
| 1101 | (run-hooks 'gnugo-post-move-hook) |
| 1102 | (unless inhibit-gnugo-refresh |
| 1103 | (with-current-buffer buf |
| 1104 | (gnugo-refresh)))) |
| 1105 | (if (not (gnugo-get :edit-mode)) |
| 1106 | (with-current-buffer buf |
| 1107 | (gnugo-get-move (gnugo-get :gnugo-color))) |
| 1108 | (progn |
| 1109 | (gnugo-put :user-color (gnugo-other (gnugo-get :user-color))) |
| 1110 | (gnugo-put :gnugo-color (gnugo-other (gnugo-get :gnugo-color))))))) |
| 1111 | |
| 1112 | (defun gnugo-mouse-move (e) |
| 1113 | "Do `gnugo-move' at mouse location." |
| 1114 | (interactive "@e") |
| 1115 | (mouse-set-point e) |
| 1116 | (when (looking-at "[.+]") |
| 1117 | (gnugo-move))) |
| 1118 | |
| 1119 | (defun gnugo-pass () |
| 1120 | "Make a pass on the GNU Go Board buffer. |
| 1121 | Signal error if done out-of-turn or if game-over. |
| 1122 | To start a game try M-x gnugo." |
| 1123 | (interactive) |
| 1124 | (gnugo-gate t) |
| 1125 | (let ((accept (cdr (gnugo-synchronous-send/return |
| 1126 | (format "play %s PASS" (gnugo-get :user-color)))))) |
| 1127 | (unless (= ?= (aref accept 0)) |
| 1128 | (error accept))) |
| 1129 | (let ((donep (gnugo-push-move t "PASS")) |
| 1130 | (buf (current-buffer))) |
| 1131 | (let (inhibit-gnugo-refresh) |
| 1132 | (run-hooks 'gnugo-post-move-hook) |
| 1133 | (unless inhibit-gnugo-refresh |
| 1134 | (with-current-buffer buf |
| 1135 | (gnugo-refresh)))) |
| 1136 | (unless donep |
| 1137 | (with-current-buffer buf |
| 1138 | (gnugo-get-move (gnugo-get :gnugo-color)))))) |
| 1139 | |
| 1140 | (defun gnugo-mouse-pass (e) |
| 1141 | "Do `gnugo-pass' at mouse location." |
| 1142 | (interactive "@e") |
| 1143 | (mouse-set-point e) |
| 1144 | (gnugo-pass)) |
| 1145 | |
| 1146 | (defun gnugo-resign () |
| 1147 | (interactive) |
| 1148 | (gnugo-gate t) |
| 1149 | (if (not (y-or-n-p "Resign? ")) |
| 1150 | (message "(not resigning)") |
| 1151 | (gnugo-push-move t "resign") |
| 1152 | (gnugo-refresh))) |
| 1153 | |
| 1154 | (defun gnugo-animate-group (command) |
| 1155 | (message "Computing %s ..." command) |
| 1156 | (let ((stones (cdr (gnugo-synchronous-send/return |
| 1157 | (format "%s %s" command (gnugo-position)))))) |
| 1158 | (unless (= ?= (aref stones 0)) |
| 1159 | (error stones)) |
| 1160 | (setq stones (split-string (substring stones 1))) |
| 1161 | (message "Computing %s ... %s in group." command (length stones)) |
| 1162 | (setplist (gnugo-f 'anim) nil) |
| 1163 | (let* ((spec (let ((spec |
| 1164 | ;; `(split-string gnugo-animation-string "" t)' |
| 1165 | ;; works as well, for newer emacs versions |
| 1166 | (delete "" (split-string gnugo-animation-string "")))) |
| 1167 | (cond ((gnugo-get :display-using-images) |
| 1168 | (let* ((yin (get-text-property (point) 'gnugo-yin)) |
| 1169 | (yang (gnugo-yang (char-after))) |
| 1170 | (up (get (gnugo-yy yin yang t) 'display)) |
| 1171 | (dn (get (gnugo-yy yin yang) 'display)) |
| 1172 | flip-flop) |
| 1173 | (mapcar (lambda (c) |
| 1174 | (if (setq flip-flop (not flip-flop)) |
| 1175 | dn up)) |
| 1176 | (mapcar 'string-to-char spec)))) |
| 1177 | (t spec)))) |
| 1178 | (cell (list spec)) |
| 1179 | (ovs (save-excursion |
| 1180 | (mapcar (lambda (pos) |
| 1181 | (gnugo-goto-pos pos) |
| 1182 | (let* ((p (point)) |
| 1183 | (ov (make-overlay p (1+ p)))) |
| 1184 | (overlay-put ov 'category (gnugo-f 'anim)) |
| 1185 | (overlay-put ov 'priority most-positive-fixnum) |
| 1186 | ov)) |
| 1187 | stones)))) |
| 1188 | (setplist (gnugo-f 'anim) (cons 'display cell)) |
| 1189 | (while (and (cdr spec) ; let last linger lest levity lost |
| 1190 | (sit-for 0.08675309)) ; jenny jenny i got your number... |
| 1191 | (setcar cell (setq spec (cdr spec))) |
| 1192 | (set-buffer-modified-p t)) |
| 1193 | (sit-for 5) |
| 1194 | (mapc 'delete-overlay ovs) |
| 1195 | t))) |
| 1196 | |
| 1197 | (defun gnugo-display-group-data (command buffer-name) |
| 1198 | (message "Computing %s ..." command) |
| 1199 | (let ((data (cdr (gnugo-synchronous-send/return |
| 1200 | (format "%s %s" command (gnugo-position)))))) |
| 1201 | (switch-to-buffer buffer-name) |
| 1202 | (erase-buffer) |
| 1203 | (insert data)) |
| 1204 | (message "Computing %s ... done." command)) |
| 1205 | |
| 1206 | (defun gnugo-worm-stones () |
| 1207 | "In the GNU Go Board buffer, animate \"worm\" at current position. |
| 1208 | Signal error if done out-of-turn or if game-over. |
| 1209 | See variable `gnugo-animation-string' for customization." |
| 1210 | (interactive) |
| 1211 | (gnugo-gate) |
| 1212 | (gnugo-animate-group "worm_stones")) |
| 1213 | |
| 1214 | (defun gnugo-worm-data () |
| 1215 | "Display in another buffer data from \"worm\" at current position. |
| 1216 | Signal error if done out-of-turn or if game-over." |
| 1217 | (interactive) |
| 1218 | (gnugo-gate) |
| 1219 | (gnugo-display-group-data "worm_data" "*gnugo worm data*")) |
| 1220 | |
| 1221 | (defun gnugo-dragon-stones () |
| 1222 | "In the GNU Go Board buffer, animate \"dragon\" at current position. |
| 1223 | Signal error if done out-of-turn or if game-over. |
| 1224 | See variable `gnugo-animation-string' for customization." |
| 1225 | (interactive) |
| 1226 | (gnugo-gate) |
| 1227 | (gnugo-animate-group "dragon_stones")) |
| 1228 | |
| 1229 | (defun gnugo-dragon-data () |
| 1230 | "Display in another buffer data from \"dragon\" at current position. |
| 1231 | Signal error if done out-of-turn or if game-over." |
| 1232 | (interactive) |
| 1233 | (gnugo-gate) |
| 1234 | (gnugo-display-group-data "dragon_data" "*gnugo dragon data*")) |
| 1235 | |
| 1236 | (defun gnugo-toggle-dead-group () |
| 1237 | "In a GNU Go Board buffer, during game-over, toggle a group as dead. |
| 1238 | The group is selected from current position (point). Signal error if |
| 1239 | not in game-over or if there is no group at that position. |
| 1240 | |
| 1241 | In the context of GNU Go, a group is called a \"dragon\" and may be |
| 1242 | composed of more than one \"worm\" (set of directly-connected stones). |
| 1243 | It is unclear to the gnugo.el author whether or not GNU Go supports |
| 1244 | - considering worms as groups in their own right; and |
| 1245 | - toggling group aliveness via GTP. |
| 1246 | Due to these uncertainties, this command is only half complete; the |
| 1247 | changes you may see in Emacs are not propagated to the gnugo subprocess. |
| 1248 | Thus, GTP commands like `final_score' may give unexpected results. |
| 1249 | |
| 1250 | If you are able to expose via GTP `change_dragon_status' in utils.c, |
| 1251 | you may consider modifying the `gnugo-toggle-dead-group' source code |
| 1252 | to enable full functionality." |
| 1253 | (interactive) |
| 1254 | (let ((game-over (or (gnugo-get :game-over) |
| 1255 | (error "Sorry, game still in play"))) |
| 1256 | (group (or (get-text-property (point) 'group) |
| 1257 | (error "No stone at that position"))) |
| 1258 | (now (current-time))) |
| 1259 | (gnugo-put :scoring-seed (logior (ash (logand (car now) 255) 16) |
| 1260 | (cadr now))) |
| 1261 | (let ((live (assq 'live game-over)) |
| 1262 | (dead (assq 'dead game-over)) |
| 1263 | bef now) |
| 1264 | (if (memq group live) |
| 1265 | (setq bef live now dead) |
| 1266 | (setq bef dead now live)) |
| 1267 | (setcdr bef (delq group (cdr bef))) |
| 1268 | (setcdr now (cons group (cdr now))) |
| 1269 | ;; disabled permanently -- too wrong |
| 1270 | (when nil |
| 1271 | (flet ((populate (group) |
| 1272 | (let ((color (caar group))) |
| 1273 | (dolist (stone (cdr group)) |
| 1274 | (gnugo-query "play %s %s" color stone))))) |
| 1275 | (if (eq now live) |
| 1276 | (populate group) |
| 1277 | ;; drastic (and wrong -- clobbers capture info, etc) |
| 1278 | (gnugo-query "clear_board") |
| 1279 | (mapc 'populate (cdr live))))) |
| 1280 | ;; here is the desired interface (to be enabled Some Day) |
| 1281 | (when nil |
| 1282 | (gnugo-query "change_dragon_status %s %s" |
| 1283 | (cadr group) (if (eq now live) |
| 1284 | 'alive |
| 1285 | 'dead))))) |
| 1286 | (save-excursion |
| 1287 | (gnugo-refresh))) |
| 1288 | |
| 1289 | (defun gnugo-estimate-score () |
| 1290 | "Display estimated score of a game of GNU Go. |
| 1291 | Output includes number of stones on the board and number of stones |
| 1292 | captured by each player, and the estimate of who has the advantage (and |
| 1293 | by how many stones)." |
| 1294 | (interactive) |
| 1295 | (message "Est.score ...") |
| 1296 | (let ((black (length (split-string (gnugo-query "list_stones black")))) |
| 1297 | (white (length (split-string (gnugo-query "list_stones white")))) |
| 1298 | (black-captures (gnugo-query "captures black")) |
| 1299 | (white-captures (gnugo-query "captures white")) |
| 1300 | (est (gnugo-query "estimate_score"))) |
| 1301 | ;; might as well update this |
| 1302 | (gnugo-put :black-captures black-captures) |
| 1303 | (gnugo-put :white-captures white-captures) |
| 1304 | (message "Est.score ... B %s %s | W %s %s | %s" |
| 1305 | black black-captures white white-captures est))) |
| 1306 | |
| 1307 | (defun gnugo-write-sgf-file (filename) |
| 1308 | "Save the game history to FILENAME (even if unfinished). |
| 1309 | If FILENAME already exists, Emacs confirms that you wish to overwrite it." |
| 1310 | (interactive "FWrite game as SGF file: ") |
| 1311 | (when (and (file-exists-p filename) |
| 1312 | (not (y-or-n-p "File exists. Continue? "))) |
| 1313 | (error "Not writing %s" filename)) |
| 1314 | ;; todo: write sgf.el; call to it here |
| 1315 | (let ((bef-newline-appreciated '(:C :PB :PW :AB :AW)) |
| 1316 | (aft-newline-appreciated '(:C :B :AB :AW :W :PB :PW :SZ)) |
| 1317 | (sz (gnugo-get :board-size)) |
| 1318 | (tree (gnugo-get :sgf-tree)) |
| 1319 | newline-just-printed) |
| 1320 | (with-temp-buffer |
| 1321 | (insert "(") |
| 1322 | (dolist (node (reverse tree)) |
| 1323 | (insert ";") |
| 1324 | (dolist (prop (reverse node)) |
| 1325 | (let ((name (car prop)) |
| 1326 | (v (cdr prop))) |
| 1327 | (insert |
| 1328 | (if (and (memq name bef-newline-appreciated) |
| 1329 | (not newline-just-printed)) "\n" "") |
| 1330 | (substring (symbol-name name) 1) |
| 1331 | (if (not (memq name '(:AB :AW))) "[" "") |
| 1332 | (format "%s" v) |
| 1333 | (if (not (memq name '(:AB :AW))) "]" "") |
| 1334 | (if (or (memq name aft-newline-appreciated) |
| 1335 | (> (current-column) 60)) "\n" "")) |
| 1336 | (setq newline-just-printed |
| 1337 | (memq name aft-newline-appreciated))))) |
| 1338 | (insert ")\n") |
| 1339 | (write-file filename)))) |
| 1340 | |
| 1341 | (defun gnugo-warp-point () |
| 1342 | "Move the cursor to the next-to-last move." |
| 1343 | (interactive) |
| 1344 | (let ((moves (cdr (gnugo-get :sgf-tree)))) |
| 1345 | (if (memq (car (car (car moves))) '(:B :W)) |
| 1346 | (gnugo-goto-pos (gnugo-sgf-to-gtp (cdr (car (car moves)))))))) |
| 1347 | |
| 1348 | (defun gnugo-initialize-sgf-tree () |
| 1349 | "Start a new sgf tree" |
| 1350 | (gnugo-put :sgf-tree (list (list))) |
| 1351 | (let ((g-blackp (string= "black" (gnugo-get :gnugo-color))) |
| 1352 | (black-stones (split-string (gnugo-query "list_stones black") " ")) |
| 1353 | (white-stones (split-string (gnugo-query "list_stones white") " "))) |
| 1354 | (mapc (lambda (x) (apply 'gnugo-note x)) |
| 1355 | `((:GM 1) |
| 1356 | (:FF 4) ; hmm maybe better: 3 |
| 1357 | (:DT ,(format-time-string "%Y-%m-%d")) |
| 1358 | (:RU ,(gnugo-get :rules)) |
| 1359 | (:HA ,(gnugo-get :handicap)) |
| 1360 | (:SZ ,(gnugo-get :board-size)) |
| 1361 | (:KM ,(gnugo-get :komi)) |
| 1362 | (:AP ,(format "gnugo.el:%s" gnugo-version)) |
| 1363 | (,(if g-blackp :PW :PB) ,(user-full-name)) |
| 1364 | (,(if g-blackp :PB :PW) ,(concat "GNU Go " |
| 1365 | (gnugo-query "version"))))) |
| 1366 | (if black-stones |
| 1367 | (gnugo-note :AB |
| 1368 | (apply 'concat |
| 1369 | (mapcar |
| 1370 | (lambda (x) (format "[%s]" (gnugo-gtp-to-sgf x))) |
| 1371 | black-stones)))) |
| 1372 | (if white-stones |
| 1373 | (gnugo-note :AW |
| 1374 | (apply 'concat |
| 1375 | (mapcar |
| 1376 | (lambda (x) (format "[%s]" (gnugo-gtp-to-sgf x))) |
| 1377 | white-stones)))))) |
| 1378 | |
| 1379 | (defun gnugo-read-sgf-file (filename) |
| 1380 | "Load a game tree from FILENAME, a file in SGF format." |
| 1381 | (interactive "fSGF file to load: ") |
| 1382 | (gnugo-command (format "loadsgf %s 1" (expand-file-name filename))) |
| 1383 | (gnugo-put :board-size |
| 1384 | (string-to-number (gnugo-query "query_boardsize"))) |
| 1385 | (gnugo-put :handicap |
| 1386 | (string-to-number (gnugo-query "get_handicap"))) |
| 1387 | (gnugo-put :komi |
| 1388 | (string-to-number (gnugo-query "get_komi"))) |
| 1389 | (gnugo-put :future-history nil) |
| 1390 | (gnugo-initialize-sgf-tree) |
| 1391 | (gnugo-command (format "loadsgf %s" (expand-file-name filename))) |
| 1392 | (let* ((colorhistory |
| 1393 | (mapcar |
| 1394 | (lambda (x) (split-string x " ")) |
| 1395 | (split-string |
| 1396 | (cdr (gnugo-synchronous-send/return "move_history")) "[=\n]"))) |
| 1397 | (k (length colorhistory))) |
| 1398 | (unless (equal colorhistory '(nil)) ; empty move history gives this |
| 1399 | (gnugo-put :last-mover |
| 1400 | (car (car colorhistory))) |
| 1401 | (let ((half (ash (1+ (gnugo-get :board-size)) -1))) |
| 1402 | (gnugo-goto-pos (format "A%d" half)) |
| 1403 | (forward-char (* 2 (1- half))) |
| 1404 | (gnugo-put :last-user-bpos |
| 1405 | (gnugo-put :center-position |
| 1406 | (get-text-property (point) 'gnugo-position)))) |
| 1407 | (while (> k 0) |
| 1408 | (decf k) |
| 1409 | (gnugo-note (if (string= (car (nth k colorhistory)) "black") :B :W) |
| 1410 | (nth 1 (nth k colorhistory)) t t)))) |
| 1411 | (gnugo-refresh t) |
| 1412 | (gnugo-warp-point)) |
| 1413 | |
| 1414 | (defun gnugo-undo (&optional norefresh) |
| 1415 | "Undo one move. Interchange the colors of the two players." |
| 1416 | (interactive) |
| 1417 | (gnugo-gate) |
| 1418 | (unless (and (gnugo-get :game-over) ; engine should undo pass but not resign |
| 1419 | (not |
| 1420 | (string= "PASS" |
| 1421 | (nth 1 |
| 1422 | (split-string (gnugo-query "last_move") " "))))) |
| 1423 | (if (equal |
| 1424 | (car |
| 1425 | (split-string |
| 1426 | (cdr (gnugo-synchronous-send/return "undo")) " ")) "?") |
| 1427 | (error "cannot undo") |
| 1428 | (gnugo-put :future-history |
| 1429 | (cons (car (gnugo-get :sgf-tree)) (gnugo-get :future-history))))) |
| 1430 | (gnugo-put :sgf-tree (cdr (gnugo-get :sgf-tree))) |
| 1431 | (gnugo-put :user-color (gnugo-get :last-mover)) |
| 1432 | (gnugo-put :gnugo-color (gnugo-other (gnugo-get :last-mover))) |
| 1433 | (gnugo-put :last-mover (gnugo-get :gnugo-color)) |
| 1434 | (gnugo-put :game-over nil) |
| 1435 | ; (gnugo-merge-showboard-results) |
| 1436 | (unless norefresh |
| 1437 | (gnugo-refresh t) |
| 1438 | (gnugo-warp-point))) |
| 1439 | |
| 1440 | (defun gnugo-redo (&optional norefresh) |
| 1441 | "Redo one move from the undo-stack (future-history). |
| 1442 | Interchange the colors of the two players." |
| 1443 | (interactive) |
| 1444 | (gnugo-gate) |
| 1445 | (if (equal (gnugo-get :future-history) nil) |
| 1446 | (error "no more undone moves left to redo!")) |
| 1447 | (let* ((buf (current-buffer)) |
| 1448 | (pos (gnugo-sgf-to-gtp (cdr (car (car (gnugo-get :future-history)))))) |
| 1449 | (color (if (equal (car (car (car (gnugo-get :future-history)))) :B) |
| 1450 | "black" "white")) |
| 1451 | (move (format "play %s %s" color pos)) |
| 1452 | (accept (cdr (gnugo-synchronous-send/return move)))) |
| 1453 | (gnugo-note (if (string= "black" color) :B :W) pos t t) |
| 1454 | (gnugo-put :future-history (cdr (gnugo-get :future-history))) |
| 1455 | (gnugo-put :user-color (gnugo-other color)) |
| 1456 | (gnugo-put :gnugo-color color) |
| 1457 | (gnugo-put :last-mover color) |
| 1458 | ; (gnugo-merge-showboard-results) |
| 1459 | (unless norefresh |
| 1460 | (gnugo-refresh t) |
| 1461 | (gnugo-warp-point)))) |
| 1462 | |
| 1463 | (defun gnugo-redo-two-moves () |
| 1464 | "Redo a pair of moves (yours and GNU Go's). |
| 1465 | If two moves cannot be found, do nothing. (If there is |
| 1466 | exactly one move in the undo stack, you can still redo |
| 1467 | it using gnugo-redo.)" |
| 1468 | (interactive) |
| 1469 | (gnugo-gate) |
| 1470 | (if (cdr (gnugo-get :future-history)) |
| 1471 | (gnugo-redo) |
| 1472 | (error "can't redo two moves\n")) |
| 1473 | (gnugo-redo)) |
| 1474 | |
| 1475 | (defun gnugo-magic-undo (spec &optional noalt) |
| 1476 | "Undo moves on the GNU Go Board, based on SPEC, a string or number. |
| 1477 | If SPEC is a string in the form of a board position (e.g., \"T19\"), |
| 1478 | check that the position is occupied by a stone of the user's color, |
| 1479 | and if so, remove moves from the history until that position is clear. |
| 1480 | If SPEC is a positive number, remove exactly that many moves from the |
| 1481 | history, signaling an error if the history is exhausted before finishing. |
| 1482 | If SPEC is not recognized, signal \"bad spec\" error. |
| 1483 | |
| 1484 | Refresh the board for each move undone. If (in the case where SPEC is |
| 1485 | a number) after finishing, the color to play is not the user's color, |
| 1486 | schedule a move by GNU Go. |
| 1487 | |
| 1488 | After undoing the move(s), schedule a move by GNU Go if it is GNU Go's |
| 1489 | turn to play. Optional second arg NOALT non-nil inhibits this." |
| 1490 | (gnugo-gate) |
| 1491 | (let ((n 0) done ans) |
| 1492 | (cond ((and (numberp spec) (< 0 spec)) |
| 1493 | (setq n spec done (lambda () (= 0 n)))) |
| 1494 | ((string-match "^[a-z]" spec) |
| 1495 | (let ((pos (upcase spec))) |
| 1496 | (setq done `(lambda () |
| 1497 | (equal |
| 1498 | (gnugo-query ,(concat "color " pos)) "empty"))) |
| 1499 | (when (funcall done) |
| 1500 | (error "%s already clear" pos)) |
| 1501 | (let ((u (gnugo-get :user-color))) |
| 1502 | (when (= (save-excursion |
| 1503 | (gnugo-goto-pos pos) |
| 1504 | (char-after)) |
| 1505 | (if (string= "black" u) |
| 1506 | ?O |
| 1507 | ?X)) |
| 1508 | (error "%s not occupied by %s" pos u))))) |
| 1509 | (t (error "bad spec: %S" spec))) |
| 1510 | (while (not (funcall done)) |
| 1511 | (if (gnugo-get :game-over) |
| 1512 | (gnugo-put :game-over nil) |
| 1513 | (progn |
| 1514 | (setq ans (cdr (gnugo-synchronous-send/return "undo"))) |
| 1515 | (unless (= ?= (aref ans 0)) |
| 1516 | (gnugo-refresh t) |
| 1517 | (error ans)) |
| 1518 | (gnugo-put :future-history |
| 1519 | (cons (car (gnugo-get :sgf-tree)) (gnugo-get :future-history))))) |
| 1520 | (gnugo-put :sgf-tree (cdr (gnugo-get :sgf-tree))) |
| 1521 | (gnugo-put :last-mover (gnugo-other (gnugo-get :last-mover))) |
| 1522 | ; (gnugo-merge-showboard-results) ; all |
| 1523 | ; (gnugo-refresh t) ; this |
| 1524 | (decf n) ; is |
| 1525 | (sit-for 0))) ; eye candy |
| 1526 | (let* ((ulastp (string= (gnugo-get :last-mover) (gnugo-get :user-color))) |
| 1527 | |
| 1528 | (ubpos (gnugo-move-history (if ulastp 'car 'cadr)))) |
| 1529 | (gnugo-put :last-user-bpos (if (and ubpos (not (string= "PASS" ubpos))) |
| 1530 | ubpos |
| 1531 | (gnugo-get :center-position))) |
| 1532 | (gnugo-refresh t) |
| 1533 | (when (and ulastp (not noalt)) |
| 1534 | (gnugo-get-move (gnugo-get :gnugo-color))))) |
| 1535 | |
| 1536 | (defun gnugo-undo-one-move () |
| 1537 | "Undo exactly one move (perhaps GNU Go's, perhaps yours). |
| 1538 | Do not schedule a move by GNU Go even if it is GNU Go's turn to play. |
| 1539 | See also `gnugo-undo-two-moves'." |
| 1540 | (interactive) |
| 1541 | (gnugo-gate) |
| 1542 | (gnugo-magic-undo 1 t)) |
| 1543 | |
| 1544 | (defun gnugo-undo-two-moves () |
| 1545 | "Undo a pair of moves (GNU Go's and yours). |
| 1546 | However, if you are the last mover, undo only one move. |
| 1547 | Regardless, after undoing, it is your turn to play again." |
| 1548 | (interactive) |
| 1549 | (gnugo-gate) |
| 1550 | (gnugo-magic-undo (if (string= (gnugo-get :user-color) |
| 1551 | (gnugo-get :last-mover)) |
| 1552 | 1 |
| 1553 | 2))) |
| 1554 | |
| 1555 | (defun gnugo-jump-to-move (movenum) |
| 1556 | "Jump to move number MOVENUM." |
| 1557 | (interactive) |
| 1558 | (unless |
| 1559 | (and |
| 1560 | (>= movenum 0) |
| 1561 | (<= movenum (+ (length (cdr (gnugo-get :sgf-tree))) |
| 1562 | (length (gnugo-get :future-history))))) |
| 1563 | (error "invalid move number")) |
| 1564 | (while (not (= movenum (length (cdr (gnugo-get :sgf-tree))))) |
| 1565 | (if (< movenum (length (cdr (gnugo-get :sgf-tree)))) |
| 1566 | (gnugo-undo t) |
| 1567 | (gnugo-redo t))) |
| 1568 | (gnugo-refresh t) |
| 1569 | (gnugo-warp-point)) |
| 1570 | |
| 1571 | (defun gnugo-jump-to-beginning () |
| 1572 | "Jump to the beginning of the game." |
| 1573 | (interactive) |
| 1574 | (gnugo-jump-to-move 0)) |
| 1575 | |
| 1576 | (defun gnugo-jump-to-end () |
| 1577 | "Jump to the end of the game" |
| 1578 | (interactive) |
| 1579 | (gnugo-jump-to-move (+ (length (cdr (gnugo-get :sgf-tree))) |
| 1580 | (length (gnugo-get :future-history))))) |
| 1581 | |
| 1582 | (defun gnugo-get-regression-directory (filename) |
| 1583 | "Prompt the user for the regression directory." |
| 1584 | (interactive "fRegression directory: ") |
| 1585 | (setq gnugo-regression-directory (expand-file-name filename))) |
| 1586 | |
| 1587 | (defun gnugo-view-regression (test) |
| 1588 | "View one of the standard gnugo regressions. |
| 1589 | Enter the name of the test in the format filename:testnumber. |
| 1590 | The filename must be a file in the regression directory. The |
| 1591 | first time the function is run, you will be prompted for the |
| 1592 | path to that directory." |
| 1593 | (interactive "sTest: ") |
| 1594 | (let* ((file (car (split-string test ":"))) |
| 1595 | (testnumber (nth 1 (split-string test ":"))) |
| 1596 | (gnugo-buffer (current-buffer)) |
| 1597 | (file-already-open nil)) |
| 1598 | (unless gnugo-regression-directory |
| 1599 | (call-interactively 'gnugo-get-regression-directory)) |
| 1600 | (unless gnugo-regression-directory |
| 1601 | (error "directory not found")) |
| 1602 | (let ((filename |
| 1603 | (concat gnugo-regression-directory file ".tst"))) |
| 1604 | (if (find-buffer-visiting filename) |
| 1605 | (setq file-already-open t)) |
| 1606 | (find-file filename)) |
| 1607 | (beginning-of-buffer) |
| 1608 | (unless |
| 1609 | (re-search-forward (concat "^" testnumber " ") nil t) |
| 1610 | (unless file-already-open (kill-buffer (current-buffer))) |
| 1611 | (switch-to-buffer gnugo-buffer) |
| 1612 | (error "test not found")) |
| 1613 | (beginning-of-line) |
| 1614 | (let* ((second-line (buffer-substring |
| 1615 | (line-beginning-position) |
| 1616 | (line-end-position))) |
| 1617 | (third-line (progn |
| 1618 | (forward-line) |
| 1619 | (buffer-substring |
| 1620 | (line-beginning-position) |
| 1621 | (line-end-position)))) |
| 1622 | (first-line (progn (re-search-backward "loadsgf") |
| 1623 | (buffer-substring |
| 1624 | (line-beginning-position) |
| 1625 | (line-end-position)))) |
| 1626 | (first-line-split (split-string first-line))) |
| 1627 | ; don't close the file if the user was visiting it |
| 1628 | (unless file-already-open (kill-buffer (current-buffer))) |
| 1629 | (switch-to-buffer gnugo-buffer) |
| 1630 | (gnugo-read-sgf-file |
| 1631 | (concat gnugo-regression-directory (nth 1 first-line-split))) |
| 1632 | (if (> (length first-line-split) 2) |
| 1633 | (gnugo-jump-to-move (1- (string-to-number |
| 1634 | (nth 2 first-line-split))))) |
| 1635 | (setq mode-name "running test ...") |
| 1636 | (gnugo-put :show-grid t) |
| 1637 | (gnugo-refresh t) |
| 1638 | (end-of-buffer) |
| 1639 | (insert "\n\n ") |
| 1640 | (insert first-line) |
| 1641 | (insert "\n ") |
| 1642 | (insert (format "%s:%s" file second-line)) |
| 1643 | (insert "\n ") |
| 1644 | (insert third-line) |
| 1645 | (insert "\n ") |
| 1646 | (setq mode-name (format "%s" test)) |
| 1647 | (insert (cdr (gnugo-synchronous-send/return second-line)))))) |
| 1648 | |
| 1649 | (defun gnugo-display-final-score () |
| 1650 | "Display final score and other info in another buffer (when game over). |
| 1651 | If the game is still ongoing, Emacs asks if you wish to stop play (by |
| 1652 | making sure two \"pass\" moves are played consecutively, if necessary). |
| 1653 | This info is also added to the game tree. See `gnugo-write-sgf-file'." |
| 1654 | (interactive) |
| 1655 | (unless (or (gnugo-get :game-over) |
| 1656 | (and (not (gnugo-get :waitingp)) |
| 1657 | (y-or-n-p "Game still in play. Stop play now? "))) |
| 1658 | (error "Sorry, game still in play")) |
| 1659 | (unless (gnugo-get :game-over) |
| 1660 | (flet ((pass (userp) |
| 1661 | (message "Playing PASS for %s ..." |
| 1662 | (gnugo-get (if userp :user-color :gnugo-color))) |
| 1663 | (sit-for 1) |
| 1664 | (gnugo-push-move userp "PASS"))) |
| 1665 | (unless (pass t) |
| 1666 | (pass nil))) |
| 1667 | (gnugo-refresh) |
| 1668 | (sit-for 3)) |
| 1669 | (let ((b= " Black = ") |
| 1670 | (w= " White = ") |
| 1671 | (n1p (last (gnugo-get :sgf-tree))) |
| 1672 | (res (let* ((node (car (gnugo-get :sgf-tree))) |
| 1673 | (event (and node (cdr (assq :EV node))))) |
| 1674 | (and event (string= "resignation" event) |
| 1675 | (if (assq :B node) "black" "white")))) |
| 1676 | blurb result) |
| 1677 | (if res |
| 1678 | (setq blurb (list |
| 1679 | (format "%s wins.\n" |
| 1680 | (substring (if (= ?b (aref res 0)) w= b=) |
| 1681 | 3 8)) |
| 1682 | "The game is over.\n" |
| 1683 | (format "Resignation by %s.\n" res)) |
| 1684 | result (concat (upcase (substring (gnugo-other res) 0 1)) |
| 1685 | "+Resign")) |
| 1686 | (message "Computing final score ...") |
| 1687 | (let* ((live (cdr (assq 'live (gnugo-get :game-over)))) |
| 1688 | (dead (cdr (assq 'dead (gnugo-get :game-over)))) |
| 1689 | (seed (gnugo-get :scoring-seed)) |
| 1690 | (result (gnugo-query "final_score %d" seed)) |
| 1691 | (terr-q (format "final_status_list %%s_territory %d" seed)) |
| 1692 | (terr "territory") |
| 1693 | (capt "captures") |
| 1694 | (b-terr (length (split-string (gnugo-query terr-q "black")))) |
| 1695 | (w-terr (length (split-string (gnugo-query terr-q "white")))) |
| 1696 | (b-capt (string-to-number (gnugo-get :black-captures))) |
| 1697 | (w-capt (string-to-number (gnugo-get :white-captures))) |
| 1698 | (komi (gnugo-get :komi))) |
| 1699 | (setq blurb (list "The game is over. Final score:\n")) |
| 1700 | (cond ((string= "Chinese" (gnugo-get :rules)) |
| 1701 | (dolist (group live) |
| 1702 | (let ((count (length (cdr group)))) |
| 1703 | (if (string= "black" (caar group)) |
| 1704 | (setq b-terr (+ b-terr count)) |
| 1705 | (setq w-terr (+ w-terr count))))) |
| 1706 | (dolist (group dead) |
| 1707 | (let* ((color (caar group)) |
| 1708 | (count (length (cdr group)))) |
| 1709 | (if (string= "black" color) |
| 1710 | (setq w-terr (+ count w-terr)) |
| 1711 | (setq b-terr (+ count b-terr))))) |
| 1712 | (push (format "%s%d %s = %3.1f\n" b= b-terr terr b-terr) blurb) |
| 1713 | (push (format "%s%d %s + %3.1f %s = %3.1f\n" w= |
| 1714 | w-terr terr komi 'komi (+ w-terr komi)) |
| 1715 | blurb)) |
| 1716 | (t |
| 1717 | (dolist (group dead) |
| 1718 | (let* ((color (caar group)) |
| 1719 | (adjust (* 2 (length (cdr group))))) |
| 1720 | (if (string= "black" color) |
| 1721 | (setq w-terr (+ adjust w-terr)) |
| 1722 | (setq b-terr (+ adjust b-terr))))) |
| 1723 | (push (format "%s%d %s + %s %s = %3.1f\n" b= |
| 1724 | b-terr terr |
| 1725 | b-capt capt |
| 1726 | (+ b-terr b-capt)) |
| 1727 | blurb) |
| 1728 | (push (format "%s%d %s + %s %s + %3.1f %s = %3.1f\n" w= |
| 1729 | w-terr terr |
| 1730 | w-capt capt |
| 1731 | komi 'komi |
| 1732 | (+ w-terr w-capt komi)) |
| 1733 | blurb))) |
| 1734 | (push (if (string= "0" result) |
| 1735 | "The game is a draw.\n" |
| 1736 | (format "%s wins by %s.\n" |
| 1737 | (substring (if (= ?B (aref result 0)) b= w=) 3 8) |
| 1738 | (substring result 2))) |
| 1739 | blurb) |
| 1740 | (message "Computing final score ... done"))) |
| 1741 | ;; extra info |
| 1742 | (push "\n" blurb) |
| 1743 | (dolist (spec '(("Game start" . :game-start-time) |
| 1744 | (" end" . :game-end-time))) |
| 1745 | (push (format-time-string |
| 1746 | (concat (car spec) ": %Y-%m-%d %H:%M:%S %z\n") |
| 1747 | (gnugo-get (cdr spec))) |
| 1748 | blurb)) |
| 1749 | (setq blurb (apply 'concat (reverse blurb))) |
| 1750 | (unless (eq :RE (caaar n1p)) |
| 1751 | (gnugo-note :C blurb) |
| 1752 | (setcar n1p (append `((:RE . ,result) |
| 1753 | (:C . ,blurb)) |
| 1754 | (car n1p)))) |
| 1755 | (switch-to-buffer (format "%s*GNU Go Final Score*" |
| 1756 | (gnugo-get :diamond))) |
| 1757 | (when (= 0 (buffer-size)) |
| 1758 | (insert blurb)))) |
| 1759 | |
| 1760 | ;;;--------------------------------------------------------------------------- |
| 1761 | ;;; Command properties and gnugo-command |
| 1762 | |
| 1763 | ;; GTP commands entered by the user are never issued directly to GNU Go; |
| 1764 | ;; instead, their behavior and output are controlled by the property |
| 1765 | ;; `:gnugo-gtp-command-spec' hung off of each (interned/symbolic) command. |
| 1766 | ;; The value of this property is a sub-plist, w/ sub-properties as follows: |
| 1767 | ;; |
| 1768 | ;; :full -- completely interpret the command string; the value is a |
| 1769 | ;; func that takes the list of words derived from splitting the |
| 1770 | ;; command string (minus the command) and handles everything. |
| 1771 | ;; |
| 1772 | ;; :output -- either a keyword specifying the preferred output method: |
| 1773 | ;; :message -- show output in minibuffer |
| 1774 | ;; :discard -- sometimes you just don't care; |
| 1775 | ;; or a function that takes one arg, the output string, and |
| 1776 | ;; handles it completely. default is to switch to buffer |
| 1777 | ;; "*gnugo command output*" if the output has a newline, |
| 1778 | ;; otherwise use `message'. |
| 1779 | ;; |
| 1780 | ;; :post-hook -- normal hook run after output processing (at the very end). |
| 1781 | |
| 1782 | (defun gnugo-command (command) |
| 1783 | "Send the Go Text Protocol COMMAND (a string) to GNU Go. |
| 1784 | Output and Emacs behavior depend on which command is given (some |
| 1785 | commands are handled completely by Emacs w/o using the subprocess; |
| 1786 | some commands have their output displayed in specially prepared |
| 1787 | buffers or in the echo area; some commands are instrumented to do |
| 1788 | gnugo.el-specific housekeeping). |
| 1789 | |
| 1790 | For example, for the command \"help\", Emacs visits the |
| 1791 | GTP command reference info page. |
| 1792 | |
| 1793 | NOTE: At this time, GTP command handling specification is still |
| 1794 | incomplete. Thus, some commands WILL confuse gnugo.el." |
| 1795 | (interactive "sCommand: ") |
| 1796 | (if (string= "" command) |
| 1797 | (message "(no command given)") |
| 1798 | (let* ((split (split-string command)) |
| 1799 | (cmd (intern (car split))) |
| 1800 | (spec (get cmd :gnugo-gtp-command-spec)) |
| 1801 | (full (plist-get spec :full)) |
| 1802 | (last-message nil)) |
| 1803 | (if full |
| 1804 | (funcall full (cdr split)) |
| 1805 | (message "Doing %s ..." command) |
| 1806 | (let* ((ans (cdr (gnugo-synchronous-send/return command))) |
| 1807 | (where (plist-get spec :output))) |
| 1808 | (if (string-match "unknown.command" ans) |
| 1809 | (message ans) |
| 1810 | (cond ((functionp where) (funcall where ans)) |
| 1811 | ((eq :discard where) (message "")) |
| 1812 | ((or (eq :message where) |
| 1813 | (not (string-match "\n" ans))) |
| 1814 | (message ans)) |
| 1815 | (t (switch-to-buffer "*gnugo command output*") |
| 1816 | (erase-buffer) |
| 1817 | (insert ans) |
| 1818 | (message "Doing %s ... done." command))) |
| 1819 | (let ((hook |
| 1820 | ;; do not elide this binding; `run-hooks' needs it |
| 1821 | (plist-get spec :post-hook))) |
| 1822 | (run-hooks 'hook)))))))) |
| 1823 | |
| 1824 | ;;;--------------------------------------------------------------------------- |
| 1825 | ;;; Major mode for interacting with a GNU Go subprocess |
| 1826 | |
| 1827 | (put 'gnugo-board-mode 'mode-class 'special) |
| 1828 | (defun gnugo-board-mode () |
| 1829 | "Major mode for playing GNU Go. |
| 1830 | Entering this mode runs the normal hook `gnugo-board-mode-hook'. |
| 1831 | In this mode, keys do not self insert. You can get further help |
| 1832 | describing any particular function with `C-h f <function-name>', |
| 1833 | for example `C-h f gnugo-move'. |
| 1834 | Default keybindings: |
| 1835 | |
| 1836 | ? View this help. |
| 1837 | |
| 1838 | RET or SPC Run `gnugo-move'. |
| 1839 | |
| 1840 | q or Q Quit (the latter without confirmation). |
| 1841 | |
| 1842 | R Resign. |
| 1843 | |
| 1844 | u Run `gnugo-undo-two-moves'. |
| 1845 | |
| 1846 | r Redo two moves. |
| 1847 | |
| 1848 | U Pass to `gnugo-magic-undo' either the board position |
| 1849 | at point (if no prefix arg), or the prefix arg converted |
| 1850 | to a number. E.g., to undo 16 moves: `C-u C-u U' (see |
| 1851 | `universal-argument'); to undo 42 moves: `M-4 M-2 U'. |
| 1852 | |
| 1853 | f Scroll forward (redo one undone move); |
| 1854 | potentially switch colors. |
| 1855 | |
| 1856 | b Scroll backward (undo one move); potentially switch colors. |
| 1857 | |
| 1858 | < Go to the beginning of the game |
| 1859 | |
| 1860 | > Go to the end of the game |
| 1861 | |
| 1862 | j <n> RET Jump to move number <n> |
| 1863 | |
| 1864 | g toggle the grid on or off. |
| 1865 | |
| 1866 | C-l Run `gnugo-refresh' to redraw the board. |
| 1867 | |
| 1868 | _ or M-_ Bury the Board buffer (when the boss is near). |
| 1869 | |
| 1870 | P Run `gnugo-pass'. |
| 1871 | |
| 1872 | i Toggle display using XPM images (if supported). |
| 1873 | |
| 1874 | w Run `gnugo-worm-stones'. |
| 1875 | d Run `gnugo-dragon-stones'. |
| 1876 | |
| 1877 | W Run `gnugo-worm-data'. |
| 1878 | D Run `gnugo-dragon-data'. |
| 1879 | |
| 1880 | t Run `gnugo-toggle-dead-group'. |
| 1881 | |
| 1882 | ! Run `gnugo-estimate-score'. |
| 1883 | |
| 1884 | : or ; Run `gnugo-command' (for GTP commands to GNU Go). |
| 1885 | |
| 1886 | = Display board position under point (if valid). |
| 1887 | |
| 1888 | h Run `gnugo-move-history'. |
| 1889 | |
| 1890 | F Run `gnugo-display-final-score'. |
| 1891 | |
| 1892 | s Run `gnugo-write-sgf-file'. |
| 1893 | |
| 1894 | v Run `gnugo-view-regression'. |
| 1895 | or C-x C-w |
| 1896 | or C-x C-s |
| 1897 | |
| 1898 | l Run `gnugo-read-sgf-file'." |
| 1899 | (switch-to-buffer (generate-new-buffer "(Uninitialized GNU Go Board)")) |
| 1900 | (buffer-disable-undo) ; todo: undo undo undoing |
| 1901 | (kill-all-local-variables) |
| 1902 | (setq truncate-lines t) |
| 1903 | (use-local-map gnugo-board-mode-map) |
| 1904 | (set (make-local-variable 'font-lock-defaults) |
| 1905 | '(gnugo-font-lock-keywords t)) |
| 1906 | (setq major-mode 'gnugo-board-mode) |
| 1907 | (setq mode-name "Playing GNU Go") |
| 1908 | (add-hook 'kill-buffer-hook 'gnugo-cleanup nil t) |
| 1909 | (make-local-variable 'gnugo-state) |
| 1910 | (setq gnugo-state (make-hash-table :size (1- 42) :test 'eq)) |
| 1911 | (mapc (lambda (prop) |
| 1912 | (gnugo-put prop nil)) ; todo: separate display/game aspects; |
| 1913 | '(:game-over ; move latter to func `gnugo' |
| 1914 | :waitingp |
| 1915 | :last-waiting |
| 1916 | :black-captures |
| 1917 | :white-captures |
| 1918 | :mode-line |
| 1919 | :mode-line-form |
| 1920 | :edit-mode |
| 1921 | :display-using-images |
| 1922 | :show-grid |
| 1923 | :xpms |
| 1924 | :local-xpms |
| 1925 | :all-yy)) |
| 1926 | (let ((name (if (string-match "[ ]" gnugo-program) |
| 1927 | (let ((p (substring gnugo-program 0 (match-beginning 0))) |
| 1928 | (o (substring gnugo-program (match-end 0))) |
| 1929 | (h (or (car gnugo-option-history) ""))) |
| 1930 | (when (string-match "--mode" o) |
| 1931 | (error "Found \"--mode\" in `gnugo-program'")) |
| 1932 | (when (and o (< 0 (length o)) |
| 1933 | h (< 0 (length o)) |
| 1934 | (or (< (length h) (length o)) |
| 1935 | (not (string= (substring h 0 (length o)) |
| 1936 | o)))) |
| 1937 | (push (concat o " " h) gnugo-option-history)) |
| 1938 | p) |
| 1939 | gnugo-program)) |
| 1940 | (args (read-string "GNU Go options: " |
| 1941 | (car gnugo-option-history) |
| 1942 | 'gnugo-option-history)) |
| 1943 | pre) |
| 1944 | (mapc (lambda (x) |
| 1945 | (apply (lambda (prop default opt &optional rx) |
| 1946 | (gnugo-put prop |
| 1947 | (or (when (string-match opt args) |
| 1948 | (let ((start (match-end 0)) s) |
| 1949 | (string-match (or rx "[0-9.]+") args start) |
| 1950 | (setq s (match-string 0 args)) |
| 1951 | (if rx s (string-to-number s)))) |
| 1952 | default))) |
| 1953 | x)) |
| 1954 | '((:board-size 19 "--boardsize") |
| 1955 | (:user-color "black" "--color" "\\(black\\|white\\)") |
| 1956 | (:handicap 0 "--handicap") |
| 1957 | (:komi 0.0 "--komi") |
| 1958 | (:minus-l nil "\\([^-]\\|^\\)-l[ ]*" "[^ ]+") |
| 1959 | (:infile nil "--infile" "[ ]*[^ ]+"))) |
| 1960 | (gnugo-put :rules (if (string-match "--chinese-rules" args) |
| 1961 | "Chinese" |
| 1962 | "Japanese")) |
| 1963 | (let ((proc-args (split-string args))) |
| 1964 | (gnugo-put :proc-args proc-args) |
| 1965 | (gnugo-put :proc (apply 'start-process "gnugo" nil name |
| 1966 | "--mode" "gtp" "--quiet" |
| 1967 | proc-args))) |
| 1968 | (when (setq pre (or (gnugo-get :minus-l) (gnugo-get :infile))) |
| 1969 | (mapc (lambda (x) |
| 1970 | (apply (lambda (prop q) |
| 1971 | (gnugo-put prop (string-to-number (gnugo-query q)))) |
| 1972 | x)) |
| 1973 | '((:board-size "query_boardsize") |
| 1974 | (:komi "get_komi") |
| 1975 | (:handicap "get_handicap"))))) |
| 1976 | (remhash :minus-l gnugo-state) ; (ab)used as local var only |
| 1977 | (remhash :infile gnugo-state) ; likewise |
| 1978 | (gnugo-put :diamond (substring (process-name (gnugo-get :proc)) 5)) |
| 1979 | (gnugo-put :gnugo-color (gnugo-other (gnugo-get :user-color))) |
| 1980 | (gnugo-put :highlight-last-move-spec |
| 1981 | (gnugo-put :default-highlight-last-move-spec '("(" -1 nil))) |
| 1982 | (gnugo-put :lparen-ov (make-overlay 1 1)) |
| 1983 | (gnugo-put :rparen-ov (let ((ov (make-overlay 1 1))) |
| 1984 | (overlay-put ov 'display ")") |
| 1985 | ov)) |
| 1986 | (if (< 0 (gnugo-get :handicap)) |
| 1987 | (gnugo-query (format "fixed_handicap %d" (gnugo-get :handicap)))) |
| 1988 | (gnugo-initialize-sgf-tree) |
| 1989 | (set-process-sentinel (gnugo-get :proc) 'gnugo-sentinel) |
| 1990 | (set-process-buffer (gnugo-get :proc) (current-buffer)) |
| 1991 | (gnugo-put :waiting-start (current-time)) |
| 1992 | (gnugo-put :hmul 1) |
| 1993 | (gnugo-put :wmul 1) |
| 1994 | (run-hooks 'gnugo-board-mode-hook) |
| 1995 | (gnugo-refresh t)) |
| 1996 | |
| 1997 | ;;;--------------------------------------------------------------------------- |
| 1998 | ;;; Entry point |
| 1999 | |
| 2000 | ;;;###autoload |
| 2001 | (defun gnugo (&optional new-game) |
| 2002 | "Run gnugo in a buffer, or resume a game in progress. |
| 2003 | Prefix arg means skip the game-in-progress check and start a new |
| 2004 | game straight away. |
| 2005 | |
| 2006 | You are queried for additional command-line options (Emacs supplies |
| 2007 | \"--mode gtp --quiet\" automatically). Here is a list of options |
| 2008 | that gnugo.el understands and handles specially: |
| 2009 | |
| 2010 | --boardsize num Set the board size to use (5--19) |
| 2011 | --color <color> Choose your color ('black' or 'white') |
| 2012 | --handicap <num> Set the number of handicap stones (0--9) |
| 2013 | |
| 2014 | If there is already a game in progress you may resume it instead of |
| 2015 | starting a new one. See `gnugo-board-mode' documentation for more info." |
| 2016 | (interactive "P") |
| 2017 | (let* ((all (let (acc) |
| 2018 | (dolist (buf (buffer-list)) |
| 2019 | (when (gnugo-board-buffer-p buf) |
| 2020 | (push (cons (buffer-name buf) buf) acc))) |
| 2021 | acc)) |
| 2022 | (n (length all))) |
| 2023 | (if (and (not new-game) |
| 2024 | (< 0 n) |
| 2025 | (y-or-n-p (format "GNU Go game%s in progress, resume play? " |
| 2026 | (if (= 1 n) "" "s")))) |
| 2027 | ;; resume |
| 2028 | (switch-to-buffer |
| 2029 | (cdr (if (= 1 n) |
| 2030 | (car all) |
| 2031 | (let ((sel (completing-read "Which one? " all nil t))) |
| 2032 | (if (string= "" sel) |
| 2033 | (car all) |
| 2034 | (assoc sel all)))))) |
| 2035 | ;; set up a new board |
| 2036 | (gnugo-board-mode) |
| 2037 | (let ((half (ash (1+ (gnugo-get :board-size)) -1))) |
| 2038 | (gnugo-goto-pos (format "A%d" half)) |
| 2039 | (forward-char (* 2 (1- half))) |
| 2040 | (gnugo-put :last-user-bpos |
| 2041 | (gnugo-put :center-position |
| 2042 | (get-text-property (point) 'gnugo-position)))) |
| 2043 | ;; first move |
| 2044 | (if (and (fboundp 'display-images-p) (display-images-p)) |
| 2045 | (progn |
| 2046 | (gnugo-toggle-image-display) |
| 2047 | (gnugo-refresh t))) |
| 2048 | (gnugo-put :game-start-time (current-time)) |
| 2049 | (let ((g (gnugo-get :gnugo-color)) |
| 2050 | (n (gnugo-get :handicap)) |
| 2051 | (u (gnugo-get :user-color))) |
| 2052 | (gnugo-put :last-mover g) |
| 2053 | (when (or (and (string= "black" u) (< 1 n)) |
| 2054 | (and (string= "black" g) (< n 2))) |
| 2055 | (gnugo-put :last-mover u) |
| 2056 | (gnugo-refresh t) |
| 2057 | (gnugo-get-move g)))))) |
| 2058 | |
| 2059 | ;;;--------------------------------------------------------------------------- |
| 2060 | ;;; Load-time actions |
| 2061 | |
| 2062 | (unless gnugo-board-mode-map |
| 2063 | (setq gnugo-board-mode-map (make-sparse-keymap)) |
| 2064 | (suppress-keymap gnugo-board-mode-map) |
| 2065 | (mapcar (lambda (pair) |
| 2066 | (define-key gnugo-board-mode-map (car pair) (cdr pair))) |
| 2067 | '(("?" . describe-mode) |
| 2068 | ("\C-m" . gnugo-move) |
| 2069 | (" " . gnugo-move) |
| 2070 | ("P" . gnugo-pass) |
| 2071 | ("R" . gnugo-resign) |
| 2072 | ("q" . (lambda () (interactive) |
| 2073 | (if (or (gnugo-get :game-over) |
| 2074 | (y-or-n-p "Quit? ")) |
| 2075 | (kill-buffer nil) |
| 2076 | (message "(not quitting)")))) |
| 2077 | ("Q" . (lambda () (interactive) |
| 2078 | (kill-buffer nil))) |
| 2079 | ("U" . (lambda (x) (interactive "P") |
| 2080 | (gnugo-magic-undo |
| 2081 | (cond ((numberp x) x) |
| 2082 | ((consp x) (car x)) |
| 2083 | (t (gnugo-position)))))) |
| 2084 | ("u" . gnugo-undo-two-moves) |
| 2085 | ("r" . gnugo-redo-two-moves) |
| 2086 | ("f" . gnugo-redo) |
| 2087 | ("b" . gnugo-undo) |
| 2088 | ("j" . (lambda (x) (interactive "nJump to move number: ") |
| 2089 | (gnugo-jump-to-move x))) |
| 2090 | ("<" . gnugo-jump-to-beginning) |
| 2091 | (">" . gnugo-jump-to-end) |
| 2092 | ("\C-l" . gnugo-refresh) |
| 2093 | ("\M-_" . bury-buffer) |
| 2094 | ("_" . bury-buffer) |
| 2095 | ("h" . gnugo-move-history) |
| 2096 | ("i" . (lambda () (interactive) |
| 2097 | (gnugo-toggle-image-display) |
| 2098 | (save-excursion (gnugo-refresh)))) |
| 2099 | ("e" . gnugo-toggle-edit-mode) |
| 2100 | ("w" . gnugo-worm-stones) |
| 2101 | ("W" . gnugo-worm-data) |
| 2102 | ("d" . gnugo-dragon-stones) |
| 2103 | ("D" . gnugo-dragon-data) |
| 2104 | ("t" . gnugo-toggle-dead-group) |
| 2105 | ("g" . gnugo-toggle-grid) |
| 2106 | ("v" . gnugo-view-regression) |
| 2107 | ("!" . gnugo-estimate-score) |
| 2108 | (":" . gnugo-command) |
| 2109 | (";" . gnugo-command) |
| 2110 | ("=" . (lambda () (interactive) |
| 2111 | (message (gnugo-position)))) |
| 2112 | ("s" . gnugo-write-sgf-file) |
| 2113 | ("\C-x\C-s" . gnugo-write-sgf-file) |
| 2114 | ("\C-x\C-w" . gnugo-write-sgf-file) |
| 2115 | ("l" . gnugo-read-sgf-file) |
| 2116 | ("F" . gnugo-display-final-score) |
| 2117 | ;; mouse |
| 2118 | ([(down-mouse-1)] . gnugo-mouse-move) |
| 2119 | ([(down-mouse-3)] . gnugo-mouse-pass)))) |
| 2120 | |
| 2121 | (unless (get 'help :gnugo-gtp-command-spec) |
| 2122 | (flet ((sget (x) (get x :gnugo-gtp-command-spec)) |
| 2123 | (jam (cmd prop val) (put cmd :gnugo-gtp-command-spec |
| 2124 | (plist-put (sget cmd) prop val))) |
| 2125 | (add (cmd prop val) (jam cmd prop (let ((cur (plist-get |
| 2126 | (sget cmd) |
| 2127 | prop))) |
| 2128 | (append (delete val cur) |
| 2129 | (list val))))) |
| 2130 | (defgtp (x &rest props) (dolist (cmd (if (symbolp x) (list x) x)) |
| 2131 | (let ((ls props)) |
| 2132 | (while ls |
| 2133 | (funcall (if (eq :post-hook (car ls)) |
| 2134 | 'add |
| 2135 | 'jam) |
| 2136 | cmd (car ls) (cadr ls)) |
| 2137 | (setq ls (cddr ls))))))) |
| 2138 | |
| 2139 | (defgtp 'help :full |
| 2140 | (lambda (sel) |
| 2141 | (info "(gnugo)GTP command reference") |
| 2142 | (when sel (setq sel (intern (car sel)))) |
| 2143 | (let (buffer-read-only pad cur spec output found) |
| 2144 | (flet ((note (s) (insert pad "[NOTE: gnugo.el " s ".]\n"))) |
| 2145 | (goto-char (point-min)) |
| 2146 | (save-excursion |
| 2147 | (while (re-search-forward "^ *[*] \\([a-zA-Z_]+\\)\\(:.*\\)*\n" |
| 2148 | (point-max) t) |
| 2149 | (unless pad |
| 2150 | (setq pad (make-string (- (match-beginning 1) |
| 2151 | (match-beginning 0)) |
| 2152 | 32))) |
| 2153 | (when (plist-get |
| 2154 | (setq spec |
| 2155 | (get (setq cur (intern (match-string 1))) |
| 2156 | :gnugo-gtp-command-spec)) |
| 2157 | :full) |
| 2158 | (note "handles this command completely")) |
| 2159 | (when (setq output (plist-get spec :output)) |
| 2160 | (cond ((functionp output) |
| 2161 | (note "handles the output specially")) |
| 2162 | ((eq :discard output) |
| 2163 | (note "discards the output")) |
| 2164 | ((eq :message output) |
| 2165 | (note "displays the output in the echo area")))) |
| 2166 | (when (eq sel cur) |
| 2167 | (setq found (match-beginning 0)))))) |
| 2168 | (cond (found (goto-char found)) |
| 2169 | ((not sel)) |
| 2170 | (t (message "(no such command: %s)" sel)))))) |
| 2171 | |
| 2172 | (defgtp 'final_score :full |
| 2173 | (lambda (sel) (gnugo-display-final-score))) |
| 2174 | |
| 2175 | (defgtp '(boardsize |
| 2176 | clear_board |
| 2177 | fixed_handicap |
| 2178 | loadsgf) |
| 2179 | :output :discard |
| 2180 | :post-hook (lambda () |
| 2181 | (dolist (prop '(:game-over |
| 2182 | :last-mover)) |
| 2183 | (gnugo-put prop nil)) |
| 2184 | (flet ((n! (p q) (gnugo-put p |
| 2185 | (string-to-number |
| 2186 | (gnugo-query q))))) |
| 2187 | (n! :komi "get_komi") |
| 2188 | (n! :handicap "get_handicap") |
| 2189 | (n! :board-size "query_boardsize")) |
| 2190 | (gnugo-refresh t))) |
| 2191 | |
| 2192 | (defgtp 'loadsgf |
| 2193 | :output (lambda (ans) |
| 2194 | (unless (= ?= (aref ans 0)) |
| 2195 | (error ans)) |
| 2196 | (let* ((play (substring ans 2)) |
| 2197 | (wait (gnugo-other play)) |
| 2198 | (samep (string= (gnugo-get :user-color) play))) |
| 2199 | (unless samep |
| 2200 | (gnugo-put :gnugo-color wait) |
| 2201 | (gnugo-put :user-color play)) |
| 2202 | ;; fixme: re-init :sgf-tree here. |
| 2203 | (message "GNU Go %splays as %s, you as %s (%s)" |
| 2204 | (if samep "" "now ") |
| 2205 | wait play (if samep |
| 2206 | "as before" |
| 2207 | "NOTE: this is a switch!"))))) |
| 2208 | |
| 2209 | (defgtp '(undo gg-undo) :full |
| 2210 | (lambda (sel) (gnugo-magic-undo |
| 2211 | (let (n) |
| 2212 | (cond ((not sel) 1) |
| 2213 | ((< 0 (setq n (string-to-number (car sel)))) n) |
| 2214 | (t (car sel))))))))) |
| 2215 | |
| 2216 | (provide 'gnugo) |
| 2217 | |
| 2218 | ;;; ttn-sez: worth-compiling |
| 2219 | ;;; gnugo.el ends here |