Commit | Line | Data |
---|---|---|
7eeb782e AT |
1 | ;;; ID: $Id: gnugo.el,v 1.1.1.1 2008/12/21 18:47:58 bump Exp $ |
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 1999, 2000, 2001 by the Free Software Foundation. | |
7 | ;;; | |
8 | ;;; This program is free software; you can redistribute it and/ | |
9 | ;;; modify it under the terms of the GNU General Public License | |
10 | ;;; as published by the Free Software Foundation - version 3, | |
11 | ;;; or (at your option) any later version. | |
12 | ;;; | |
13 | ;;; This program is distributed in the hope that it will be | |
14 | ;;; useful, but WITHOUT ANY WARRANTY; without even the implied | |
15 | ;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR | |
16 | ;;; PURPOSE. See the GNU General Public License in file COPYIN | |
17 | ;;; for more details. | |
18 | ;;; | |
19 | ;;; You should have received a copy of the GNU General Public | |
20 | ;;; License along with this program; if not, write to the Free | |
21 | ;;; Software Foundation, Inc., 51 Franklin Street, Fifth Floor, | |
22 | ;;; Boston, MA 02111, USA. | |
23 | ||
24 | ;;; Description: Run GNU Go in a buffer. | |
25 | ||
26 | ;;; Commentary: | |
27 | ||
28 | ;; This is an interface to GNU Go using the Go Text Protocol. Interaction | |
29 | ;; with the gnugo subprocess is synchronous except for `gnugo-get-move'. This | |
30 | ;; means you can use Emacs to do other things while gnugo is thinking about | |
31 | ;; its move. (Actually, all interaction with the subprocess is inhibited | |
32 | ;; during thinking time -- really, trying to distract your opponent is poor | |
33 | ;; sportsmanship. :-) | |
34 | ;; | |
35 | ;; Customization is presently limited to `gnugo-animation-string', q.v. | |
36 | ;; | |
37 | ;; This code was tested with Emacs 20.7 on a monochrome 80x24 terminal. | |
38 | ||
39 | ;;; Code: | |
40 | ||
41 | (require 'cl) ; use the source luke! | |
42 | ||
43 | ;;;--------------------------------------------------------------------------- | |
44 | ;;; Variables | |
45 | ||
46 | (defvar gnugo-board-mode-map nil | |
47 | "Keymap for GNU Go Board mode.") | |
48 | ||
49 | (defvar gnugo-option-history nil | |
50 | "History of additional GNU Go command-line options.") | |
51 | ||
52 | (defvar gnugo-animation-string | |
53 | (let ((jam "*#") (blink " #") (spin "-\\|/") (yada "*-*!")) | |
54 | (concat jam jam jam jam jam | |
55 | ;; "SECRET MESSAGE HERE" | |
56 | blink blink blink blink blink blink blink blink | |
57 | ;; Playing go is like fighting ignorance: when you think you have | |
58 | ;; surrounded something by knowing it very well it often turns | |
59 | ;; out that in the time you spent deepening this understanding, | |
60 | ;; other areas of ignorance have surrounded you. | |
61 | spin spin spin spin spin spin spin spin spin | |
62 | ;; Playing go is not like fighting ignorance: what one person | |
63 | ;; knows many people may come to know; knowledge does not build | |
64 | ;; solely move by move. Wisdom, on the other hand... | |
65 | yada yada yada)) | |
66 | "*String whose individual characters are used for animation. | |
67 | Specifically, the `gnugo-worm-stones' and `gnugo-dragon-stones' commands | |
68 | render the stones in their respective (computed) groups as the first | |
69 | character in the string, then the next, and so on until the string (and/or | |
70 | the viewer) is exhausted.") | |
71 | ||
72 | ;;;--------------------------------------------------------------------------- | |
73 | ;;; Support functions | |
74 | ||
75 | (defun gnugo-other (color) | |
76 | (if (string= "black" color) "white" "black")) | |
77 | ||
78 | (defun gnugo-gate () | |
79 | (unless (eq (current-buffer) (get 'gnugo 'bbuf)) | |
80 | (error "Wrong buffer -- try M-x gnugo")) | |
81 | (when (eq 'waiting (get 'gnugo 'get-move-state)) | |
82 | (error "Not your turn yet -- please wait")) | |
83 | (when (eq 'game-over (get 'gnugo 'last-move)) | |
84 | (error "Sorry, game over"))) | |
85 | ||
86 | (defun gnugo-sentinel (proc string) | |
87 | (let ((status (process-status proc))) | |
88 | (when (or (eq status 'exit) | |
89 | (eq status 'signal)) | |
90 | (switch-to-buffer (get 'gnugo 'bbuf)) | |
91 | (delete-other-windows) | |
92 | (delete-process proc) | |
93 | (put 'gnugo 'proc nil)))) | |
94 | ||
95 | (defun gnugo-send-line (line) | |
96 | (process-send-string (get 'gnugo 'proc) (concat line "\n"))) | |
97 | ||
98 | (defun gnugo-synchronous-send/return (message) | |
99 | "Return (TIME . STRING) where TIME is that returned by `current-time' and | |
100 | STRING omits the two trailing newlines. See also `gnugo-query'." | |
101 | (when (eq 'waiting (get 'gnugo 'get-move-state)) | |
102 | (error "sorry, still waiting for %s to play" (get 'gnugo 'gnugo-color))) | |
103 | (put 'gnugo 'sync-return "") | |
104 | (let ((proc (get 'gnugo 'proc))) | |
105 | (set-process-filter | |
106 | proc #'(lambda (proc string) | |
107 | (let* ((so-far (get 'gnugo 'sync-return)) | |
108 | (start (max 0 (- (length so-far) 2))) ; backtrack a little | |
109 | (full (put 'gnugo 'sync-return (concat so-far string)))) | |
110 | (when (string-match "\n\n" full start) | |
111 | (put 'gnugo 'sync-return | |
112 | (cons (current-time) (substring full 0 -2))))))) | |
113 | (gnugo-send-line message) | |
114 | (let (rv) | |
115 | ;; type change => break | |
116 | (while (stringp (setq rv (get 'gnugo 'sync-return))) | |
117 | (accept-process-output proc)) | |
118 | (put 'gnugo 'sync-return "") | |
119 | rv))) | |
120 | ||
121 | (defun gnugo-query (message) | |
122 | "Return cleaned-up value of a call to `gnugo-synchronous-send/return', q.v. | |
123 | The TIME portion is omitted as well as the first two characters of the STRING | |
124 | portion (corresponding to the status indicator in the Go Text Protocol). Use | |
125 | this function when you are sure the command cannot fail." | |
126 | (substring (cdr (gnugo-synchronous-send/return message)) 2)) | |
127 | ||
128 | (defun gnugo-goto-pos (pos) | |
129 | "Move point to board position POS, a letter-number string." | |
130 | (goto-char (point-min)) | |
131 | (search-forward (substring pos 0 1)) | |
132 | (let ((col (1- (current-column)))) | |
133 | (re-search-forward (concat "^\\s-*" (substring pos 1) "\\s-")) | |
134 | (move-to-column col))) | |
135 | ||
136 | ;;;--------------------------------------------------------------------------- | |
137 | ;;; Game play actions | |
138 | ||
139 | (defun gnugo-showboard () | |
140 | (interactive) | |
141 | (let ((board (cdr (gnugo-synchronous-send/return "showboard"))) | |
142 | white-captures black-captures) | |
143 | (with-current-buffer (get 'gnugo 'bbuf) | |
144 | (delete-region (point-min) (point-max)) | |
145 | (insert (substring board 3)) ; omit "= \n" | |
146 | (goto-char (point-min)) | |
147 | (while (re-search-forward "\\s-*\\(WH\\|BL\\).*capt.*\\([0-9]+\\).*$" | |
148 | (point-max) t) | |
149 | (if (string= "WH" (match-string 1)) | |
150 | (setq white-captures (match-string 2)) | |
151 | (setq black-captures (match-string 2))) | |
152 | (replace-match "")) | |
153 | (goto-char (point-max)) | |
154 | (move-to-column-force (get 'gnugo 'board-cols)) | |
155 | (delete-region (point) (point-max)) | |
156 | (let (pos) | |
157 | (insert | |
158 | (case (get 'gnugo 'last-move) | |
159 | ((nil) "(black to play)") | |
160 | ((game-over) "(t toggle, ! score, q quit)") | |
161 | (t (let* ((last-move (get 'gnugo 'last-move)) | |
162 | (color (car last-move)) | |
163 | (move (cdr last-move))) | |
164 | (setq pos (and (not (string= "PASS" move)) move)) | |
165 | (format "%s: %s (%s to play)\n%scaptures: black %s white %s" | |
166 | color move (gnugo-other color) | |
167 | (make-string (get 'gnugo 'board-cols) 32) ; space | |
168 | black-captures white-captures))))) | |
169 | (when pos | |
170 | (gnugo-goto-pos pos) | |
171 | (delete-char -1) (insert "(") | |
172 | (forward-char 1) (delete-char 1) (insert ")"))) | |
173 | (goto-char (get 'gnugo 'last))))) | |
174 | ||
175 | (defun gnugo-get-move-insertion-filter (proc string) | |
176 | (let* ((so-far (get 'gnugo 'get-move-string)) | |
177 | (full (put 'gnugo 'get-move-string (concat so-far string)))) | |
178 | (when (string-match "^= \\(.+\\)\n\n" full) | |
179 | (let ((pos (match-string 1 full))) | |
180 | (put 'gnugo 'get-move-string nil) | |
181 | (put 'gnugo 'get-move-state nil) | |
182 | (put 'gnugo 'last-move (cons (get 'gnugo 'gnugo-color) pos)) | |
183 | (gnugo-showboard) | |
184 | (put 'gnugo 'passes | |
185 | (if (string= "PASS" pos) | |
186 | (1+ (get 'gnugo 'passes)) | |
187 | 0)) | |
188 | (when (= 2 (get 'gnugo 'passes)) | |
189 | (put 'gnugo 'last-move 'game-over)))))) | |
190 | ||
191 | (defun gnugo-get-move (color) | |
192 | (put 'gnugo 'get-move-state 'waiting) | |
193 | (set-process-filter (get 'gnugo 'proc) 'gnugo-get-move-insertion-filter) | |
194 | (gnugo-send-line (concat "genmove " color)) | |
195 | (accept-process-output)) | |
196 | ||
197 | (defun gnugo-cleanup (&optional quietly) | |
198 | "Kill gnugo process and *gnugo board* buffer. Reset internal state." | |
199 | (interactive) | |
200 | (let ((proc (get 'gnugo 'proc))) | |
201 | (when proc | |
202 | (delete-process proc))) | |
203 | (let ((bbuf (get 'gnugo 'bbuf))) | |
204 | (when (and bbuf (get-buffer bbuf)) | |
205 | (kill-buffer bbuf))) | |
206 | (unless quietly | |
207 | (message "Thank you for playing GNU Go.")) | |
208 | (setplist 'gnugo nil)) | |
209 | ||
210 | (defun gnugo-position () | |
211 | (let* ((letter (ignore-errors | |
212 | (save-excursion | |
213 | (let ((col (current-column))) | |
214 | (re-search-forward "^\\s-+A B C") | |
215 | (move-to-column col) | |
216 | (buffer-substring (point) (1+ (point))))))) | |
217 | (number (save-excursion | |
218 | (beginning-of-line) | |
219 | (looking-at "\\s-*\\([0-9]+\\)") | |
220 | (match-string 1))) | |
221 | (pos (concat letter number))) | |
222 | (if (string-match "^[A-T][1-9][0-9]*$" pos) | |
223 | pos | |
224 | (error "Not a proper position point")))) | |
225 | ||
226 | (defun gnugo-move () | |
227 | "Make a move on the *gnugo board* buffer. | |
228 | The position is computed from current point. | |
229 | Signal error if done out-of-turn or if game-over. | |
230 | To start a game try M-x gnugo." | |
231 | (interactive) | |
232 | (gnugo-gate) | |
233 | (let* ((pos (gnugo-position)) | |
234 | (move (format "play %s %s" (get 'gnugo 'user-color) pos)) | |
235 | (accept (cdr (gnugo-synchronous-send/return move))) | |
236 | (status (substring accept 0 1))) | |
237 | (cond ((string= "=" status) | |
238 | (put 'gnugo 'last (point)) | |
239 | (put 'gnugo 'last-move (cons (get 'gnugo 'user-color) pos)) | |
240 | (put 'gnugo 'passes 0) | |
241 | (gnugo-showboard)) | |
242 | (t (error accept))) | |
243 | (gnugo-get-move (get 'gnugo 'gnugo-color)))) | |
244 | ||
245 | (defun gnugo-mouse-move (e) | |
246 | "Do `gnugo-move' at mouse location." | |
247 | (interactive "@e") | |
248 | (mouse-set-point e) | |
249 | (when (looking-at "[.+]") | |
250 | (gnugo-move))) | |
251 | ||
252 | (defun gnugo-pass () | |
253 | "Make a pass on the *gnugo board* buffer. | |
254 | Signal error if done out-of-turn or if game-over. | |
255 | To start a game try M-x gnugo." | |
256 | (interactive) | |
257 | (gnugo-gate) | |
258 | (let ((passes (1+ (get 'gnugo 'passes)))) | |
259 | (put 'gnugo 'passes passes) | |
260 | (put 'gnugo 'last-move | |
261 | (if (= 2 passes) | |
262 | 'game-over | |
263 | (cons (get 'gnugo 'user-color) "PASS"))) | |
264 | (gnugo-showboard) | |
265 | (unless (= 2 passes) | |
266 | (gnugo-get-move (get 'gnugo 'gnugo-color))))) | |
267 | ||
268 | (defun gnugo-mouse-pass (e) | |
269 | "Do `gnugo-pass' at mouse location." | |
270 | (interactive "@e") | |
271 | (mouse-set-point e) | |
272 | (gnugo-pass)) | |
273 | ||
274 | (defun gnugo-refresh () | |
275 | "Display *gnugo board* buffer and update it with the current board state. | |
276 | During normal play, parenthesize the last-played stone (no parens for pass), | |
277 | and display at bottom-right corner a message describing the last-played | |
278 | position, who played it (and who is to play), and the number of stones | |
279 | captured thus far by each player." | |
280 | (interactive) | |
281 | (switch-to-buffer (get 'gnugo 'bbuf)) | |
282 | (gnugo-showboard)) | |
283 | ||
284 | (defun gnugo-animate-group (command) | |
285 | (message "Computing %s ..." command) | |
286 | (let ((stones (cdr (gnugo-synchronous-send/return | |
287 | (format "%s %s" command (gnugo-position)))))) | |
288 | (if (not (string= "=" (substring stones 0 1))) | |
289 | (error stones) | |
290 | (setq stones (split-string (substring stones 1))) | |
291 | (message "Computing %s ... %s in group." command (length stones)) | |
292 | (dolist (c (string-to-list gnugo-animation-string)) | |
293 | (save-excursion | |
294 | (dolist (pos stones) | |
295 | (gnugo-goto-pos pos) | |
296 | (delete-char 1) | |
297 | (insert c))) | |
298 | (sit-for 0.08675309)) ; jenny jenny i got your number... | |
299 | (sit-for 5) | |
300 | (let ((p (point))) | |
301 | (gnugo-showboard) | |
302 | (goto-char p))))) | |
303 | ||
304 | (defun gnugo-display-group-data (command buffer-name) | |
305 | (message "Computing %s ..." command) | |
306 | (let ((data (cdr (gnugo-synchronous-send/return | |
307 | (format "%s %s" command (gnugo-position)))))) | |
308 | (switch-to-buffer buffer-name) | |
309 | (erase-buffer) | |
310 | (insert data)) | |
311 | (message "Computing %s ... done." command)) | |
312 | ||
313 | (defun gnugo-worm-stones () | |
314 | "In the *gnugo board* buffer, animate \"worm\" at current position. | |
315 | Signal error if done out-of-turn or if game-over. | |
316 | See variable `gnugo-animation-string' for customization." | |
317 | (interactive) | |
318 | (gnugo-gate) | |
319 | (gnugo-animate-group "worm_stones")) | |
320 | ||
321 | (defun gnugo-worm-data () | |
322 | "Display in another buffer data from \"worm\" at current position. | |
323 | Signal error if done out-of-turn or if game-over." | |
324 | (interactive) | |
325 | (gnugo-gate) | |
326 | (gnugo-display-group-data "worm_data" "*gnugo worm data*")) | |
327 | ||
328 | (defun gnugo-dragon-stones () | |
329 | "In the *gnugo board* buffer, animate \"dragon\" at current position. | |
330 | Signal error if done out-of-turn or if game-over. | |
331 | See variable `gnugo-animation-string' for customization." | |
332 | (interactive) | |
333 | (gnugo-gate) | |
334 | (gnugo-animate-group "dragon_stones")) | |
335 | ||
336 | (defun gnugo-dragon-data () | |
337 | "Display in another buffer data from \"dragon\" at current position. | |
338 | Signal error if done out-of-turn or if game-over." | |
339 | (interactive) | |
340 | (gnugo-gate) | |
341 | (gnugo-display-group-data "dragon_data" "*gnugo dragon data*")) | |
342 | ||
343 | (defun gnugo-snap () | |
344 | (save-excursion | |
345 | (let ((letters (progn | |
346 | (goto-char (point-min)) | |
347 | (end-of-line) | |
348 | (split-string (buffer-substring (point-min) (point))))) | |
349 | (maxnum (read (current-buffer))) | |
350 | snap) | |
351 | (dolist (letter letters) | |
352 | (do ((number maxnum (1- number))) | |
353 | ((= 0 number)) | |
354 | (let* ((pos (format "%s%d" letter number)) | |
355 | (color (gnugo-query (format "color %s" pos)))) | |
356 | (unless (string= "empty" color) | |
357 | (setq snap (cons (cons pos color) snap)))))) | |
358 | snap))) | |
359 | ||
360 | (defun gnugo-toggle-dead-group () | |
361 | "In a *gnugo board* buffer, during game-over, toggle a group as dead. | |
362 | The group is selected from current position (point). | |
363 | Signal error if not in game-over or if there is no group at that position." | |
364 | (interactive) | |
365 | (unless (eq 'game-over (get 'gnugo 'last-move)) | |
366 | (error "Sorry, game still in play")) | |
367 | (let* ((snap (or (get 'gnugo 'snap) (put 'gnugo 'snap (gnugo-snap)))) | |
368 | (pos (gnugo-position)) | |
369 | (color (gnugo-query (format "color %s" pos))) | |
370 | (morgue (get 'gnugo 'morgue))) | |
371 | (if (string= "empty" color) | |
372 | (let ((already-dead (find-if '(lambda (group) | |
373 | (member pos (cdr group))) | |
374 | morgue))) | |
375 | (unless already-dead | |
376 | (error "No group at that position")) | |
377 | (put 'gnugo 'morgue (delete already-dead morgue)) | |
378 | (setq color (car already-dead)) | |
379 | (save-excursion | |
380 | (let ((c (if (string= color "black") "X" "O"))) | |
381 | (dolist (stone (cdr already-dead)) | |
382 | (gnugo-synchronous-send/return | |
383 | (format "play %s %s" color stone)) | |
384 | (gnugo-goto-pos stone) (delete-char 1) (insert c))))) | |
385 | (let ((stones (sort (split-string | |
386 | (gnugo-query (format "worm_stones %s" pos))) | |
387 | 'string<))) | |
388 | (let ((newly-dead (cons color stones))) | |
389 | (unless (member newly-dead morgue) | |
390 | (setq morgue (put 'gnugo 'morgue (cons newly-dead morgue))))) | |
391 | ;; clear and add back everything except the dead -- yuk! | |
392 | (gnugo-synchronous-send/return "clear_board") | |
393 | (let ((all-dead (apply 'append (mapcar 'cdr morgue)))) | |
394 | (dolist (pos-color snap) | |
395 | (unless (member (car pos-color) all-dead) | |
396 | (gnugo-synchronous-send/return | |
397 | (format "play %s %s" (cdr pos-color) (car pos-color)))))) | |
398 | (let ((p (point))) | |
399 | ;;(gnugo-showboard) | |
400 | (dolist (worm morgue) | |
401 | (let ((c (if (string= "black" (car worm)) "x" "o"))) | |
402 | (dolist (stone (cdr worm)) | |
403 | (gnugo-goto-pos stone) | |
404 | (delete-char 1) (insert c)))) | |
405 | (goto-char p)))))) | |
406 | ||
407 | (defun gnugo-estimate-score () | |
408 | "Display estimated score of a game of GNU Go. | |
409 | Output includes number of stones on the board and number of stones | |
410 | captured by each player, and the estimate of who has the advantage (and | |
411 | by how many stones)." | |
412 | (interactive) | |
413 | (message "Est.score ...") | |
414 | (let ((black (length (split-string (gnugo-query "list_stones black")))) | |
415 | (white (length (split-string (gnugo-query "list_stones white")))) | |
416 | (black-captures (gnugo-query "captures black")) | |
417 | (white-captures (gnugo-query "captures white")) | |
418 | (est (gnugo-query "estimate_score"))) | |
419 | (message "Est.score ... B %s %s | W %s %s | %s" | |
420 | black black-captures white white-captures est))) | |
421 | ||
422 | ;;;--------------------------------------------------------------------------- | |
423 | ;;; Command properties and gnugo-command | |
424 | ||
425 | ;; A direct gtp command can easily confuse gnugo.el, so we allow for | |
426 | ;; interpretation of any command (and still become confused when the | |
427 | ;; heuristics fail ;-). Both control and data paths are are influenced by | |
428 | ;; these properties: | |
429 | ;; | |
430 | ;; gnugo-full -- completely interpret the command string; the value is a | |
431 | ;; func that takes the list of words derived from splitting the | |
432 | ;; command string (minus the command) and handles everything. | |
433 | ;; | |
434 | ;; gnugo-rinse -- function taking raw output string and returning a | |
435 | ;; (possibly filtered) replacement, the only one able | |
436 | ;; to set the `gnugo-post-function' property (below). | |
437 | ;; value may also be a list of such functions. | |
438 | ;; | |
439 | ;; gnugo-output -- symbol specifying the preferred output method. | |
440 | ;; message -- show output in minibuffer | |
441 | ;; discard -- sometimes you just don't care | |
442 | ;; default is to switch to buffer "*gnugo command output*" | |
443 | ;; if the output has a newline, otherwise use `message'. | |
444 | ;; | |
445 | ;; gnugo-post-function -- function or list of functions to call after the | |
446 | ;; command (also after all output processing); only | |
447 | ;; settable by a `gnugo-rinse' function. | |
448 | ||
449 | (defun gnugo-command (command) | |
450 | "During a GNU Go game, send Go Text Protocol COMMAND to the subprocess." | |
451 | (interactive "sCommand: ") | |
452 | (if (string= "" command) | |
453 | (message "(no command given)") | |
454 | (let* ((split (split-string command)) | |
455 | (cmd (intern (car split))) | |
456 | (full (get cmd 'gnugo-full)) | |
457 | (last-message nil)) | |
458 | (if full | |
459 | (funcall full (cdr split)) | |
460 | (message "Doing %s ..." command) | |
461 | (let* ((ans (cdr (gnugo-synchronous-send/return command))) | |
462 | (rinse (get cmd 'gnugo-rinse)) | |
463 | (where (get cmd 'gnugo-output))) | |
464 | (put cmd 'gnugo-post-function nil) | |
465 | (when rinse | |
466 | (cond ((functionp rinse) (setq ans (funcall rinse ans))) | |
467 | ((listp rinse) (while rinse | |
468 | (setq ans (funcall (car rinse) ans) | |
469 | rinse (cdr rinse)))) | |
470 | (t (error "bad gnugo-rinse property: %s" rinse)))) | |
471 | (if (string-match "unknown.command" ans) | |
472 | (message ans) | |
473 | (cond ((eq 'discard where) (message "")) | |
474 | ((or (eq 'message where) | |
475 | (not (string-match "\n" ans))) | |
476 | (message ans)) | |
477 | (t (switch-to-buffer "*gnugo command output*") | |
478 | (erase-buffer) | |
479 | (insert ans) | |
480 | (message "Doing %s ... done." command))) | |
481 | (let ((pf (get cmd 'gnugo-post-function))) | |
482 | (when pf | |
483 | (cond ((functionp pf) (funcall pf)) | |
484 | ((listp pf) (while pf | |
485 | (progn (funcall (car pf)) | |
486 | (setq pf (cdr pf))))) | |
487 | (t (error "bad gnugo-post-function property: %s" | |
488 | pf))) | |
489 | (put cmd 'gnugo-post-function nil))))))))) | |
490 | ||
491 | ;;;--------------------------------------------------------------------------- | |
492 | ;;; Major mode for interacting with a GNU Go subprocess | |
493 | ||
494 | (defun gnugo-board-mode () | |
495 | "In this mode, keys do not self insert. | |
496 | Here are the default keybindings: | |
497 | ||
498 | ? View this help. | |
499 | ||
500 | RET or SPC Select point as the next move. | |
501 | An error is signalled for invalid locations. | |
502 | ||
503 | q or Q Quit (the latter without confirmation). | |
504 | ||
505 | R Resign. | |
506 | ||
507 | C-l Refresh board. | |
508 | ||
509 | _ or M-_ Bury the Board buffer (when the boss is near). | |
510 | ||
511 | P Pass; i.e., select no location for your move. | |
512 | ||
513 | w Animate current position's worm stones. | |
514 | d Animate current position's dragon stones. | |
515 | See variable `gnugo-animation-string'. | |
516 | ||
517 | W Display current position's worm data in another buffer. | |
518 | D Display current position's dragon data in another buffer. | |
519 | ||
520 | t Toggle dead groups (when the game is over). | |
521 | ||
522 | ! Estimate score (at any time). | |
523 | ||
524 | : or ; Extended command. Type in a string to be passed (quite | |
525 | indirectly) to the GNU Go subprocess. Output and emacs | |
526 | behavior depend on which command is given. Try `help' | |
527 | to get a list of all commands. Note that some commands | |
528 | may confuse gnugo.el." | |
529 | (kill-all-local-variables) | |
530 | (use-local-map gnugo-board-mode-map) | |
531 | (setq major-mode 'gnugo-board-mode) | |
532 | (setq mode-name "GNU Go Board")) | |
533 | ||
534 | ;;;--------------------------------------------------------------------------- | |
535 | ;;; Entry point | |
536 | ||
537 | ;;;###autoload | |
538 | (defun gnugo () | |
539 | "Run gnugo in a buffer, or resume a game in progress. | |
540 | You are queried for additional command-line options (Emacs supplies | |
541 | \"--mode gtp --quiet\" automatically). Here is a list of options | |
542 | that gnugo.el understands and handles specially: | |
543 | ||
544 | --boardsize num Set the board size to use (5--19) | |
545 | --color <color> Choose your color ('black' or 'white') | |
546 | --handicap <num> Set the number of handicap stones (0--9) | |
547 | ||
548 | If there is already a game in progress you may resume it instead of | |
549 | starting a new one. See `gnugo-board-mode' documentation for more info. | |
550 | See also variable `gnugo-option-history'." | |
551 | (interactive) | |
552 | (if (and (get 'gnugo 'proc) | |
553 | (y-or-n-p "GNU Go game in progress, resume play? ")) | |
554 | (progn | |
555 | (switch-to-buffer (get 'gnugo 'bbuf)) | |
556 | (gnugo-refresh)) | |
557 | (gnugo-cleanup t) | |
558 | (put 'gnugo 'last 1) | |
559 | (let* ((name "gnugo") | |
560 | (args (read-string "GNU Go options: " | |
561 | (car gnugo-option-history) | |
562 | 'gnugo-option-history)) | |
563 | (proc (apply 'start-process name nil name | |
564 | "--mode" "gtp" "--quiet" | |
565 | (split-string args))) | |
566 | (bbuf (generate-new-buffer "*gnugo board*")) | |
567 | (board-cols (+ 8 (* 2 (if (string-match "--boardsize" args) | |
568 | (let ((start (match-end 0))) | |
569 | (string-match "[1-9]+" args start) | |
570 | (string-to-number (match-string 0 args))) | |
571 | 19)))) | |
572 | (user-color (if (string-match "--color" args) | |
573 | (let ((start (match-end 0))) | |
574 | (string-match "\\(black\\|white\\)" args start) | |
575 | (match-string 0 args)) | |
576 | "black")) | |
577 | (gnugo-color (gnugo-other user-color)) | |
578 | (handicap (if (string-match "--handicap" args) | |
579 | (let ((start (match-end 0))) | |
580 | (string-match "[0-9]+" args start) | |
581 | (string-to-number (match-string 0 args))) | |
582 | 0)) | |
583 | (passes 0) | |
584 | snap morgue) | |
585 | (mapcar '(lambda (sym) | |
586 | (put 'gnugo sym (eval sym))) | |
587 | '(proc bbuf board-cols user-color gnugo-color handicap passes | |
588 | snap morgue)) | |
589 | (unless (= 0 handicap) | |
590 | (gnugo-synchronous-send/return (concat "fixed_handicap " handicap))) | |
591 | (set-process-sentinel proc 'gnugo-sentinel) | |
592 | (gnugo-refresh)) | |
593 | ;; set it all up | |
594 | (gnugo-board-mode) | |
595 | ;; first move | |
596 | (when (or (and (string= "black" (get 'gnugo 'user-color)) | |
597 | (< 1 (get 'gnugo 'handicap))) | |
598 | (and (string= "black" (get 'gnugo 'gnugo-color)) | |
599 | (< (get 'gnugo 'handicap) 2))) | |
600 | (gnugo-get-move (get 'gnugo 'gnugo-color))))) | |
601 | ||
602 | ;;;--------------------------------------------------------------------------- | |
603 | ;;; Load-time actions | |
604 | ||
605 | (unless gnugo-board-mode-map | |
606 | (setq gnugo-board-mode-map (make-sparse-keymap)) | |
607 | (suppress-keymap gnugo-board-mode-map) | |
608 | (mapcar '(lambda (pair) | |
609 | (define-key gnugo-board-mode-map (car pair) (cdr pair))) | |
610 | '(("?" . describe-mode) | |
611 | ("\C-m" . gnugo-move) | |
612 | (" " . gnugo-move) | |
613 | ("P" . gnugo-pass) | |
614 | ("R" . (lambda () (interactive) | |
615 | (if (y-or-n-p "Resign? ") | |
616 | (gnugo-cleanup) | |
617 | (message "(not resigning)")))) | |
618 | ("q" . (lambda () (interactive) | |
619 | (if (y-or-n-p "Quit? ") | |
620 | (gnugo-cleanup) | |
621 | (message "(not quitting)")))) | |
622 | ("Q" . gnugo-cleanup) | |
623 | ("\C-l" . gnugo-refresh) | |
624 | ("\M-_" . bury-buffer) | |
625 | ("_" . bury-buffer) | |
626 | ("w" . gnugo-worm-stones) | |
627 | ("W" . gnugo-worm-data) | |
628 | ("d" . gnugo-dragon-stones) | |
629 | ("D" . gnugo-dragon-data) | |
630 | ("t" . gnugo-toggle-dead-group) | |
631 | ("!" . gnugo-estimate-score) | |
632 | (":" . gnugo-command) | |
633 | (";" . gnugo-command) | |
634 | ;; mouse | |
635 | ([(down-mouse-1)] . gnugo-mouse-move) | |
636 | ([(down-mouse-3)] . gnugo-mouse-pass)))) | |
637 | ||
638 | (put 'help 'gnugo-full | |
639 | '(lambda (sel) | |
640 | (info "(gnugo)GTP command reference") | |
641 | (if (not sel) | |
642 | (message "(you can also try \"help COMMAND\" next time)") | |
643 | (let ((topic (intern (car sel)))) | |
644 | (goto-char (point-min)) | |
645 | (when (search-forward (concat "* " (car sel) "\n") (point-max) t) | |
646 | (let (buffer-read-only) | |
647 | (when (get topic 'gnugo-full) | |
648 | (insert "[NOTE: fully handled by gnugo.el]\n")) | |
649 | (when (get topic 'gnugo-rinse) | |
650 | (insert "[NOTE: output rinsed by gnugo.el]\n")))))))) | |
651 | ||
652 | (mapc '(lambda (command) | |
653 | (put command 'gnugo-output 'discard) | |
654 | (put command 'gnugo-rinse | |
655 | '(lambda (ans) | |
656 | (put cmd 'gnugo-post-function 'gnugo-refresh) | |
657 | ans))) | |
658 | '(clear_board | |
659 | fixed_handicap)) | |
660 | ||
661 | (provide 'gnugo) | |
662 | ||
663 | ;;; $RCSfile: gnugo.el,v $$Revision: 1.1.1.1 $ ends here |