gnugo.el 1.15

[Thien-Thi Nguyen]

greetings earthlings,

please find below gnugo.el 1.15, rewritten to use the Go Text Protocol
supported by GNU Go.  i'm posting this here to get some feedback before
contributing it to the gnugo project (they have papers from me already).

users of a previous release of gnugo.el will notice less clutter and
(unintentional ;-) jitter as well as a new customization var.  a code
enhancement opportunity lies in the scoring method, which passes through
to gtp command `estimate_score' currently -- suggestions welcome.

dear RMS: i have procrastinated mightily on the variable-width fonts
support, but at least you can see how it is i love monospace so much...

thi

____________________________________________________________
;;; ID: gnugo.el,v 1.15 2002/11/16 00:26:37 ttn Exp
;;;
;;; Copyright (C) 1999, 2000, 2002 Thien-Thi Nguyen
;;; This file is part of ttn's personal elisp library, released under GNU
;;; GPL with ABSOLUTELY NO WARRANTY.  See the file COPYING for details.

;;; Description: Run GNU Go in a buffer.

;;; Commentary:

;; 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
;; sportsmanship. :-)
;;
;; Customization is presently limited to `gnugo-animation-string', q.v.
;;
;; This code was tested with Emacs 20.7 on a monochrome 80x24 terminal.

;;; Code:

(require 'cl)                           ; use the source luke!

;;;---------------------------------------------------------------------------
;;; Variables

(defvar gnugo-board-mode-map nil
  "Keymap for GNUGO Board mode.")

(defvar gnugo-option-history '()
  "History of additional GNUGO 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
            spin spin spin spin spin spin spin spin spin
            ;; "SECRET MESSAGE HERE"
            yada yada yada))
  "*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.")

;;;---------------------------------------------------------------------------
;;; Support functions

(defun gnugo-other (color)
  (if (string= "black" color) "white" "black"))

(defun gnugo-gate ()
  (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)
              (eq status 'signal))
      (switch-to-buffer (get 'gnugo 'bbuf))
      (delete-other-windows)
      (delete-process proc)
      (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.
  (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)))
    (set-process-filter
     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)
                  (put 'gnugo 'sync-return
                       (cons (current-time) (substring full 0 -2)))))))
    (gnugo-send-line message)
    (let (rv)
      ;; type change => break
      (while (stringp (setq rv (get 'gnugo 'sync-return)))
        (accept-process-output proc))
      (put 'gnugo 'sync-return "")
      rv)))

(defun gnugo-query (message)
  (substring (cdr (gnugo-synchronous-send/return message)) 2))

(defun gnugo-goto-pos (pos)
  (goto-char (point-min))
  (search-forward (substring pos 0 1))
  (let ((col (1- (current-column))))
    (re-search-forward (concat "^\\s-*" (substring pos 1) "\\s-"))
    (move-to-column col)))

;;;---------------------------------------------------------------------------
;;; Game play actions

(defun gnugo-showboard ()
  (interactive)
  (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"
      (goto-char (point-min))
      (while (re-search-forward "\\s-*\\(WH\\|BL\\).*capt.*\\([0-9]+\\).*$"
                                (point-max) t)
        (if (string= "WH" (match-string 1))
            (setq white-captures (match-string 2))
          (setq black-captures (match-string 2)))
        (replace-match ""))
      (goto-char (point-max))
      (move-to-column-force (get 'gnugo 'board-cols))
      (delete-region (point) (point-max))
      (let (pos)
        (insert
         (case (get 'gnugo 'last-move)
           ((nil) "(black to play)")
           ((game-over) "(t toggle, ! score, q quit)")
           (t (let* ((last-move (get 'gnugo 'last-move))
                     (color (car last-move))
                     (move (cdr last-move)))
                (setq pos (and (not (string= "PASS" move)) move))
                (format "%s: %s (%s to play)\n%scaptures: white %s black %s"
                        color move (gnugo-other color)
                        (make-string (get 'gnugo 'board-cols) 32) ; space
                        white-captures black-captures)))))
        (when pos
          (gnugo-goto-pos pos)
          (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))
        (gnugo-showboard)
        (put 'gnugo 'passes
             (if (string= "PASS" pos)
                 (1+ (get 'gnugo 'passes))
               0))
        (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))
  (accept-process-output))

(defun gnugo-progn (pair-list)
  (mapcar (lambda (pair)
            (condition-case error
                (let ((it (get 'gnugo (car pair))))
                  (when it
                    (funcall (cdr pair) it)))
              (error t)))
          pair-list))

(defun gnugo-cleanup ()
  "Kill gnugo process and buffers.  Reset internal state."
  (interactive)
  (gnugo-progn '((proc . delete-process)
                 (bbuf . kill-buffer)
                 (orig . switch-to-buffer)))
  (delete-other-windows)
  (message "Thank you for playing GNU Go.")
  (setplist 'gnugo nil))

(defun gnugo-position ()
  "Examine buffer, returning position based on point.
The position is expressed as a string: (concat LETTER NUMBER)"
  (let* ((letter (ignore-errors
                   (save-excursion
                     (let ((col (current-column)))
                       (re-search-forward "^\\s-+A B C")
                       (move-to-column col)
                       (buffer-substring (point) (1+ (point)))))))
         (number (save-excursion
                   (beginning-of-line)
                   (looking-at "\\s-*\\([0-9]+\\)")
                   (match-string 1)))
         (pos (concat letter number)))
    (if (string-match "^[A-T][1-9][0-9]*$" pos)
        pos
      (error "Not a proper position point"))))

(defun gnugo-move ()
  "Make a move."
  (interactive)
  (gnugo-gate)
  (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))
           (put 'gnugo 'passes 0)
           (gnugo-showboard))
          (t (error accept)))
    (gnugo-get-move (get 'gnugo 'gnugo-color))))

(defun gnugo-pass ()
  "Make a pass."
  (interactive)
  (gnugo-gate)
  (let ((passes (1+ (get 'gnugo 'passes))))
    (put 'gnugo 'passes passes)
    (put 'gnugo 'last-move
         (if (= 2 passes)
             'game-over
           (cons (get 'gnugo 'user-color) "PASS")))
    (gnugo-showboard)
    (unless (= 2 passes)
      (gnugo-get-move (get 'gnugo 'gnugo-color)))))

(defun gnugo-refresh ()
  (interactive)
  (switch-to-buffer (get 'gnugo 'bbuf))
  (gnugo-showboard))

(defun gnugo-bury ()
  (interactive)
  (gnugo-progn '((orig . switch-to-buffer)))
  (delete-other-windows))

(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)))
        (error stones)
      (setq stones (split-string (substring stones 1)))
      (message "Computing %s ... %s in group." command (length stones))
      (dolist (c (string-to-list gnugo-animation-string))
        (save-excursion
          (dolist (pos stones)
            (gnugo-goto-pos pos)
            (delete-char 1)
            (insert c)))
        (sit-for 0.08675309))           ; jenny jenny i got your number...
      (sit-for 5)
      (let ((p (point)))
        (gnugo-showboard)
        (goto-char p)))))

(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)
    (erase-buffer)
    (insert data))
  (message "Computing %s ... done." command))

(defun gnugo-worm-stones ()
  (interactive)
  (gnugo-animate-group "worm_stones"))

(defun gnugo-worm-data ()
  (interactive)
  (gnugo-display-group-data "worm_data" "*gnugo worm data*"))

(defun gnugo-dragon-stones ()
  (interactive)
  (gnugo-animate-group "dragon_stones"))

(defun gnugo-dragon-data ()
  (interactive)
  (gnugo-display-group-data "dragon_data" "*gnugo dragon data*"))

(defun gnugo-snap ()
  (save-excursion
    (let ((letters (progn
                     (goto-char (point-min))
                     (end-of-line)
                     (split-string (buffer-substring (point-min) (point)))))
          (maxnum (read (current-buffer)))
          snap)
      (dolist (letter letters)
        (do ((number maxnum (1- number)))
            ((= 0 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))))))
      snap)))

(defun gnugo-toggle-dead-group ()
  "Toggle a group as dead."
  (interactive)
  (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))))
         (pos (gnugo-position))
         (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)))
                                     morgue)))
          (unless already-dead
            (error "No group at that position"))
          (put 'gnugo 'morgue (delete already-dead morgue))
          (setq color (car already-dead))
          (save-excursion
            (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)))
                          'string<)))
        (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))))
          (dolist (pos-color snap)
            (unless (member (car pos-color) all-dead)
              (gnugo-synchronous-send/return
               (format "play %s %s" (cdr pos-color) (car pos-color))))))
        (let ((p (point)))
          ;;(gnugo-showboard)
          (dolist (worm morgue)
            (let ((c (if (string= "black" (car worm)) "x" "o")))
              (dolist (stone (cdr worm))
                (gnugo-goto-pos stone)
                (delete-char 1) (insert c))))
          (goto-char p))))))

(defun gnugo-estimate-score ()
  (interactive)
  (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)))

;;;---------------------------------------------------------------------------
;;; Major mode for

(defun gnugo-board-mode ()
  "In this mode, keys do not self insert.
Here are the default keybindings:

  ?             View this help.

  RET or SPC    Select point as the next move.
                An error is signalled for invalid locations.

  q or Q        Quit (the latter without confirmation).

  R             Resign.

  C-l           Refresh board.

  _ 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).

  :             Extended command.  Type in a string to be passed
                directly to the GNUGO subprocess.  Output goes to the
                buffer \"*gnugo command output*\" which is displayed.
                Note that some commands might confuse gnugo.el."
  (kill-all-local-variables)
  (use-local-map gnugo-board-mode-map)
  (setq major-mode 'gnugo-board-mode)
  (setq mode-name "GNUGO Board"))

(defun gnugo-interpret-action (action)
  (if (stringp action)
      (gnugo-send-line action)
    (funcall action)))

(defun gnugo-command ()
  (interactive)
  (let ((command (read-string "Command: ")))
    (message "Doing %s ..." command)
    (let ((data (cdr (gnugo-synchronous-send/return command))))
      (switch-to-buffer "*gnugo command output*")
      (erase-buffer)
      (insert data))
    (message "Doing %s ... done." command)))

;;;---------------------------------------------------------------------------
;;; Entry point

;;;###autoload
(defun gnugo ()
  "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."
  (interactive)
  (if (and (get 'gnugo 'proc)
           (y-or-n-p "GNU GO game in progress, resume play? "))
      (progn
        (put 'gnugo 'orig (current-buffer))     ; update
        (switch-to-buffer (get 'gnugo 'bbuf))
        (gnugo-refresh))
    (gnugo-cleanup)
    (put 'gnugo 'orig (current-buffer))
    (put 'gnugo 'last 1)
    (let* ((name "gnugo")
           (args (read-string "GNU GO options: "
                              (car gnugo-option-history)
                              'gnugo-option-history))
           (proc (apply 'start-process name nil name
                        "--mode" "gtp" "--quiet"
                        (split-string args)))
           (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)))
                                   19))))
           (user-color (if (string-match "--color" args)
                           (let ((start (match-end 0)))
                             (string-match "\\(black\\|white\\)" args start)
                             (match-string 0 args))
                         "black"))
           (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)))
                       0))
           (passes 0)
           snap morgue)
      (mapcar (lambda (sym)
                (put 'gnugo sym (eval sym)))
              '(proc bbuf board-cols user-color gnugo-color handicap passes
                     snap morgue))
      (unless (= 0 handicap)
        (gnugo-synchronous-send/return (concat "fixed_handicap " handicap)))
      ;;(with-current-buffer cbuf (set-marker (process-mark proc) (point)))
      (set-process-sentinel proc 'gnugo-sentinel)
      (gnugo-refresh))
    ;; set it all up
    (gnugo-board-mode)
    ;; first move
    (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)))))

;;;---------------------------------------------------------------------------
;;; Load-time actions

(setq gnugo-board-mode-map nil)         ; zonk me

(unless gnugo-board-mode-map
  (setq gnugo-board-mode-map (make-sparse-keymap))
  (suppress-keymap gnugo-board-mode-map)
  (mapcar (lambda (pair)
            (define-key gnugo-board-mode-map (car pair) (cdr pair)))
          '(("?"        . describe-mode)
            ("\C-m"     . gnugo-move)
            (" "        . gnugo-move)
            ("P"        . gnugo-pass)
            ("R"        . (lambda () (interactive)
                            (if (y-or-n-p "Resign? ")
                                (gnugo-cleanup)
                              (message "(not resigning)"))))
            ("q"        . (lambda () (interactive)
                            (if (y-or-n-p "Quit? ")
                                (gnugo-cleanup)
                              (message "(not quitting)"))))
            ("Q"        . gnugo-cleanup)
            ("\C-l"     . gnugo-refresh)
            ("\M-_"     . gnugo-bury)
            ("_"        . gnugo-bury)
            ("w"        . gnugo-worm-stones)
            ("W"        . gnugo-worm-data)
            ("d"        . gnugo-dragon-stones)
            ("D"        . gnugo-dragon-data)
            ("t"        . gnugo-toggle-dead-group)
            ("!"        . gnugo-estimate-score)
            (":"        . gnugo-command))))

(provide 'gnugo)

;;; gnugo.el,v1.15 ends here