;;; ID: $Id: gnugo.el,v 1.1.1.1 2008/12/21 18:47:58 bump Exp $
;;; This is GNU Go, a Go program. Contact gnugo@gnu.org, or see
;;; http://www.gnu.org/software/gnugo/ for more information.
;;; Copyright 1999, 2000, 2001 by the Free Software Foundation.
;;; This program is free software; you can redistribute it and/
;;; modify it under the terms of the GNU General Public License
;;; as published by the Free Software Foundation - version 3,
;;; or (at your option) any later version.
;;; This program is distributed in the hope that it will be
;;; useful, but WITHOUT ANY WARRANTY; without even the implied
;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;; PURPOSE. See the GNU General Public License in file COPYIN
;;; You should have received a copy of the GNU General Public
;;; License along with this program; if not, write to the Free
;;; Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;;; Boston, MA 02111, USA.
;;; Description: Run GNU Go in a buffer.
;; This is an interface to GNU Go using the Go Text Protocol. Interaction
;; with the gnugo subprocess is synchronous except for `gnugo-get-move'. This
;; means you can use Emacs to do other things while gnugo is thinking about
;; its move. (Actually, all interaction with the subprocess is inhibited
;; during thinking time -- really, trying to distract your opponent is poor
;; Customization is presently limited to `gnugo-animation-string', q.v.
;; This code was tested with Emacs 20.7 on a monochrome 80x24 terminal.
(require 'cl) ; use the source luke!
;;;---------------------------------------------------------------------------
(defvar gnugo-board-mode-map nil
"Keymap for GNU Go Board mode.")
(defvar gnugo-option-history nil
"History of additional GNU Go command-line options.")
(defvar gnugo-animation-string
(let ((jam "*#") (blink " #") (spin "-\\|/") (yada "*-*!"))
(concat jam jam jam jam jam
blink blink blink blink blink blink blink blink
;; Playing go is like fighting ignorance: when you think you have
;; surrounded something by knowing it very well it often turns
;; out that in the time you spent deepening this understanding,
;; other areas of ignorance have surrounded you.
spin spin spin spin spin spin spin spin spin
;; Playing go is not like fighting ignorance: what one person
;; knows many people may come to know; knowledge does not build
;; solely move by move. Wisdom, on the other hand...
"*String whose individual characters are used for animation.
Specifically, the `gnugo-worm-stones' and `gnugo-dragon-stones' commands
render the stones in their respective (computed) groups as the first
character in the string, then the next, and so on until the string (and/or
the viewer) is exhausted.")
;;;---------------------------------------------------------------------------
(defun gnugo-other (color)
(if (string= "black" color) "white" "black"))
(unless (eq (current-buffer) (get 'gnugo 'bbuf))
(error "Wrong buffer -- try M-x gnugo"))
(when (eq 'waiting (get 'gnugo 'get-move-state))
(error "Not your turn yet -- please wait"))
(when (eq 'game-over (get 'gnugo 'last-move))
(error "Sorry, game over")))
(defun gnugo-sentinel (proc string)
(let ((status (process-status proc)))
(when (or (eq status 'exit)
(switch-to-buffer (get 'gnugo 'bbuf))
(put 'gnugo 'proc nil))))
(defun gnugo-send-line (line)
(process-send-string (get 'gnugo 'proc) (concat line "\n")))
(defun gnugo-synchronous-send/return (message)
"Return (TIME . STRING) where TIME is that returned by `current-time' and
STRING omits the two trailing newlines. See also `gnugo-query'."
(when (eq 'waiting (get 'gnugo 'get-move-state))
(error "sorry, still waiting for %s to play" (get 'gnugo 'gnugo-color)))
(put 'gnugo 'sync-return "")
(let ((proc (get 'gnugo 'proc)))
proc #'(lambda (proc string)
(let* ((so-far (get 'gnugo 'sync-return))
(start (max 0 (- (length so-far) 2))) ; backtrack a little
(full (put 'gnugo 'sync-return (concat so-far string))))
(when (string-match "\n\n" full start)
(cons (current-time) (substring full 0 -2)))))))
(gnugo-send-line message)
(while (stringp (setq rv (get 'gnugo 'sync-return)))
(accept-process-output proc))
(put 'gnugo 'sync-return "")
(defun gnugo-query (message)
"Return cleaned-up value of a call to `gnugo-synchronous-send/return', q.v.
The TIME portion is omitted as well as the first two characters of the STRING
portion (corresponding to the status indicator in the Go Text Protocol). Use
this function when you are sure the command cannot fail."
(substring (cdr (gnugo-synchronous-send/return message)) 2))
(defun gnugo-goto-pos (pos)
"Move point to board position POS, a letter-number string."
(search-forward (substring pos 0 1))
(let ((col (1- (current-column))))
(re-search-forward (concat "^\\s-*" (substring pos 1) "\\s-"))
;;;---------------------------------------------------------------------------
(defun gnugo-showboard ()
(let ((board (cdr (gnugo-synchronous-send/return "showboard")))
white-captures black-captures)
(with-current-buffer (get 'gnugo 'bbuf)
(delete-region (point-min) (point-max))
(insert (substring board 3)) ; omit "= \n"
(while (re-search-forward "\\s-*\\(WH\\|BL\\).*capt.*\\([0-9]+\\).*$"
(if (string= "WH" (match-string 1))
(setq white-captures (match-string 2))
(setq black-captures (match-string 2)))
(move-to-column-force (get 'gnugo 'board-cols))
(delete-region (point) (point-max))
(case (get 'gnugo 'last-move)
((nil) "(black to play)")
((game-over) "(t toggle, ! score, q quit)")
(t (let* ((last-move (get 'gnugo 'last-move))
(setq pos (and (not (string= "PASS" move)) move))
(format "%s: %s (%s to play)\n%scaptures: black %s white %s"
color move (gnugo-other color)
(make-string (get 'gnugo 'board-cols) 32) ; space
black-captures white-captures)))))
(delete-char -1) (insert "(")
(forward-char 1) (delete-char 1) (insert ")")))
(goto-char (get 'gnugo 'last)))))
(defun gnugo-get-move-insertion-filter (proc string)
(let* ((so-far (get 'gnugo 'get-move-string))
(full (put 'gnugo 'get-move-string (concat so-far string))))
(when (string-match "^= \\(.+\\)\n\n" full)
(let ((pos (match-string 1 full)))
(put 'gnugo 'get-move-string nil)
(put 'gnugo 'get-move-state nil)
(put 'gnugo 'last-move (cons (get 'gnugo 'gnugo-color) pos))
(1+ (get 'gnugo 'passes))
(when (= 2 (get 'gnugo 'passes))
(put 'gnugo 'last-move 'game-over))))))
(defun gnugo-get-move (color)
(put 'gnugo 'get-move-state 'waiting)
(set-process-filter (get 'gnugo 'proc) 'gnugo-get-move-insertion-filter)
(gnugo-send-line (concat "genmove " color))
(defun gnugo-cleanup (&optional quietly)
"Kill gnugo process and *gnugo board* buffer. Reset internal state."
(let ((proc (get 'gnugo 'proc)))
(let ((bbuf (get 'gnugo 'bbuf)))
(when (and bbuf (get-buffer bbuf))
(message "Thank you for playing GNU Go."))
(let* ((letter (ignore-errors
(let ((col (current-column)))
(re-search-forward "^\\s-+A B C")
(buffer-substring (point) (1+ (point)))))))
(looking-at "\\s-*\\([0-9]+\\)")
(pos (concat letter number)))
(if (string-match "^[A-T][1-9][0-9]*$" pos)
(error "Not a proper position point"))))
"Make a move on the *gnugo board* buffer.
The position is computed from current point.
Signal error if done out-of-turn or if game-over.
To start a game try M-x gnugo."
(let* ((pos (gnugo-position))
(move (format "play %s %s" (get 'gnugo 'user-color) pos))
(accept (cdr (gnugo-synchronous-send/return move)))
(status (substring accept 0 1)))
(cond ((string= "=" status)
(put 'gnugo 'last (point))
(put 'gnugo 'last-move (cons (get 'gnugo 'user-color) pos))
(gnugo-get-move (get 'gnugo 'gnugo-color))))
(defun gnugo-mouse-move (e)
"Do `gnugo-move' at mouse location."
(when (looking-at "[.+]")
"Make a pass on the *gnugo board* buffer.
Signal error if done out-of-turn or if game-over.
To start a game try M-x gnugo."
(let ((passes (1+ (get 'gnugo 'passes))))
(put 'gnugo 'passes passes)
(cons (get 'gnugo 'user-color) "PASS")))
(gnugo-get-move (get 'gnugo 'gnugo-color)))))
(defun gnugo-mouse-pass (e)
"Do `gnugo-pass' at mouse location."
"Display *gnugo board* buffer and update it with the current board state.
During normal play, parenthesize the last-played stone (no parens for pass),
and display at bottom-right corner a message describing the last-played
position, who played it (and who is to play), and the number of stones
captured thus far by each player."
(switch-to-buffer (get 'gnugo 'bbuf))
(defun gnugo-animate-group (command)
(message "Computing %s ..." command)
(let ((stones (cdr (gnugo-synchronous-send/return
(format "%s %s" command (gnugo-position))))))
(if (not (string= "=" (substring stones 0 1)))
(setq stones (split-string (substring stones 1)))
(message "Computing %s ... %s in group." command (length stones))
(dolist (c (string-to-list gnugo-animation-string))
(sit-for 0.08675309)) ; jenny jenny i got your number...
(defun gnugo-display-group-data (command buffer-name)
(message "Computing %s ..." command)
(let ((data (cdr (gnugo-synchronous-send/return
(format "%s %s" command (gnugo-position))))))
(switch-to-buffer buffer-name)
(message "Computing %s ... done." command))
(defun gnugo-worm-stones ()
"In the *gnugo board* buffer, animate \"worm\" at current position.
Signal error if done out-of-turn or if game-over.
See variable `gnugo-animation-string' for customization."
(gnugo-animate-group "worm_stones"))
(defun gnugo-worm-data ()
"Display in another buffer data from \"worm\" at current position.
Signal error if done out-of-turn or if game-over."
(gnugo-display-group-data "worm_data" "*gnugo worm data*"))
(defun gnugo-dragon-stones ()
"In the *gnugo board* buffer, animate \"dragon\" at current position.
Signal error if done out-of-turn or if game-over.
See variable `gnugo-animation-string' for customization."
(gnugo-animate-group "dragon_stones"))
(defun gnugo-dragon-data ()
"Display in another buffer data from \"dragon\" at current position.
Signal error if done out-of-turn or if game-over."
(gnugo-display-group-data "dragon_data" "*gnugo dragon data*"))
(split-string (buffer-substring (point-min) (point)))))
(maxnum (read (current-buffer)))
(do ((number maxnum (1- number)))
(let* ((pos (format "%s%d" letter number))
(color (gnugo-query (format "color %s" pos))))
(unless (string= "empty" color)
(setq snap (cons (cons pos color) snap))))))
(defun gnugo-toggle-dead-group ()
"In a *gnugo board* buffer, during game-over, toggle a group as dead.
The group is selected from current position (point).
Signal error if not in game-over or if there is no group at that position."
(unless (eq 'game-over (get 'gnugo 'last-move))
(error "Sorry, game still in play"))
(let* ((snap (or (get 'gnugo 'snap) (put 'gnugo 'snap (gnugo-snap))))
(color (gnugo-query (format "color %s" pos)))
(morgue (get 'gnugo 'morgue)))
(if (string= "empty" color)
(let ((already-dead (find-if '(lambda (group)
(member pos (cdr group)))
(error "No group at that position"))
(put 'gnugo 'morgue (delete already-dead morgue))
(setq color (car already-dead))
(let ((c (if (string= color "black") "X" "O")))
(dolist (stone (cdr already-dead))
(gnugo-synchronous-send/return
(format "play %s %s" color stone))
(gnugo-goto-pos stone) (delete-char 1) (insert c)))))
(let ((stones (sort (split-string
(gnugo-query (format "worm_stones %s" pos)))
(let ((newly-dead (cons color stones)))
(unless (member newly-dead morgue)
(setq morgue (put 'gnugo 'morgue (cons newly-dead morgue)))))
;; clear and add back everything except the dead -- yuk!
(gnugo-synchronous-send/return "clear_board")
(let ((all-dead (apply 'append (mapcar 'cdr morgue))))
(unless (member (car pos-color) all-dead)
(gnugo-synchronous-send/return
(format "play %s %s" (cdr pos-color) (car pos-color))))))
(let ((c (if (string= "black" (car worm)) "x" "o")))
(dolist (stone (cdr worm))
(delete-char 1) (insert c))))
(defun gnugo-estimate-score ()
"Display estimated score of a game of GNU Go.
Output includes number of stones on the board and number of stones
captured by each player, and the estimate of who has the advantage (and
(message "Est.score ...")
(let ((black (length (split-string (gnugo-query "list_stones black"))))
(white (length (split-string (gnugo-query "list_stones white"))))
(black-captures (gnugo-query "captures black"))
(white-captures (gnugo-query "captures white"))
(est (gnugo-query "estimate_score")))
(message "Est.score ... B %s %s | W %s %s | %s"
black black-captures white white-captures est)))
;;;---------------------------------------------------------------------------
;;; Command properties and gnugo-command
;; A direct gtp command can easily confuse gnugo.el, so we allow for
;; interpretation of any command (and still become confused when the
;; heuristics fail ;-). Both control and data paths are are influenced by
;; gnugo-full -- completely interpret the command string; the value is a
;; func that takes the list of words derived from splitting the
;; command string (minus the command) and handles everything.
;; gnugo-rinse -- function taking raw output string and returning a
;; (possibly filtered) replacement, the only one able
;; to set the `gnugo-post-function' property (below).
;; value may also be a list of such functions.
;; gnugo-output -- symbol specifying the preferred output method.
;; message -- show output in minibuffer
;; discard -- sometimes you just don't care
;; default is to switch to buffer "*gnugo command output*"
;; if the output has a newline, otherwise use `message'.
;; gnugo-post-function -- function or list of functions to call after the
;; command (also after all output processing); only
;; settable by a `gnugo-rinse' function.
(defun gnugo-command (command)
"During a GNU Go game, send Go Text Protocol COMMAND to the subprocess."
(interactive "sCommand: ")
(message "(no command given)")
(let* ((split (split-string command))
(cmd (intern (car split)))
(full (get cmd 'gnugo-full))
(funcall full (cdr split))
(message "Doing %s ..." command)
(let* ((ans (cdr (gnugo-synchronous-send/return command)))
(rinse (get cmd 'gnugo-rinse))
(where (get cmd 'gnugo-output)))
(put cmd 'gnugo-post-function nil)
(cond ((functionp rinse) (setq ans (funcall rinse ans)))
((listp rinse) (while rinse
(setq ans (funcall (car rinse) ans)
(t (error "bad gnugo-rinse property: %s" rinse))))
(if (string-match "unknown.command" ans)
(cond ((eq 'discard where) (message ""))
(not (string-match "\n" ans)))
(t (switch-to-buffer "*gnugo command output*")
(message "Doing %s ... done." command)))
(let ((pf (get cmd 'gnugo-post-function)))
(cond ((functionp pf) (funcall pf))
(progn (funcall (car pf))
(t (error "bad gnugo-post-function property: %s"
(put cmd 'gnugo-post-function nil)))))))))
;;;---------------------------------------------------------------------------
;;; Major mode for interacting with a GNU Go subprocess
(defun gnugo-board-mode ()
"In this mode, keys do not self insert.
Here are the default keybindings:
RET or SPC Select point as the next move.
An error is signalled for invalid locations.
q or Q Quit (the latter without confirmation).
_ or M-_ Bury the Board buffer (when the boss is near).
P Pass; i.e., select no location for your move.
w Animate current position's worm stones.
d Animate current position's dragon stones.
See variable `gnugo-animation-string'.
W Display current position's worm data in another buffer.
D Display current position's dragon data in another buffer.
t Toggle dead groups (when the game is over).
! Estimate score (at any time).
: or ; Extended command. Type in a string to be passed (quite
indirectly) to the GNU Go subprocess. Output and emacs
behavior depend on which command is given. Try `help'
to get a list of all commands. Note that some commands
(kill-all-local-variables)
(use-local-map gnugo-board-mode-map)
(setq major-mode 'gnugo-board-mode)
(setq mode-name "GNU Go Board"))
;;;---------------------------------------------------------------------------
"Run gnugo in a buffer, or resume a game in progress.
You are queried for additional command-line options (Emacs supplies
\"--mode gtp --quiet\" automatically). Here is a list of options
that gnugo.el understands and handles specially:
--boardsize num Set the board size to use (5--19)
--color <color> Choose your color ('black' or 'white')
--handicap <num> Set the number of handicap stones (0--9)
If there is already a game in progress you may resume it instead of
starting a new one. See `gnugo-board-mode' documentation for more info.
See also variable `gnugo-option-history'."
(if (and (get 'gnugo 'proc)
(y-or-n-p "GNU Go game in progress, resume play? "))
(switch-to-buffer (get 'gnugo 'bbuf))
(args (read-string "GNU Go options: "
(car gnugo-option-history)
(proc (apply 'start-process name nil name
(bbuf (generate-new-buffer "*gnugo board*"))
(board-cols (+ 8 (* 2 (if (string-match "--boardsize" args)
(let ((start (match-end 0)))
(string-match "[1-9]+" args start)
(string-to-number (match-string 0 args)))
(user-color (if (string-match "--color" args)
(let ((start (match-end 0)))
(string-match "\\(black\\|white\\)" args start)
(gnugo-color (gnugo-other user-color))
(handicap (if (string-match "--handicap" args)
(let ((start (match-end 0)))
(string-match "[0-9]+" args start)
(string-to-number (match-string 0 args)))
(put 'gnugo sym (eval sym)))
'(proc bbuf board-cols user-color gnugo-color handicap passes
(gnugo-synchronous-send/return (concat "fixed_handicap " handicap)))
(set-process-sentinel proc 'gnugo-sentinel)
(when (or (and (string= "black" (get 'gnugo 'user-color))
(< 1 (get 'gnugo 'handicap)))
(and (string= "black" (get 'gnugo 'gnugo-color))
(< (get 'gnugo 'handicap) 2)))
(gnugo-get-move (get 'gnugo 'gnugo-color)))))
;;;---------------------------------------------------------------------------
(unless gnugo-board-mode-map
(setq gnugo-board-mode-map (make-sparse-keymap))
(suppress-keymap gnugo-board-mode-map)
(define-key gnugo-board-mode-map (car pair) (cdr pair)))
("R" . (lambda () (interactive)
(if (y-or-n-p "Resign? ")
(message "(not resigning)"))))
("q" . (lambda () (interactive)
(message "(not quitting)"))))
("w" . gnugo-worm-stones)
("d" . gnugo-dragon-stones)
("D" . gnugo-dragon-data)
("t" . gnugo-toggle-dead-group)
("!" . gnugo-estimate-score)
([(down-mouse-1)] . gnugo-mouse-move)
([(down-mouse-3)] . gnugo-mouse-pass))))
(info "(gnugo)GTP command reference")
(message "(you can also try \"help COMMAND\" next time)")
(let ((topic (intern (car sel))))
(when (search-forward (concat "* " (car sel) "\n") (point-max) t)
(when (get topic 'gnugo-full)
(insert "[NOTE: fully handled by gnugo.el]\n"))
(when (get topic 'gnugo-rinse)
(insert "[NOTE: output rinsed by gnugo.el]\n"))))))))
(put command 'gnugo-output 'discard)
(put command 'gnugo-rinse
(put cmd 'gnugo-post-function 'gnugo-refresh)
;;; $RCSfile: gnugo.el,v $$Revision: 1.1.1.1 $ ends here
projects / sgk-go / blob