Commit | Line | Data |
---|---|---|
7eeb782e AT |
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 |