projects / sgk-go / blame
? search:
summary | tags | clone url | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Updated README: Equal sign not required with `--mode` flag.
[sgk-go] / interface / gnugo.el
CommitLineData
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.
189Note that more than two dots in the value indicates \"pre-release\",
190or \"alpha\" or \"hackers-invited-all-else-beware\"; use at your own risk!
191The more dots the more courage/foolishness you must find to continue.
192See 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\".
199The value may also be in the form \"PROGRAM OPTIONS...\" in which case the
200the command `gnugo' will prefix OPTIONS in its default offering when it
201queries you for additional options. It is an error for \"--mode\" to appear
202in OPTIONS.
203
204For more information on GTP and GNU Go, feel free to visit:
205http://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.
215Hook functions can prevent the call to `gnugo-refresh' by evaluating:
216 (setq inhibit-gnugo-refresh t)
217Initially, when `run-hooks' is called, the current buffer is the GNU Go
218Board buffer of the game. Hook functions that switch buffers must take
219care 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.
237Specifically, the `gnugo-worm-stones' and `gnugo-dragon-stones' commands
238render the stones in their respective (computed) groups as the first
239character in the string, then the next, and so on until the string (and/or
240the 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.
244If a single string, the following special escape sequences are
245replaced 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
252The times are in seconds, or \"-\" if that information is not available.
253For ~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.
286Store the result in LIST and return it. LIST must be a proper list.
287Of several `equal' occurrences of an element in LIST, the first
288one 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.
298Return 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
313There are many properties, each named by a keyword, that record and control
314how gnugo.el manages each game. Each GNU Go Board buffer has its own set
315of properties, stored in the hash table `gnugo-state'. Here we document
316some of the more stable properties. You may wish to use them as part of
317a `gnugo-post-move-hook' function, for example. Be careful to preserve
318the current buffer as `gnugo-state' is made into a buffer-local variable.
319NOTE: In the following, \"see foo\" actually means \"see foo source or
320you 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
367If you browse the source you will see a form for extracting all the
368properties from `gnugo-state' (even those not documented here). As
369things 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
412STRING 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.
435The TIME portion is omitted as well as the first two characters of the STRING
436portion (corresponding to the status indicator in the Go Text Protocol). Use
437this function when you are sure the command cannot fail. The first arg is
438a 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.
709Optional arg RSEL controls side effects and return value.
710If nil, display the history in the echo area as \"(N moves)\"
711followed by the space-separated list of moves. When called
712interactively with a prefix arg (i.e., RSEL is `(4)'), display
713similarly, but prefix with the mover (either \"B:\" or \"W:\").
714If RSEL is the symbol `car' return the most-recent move; if
715`cadr', the next-to-most-recent move.
716
717For 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.
890While a game is in progress, parenthesize the last-played stone (no parens
891for pass). If the buffer is currently displayed in the selected window,
892recenter the board (presuming there is extra space in the window). Update
893the mode line. Lastly, move point to the last position played by the user,
894if that move was not a pass.
895
896Prefix arg NOCACHE requests complete reconstruction of the display, which may
897be slow. (This should normally be unnecessary; specify it only if the display
898seems corrupted.) NOCACHE is silently ignored when GNU Go is thinking about
899its 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.
1088The position is computed from current point.
1089Signal error if done out-of-turn or if game-over.
1090To 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.
1121Signal error if done out-of-turn or if game-over.
1122To 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.
1208Signal error if done out-of-turn or if game-over.
1209See 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.
1216Signal 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.
1223Signal error if done out-of-turn or if game-over.
1224See 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.
1231Signal 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.
1238The group is selected from current position (point). Signal error if
1239not in game-over or if there is no group at that position.
1240
1241In the context of GNU Go, a group is called a \"dragon\" and may be
1242composed of more than one \"worm\" (set of directly-connected stones).
1243It 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.
1246Due to these uncertainties, this command is only half complete; the
1247changes you may see in Emacs are not propagated to the gnugo subprocess.
1248Thus, GTP commands like `final_score' may give unexpected results.
1249
1250If you are able to expose via GTP `change_dragon_status' in utils.c,
1251you may consider modifying the `gnugo-toggle-dead-group' source code
1252to 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.
1291Output includes number of stones on the board and number of stones
1292captured by each player, and the estimate of who has the advantage (and
1293by 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).
1309If 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).
1465If two moves cannot be found, do nothing. (If there is
1466exactly one move in the undo stack, you can still redo
1467it 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.
1477If SPEC is a string in the form of a board position (e.g., \"T19\"),
1478check that the position is occupied by a stone of the user's color,
1479and if so, remove moves from the history until that position is clear.
1480If SPEC is a positive number, remove exactly that many moves from the
1481history, signaling an error if the history is exhausted before finishing.
1482If SPEC is not recognized, signal \"bad spec\" error.
1483
1484Refresh the board for each move undone. If (in the case where SPEC is
1485a number) after finishing, the color to play is not the user's color,
1486schedule a move by GNU Go.
1487
1488After undoing the move(s), schedule a move by GNU Go if it is GNU Go's
1489turn 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).
1538Do not schedule a move by GNU Go even if it is GNU Go's turn to play.
1539See 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).
1546However, if you are the last mover, undo only one move.
1547Regardless, 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).
1651If the game is still ongoing, Emacs asks if you wish to stop play (by
1652making sure two \"pass\" moves are played consecutively, if necessary).
1653This 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.
1784Output and Emacs behavior depend on which command is given (some
1785commands are handled completely by Emacs w/o using the subprocess;
1786some commands have their output displayed in specially prepared
1787buffers or in the echo area; some commands are instrumented to do
1788gnugo.el-specific housekeeping).
1789
1790For example, for the command \"help\", Emacs visits the
1791GTP command reference info page.
1792
1793NOTE: 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.
1830Entering this mode runs the normal hook `gnugo-board-mode-hook'.
1831In this mode, keys do not self insert. You can get further help
1832describing any particular function with `C-h f <function-name>',
1833for example `C-h f gnugo-move'.
1834Default 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.
2003Prefix arg means skip the game-in-progress check and start a new
2004game straight away.
2005
2006You are queried for additional command-line options (Emacs supplies
2007\"--mode gtp --quiet\" automatically). Here is a list of options
2008that 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
2014If there is already a game in progress you may resume it instead of
2015starting 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
Fork of GNU Go supporting Xeon Phi coprocessors (and other modifications).