Move from go to gnugo
This commit is contained in:
Gergely Polonkai
parent
ef6c0c41f2
commit
b8052b9da2
|
|
@ -0,0 +1,5 @@
|
|||
;;; .dir-locals.el
|
||||
|
||||
((emacs-lisp-mode . ((indent-tabs-mode . nil))))
|
||||
|
||||
;;; .dir-locals.el ends here
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -0,0 +1,82 @@
|
|||
HACKING gnugo -*- org -*-
|
||||
|
||||
This file is both a guide for newcomers and a todo list for oldstayers.
|
||||
|
||||
* next
|
||||
*** newbie support
|
||||
***** "don't panic" button :-D
|
||||
***** on gnugo.el load, check [[file:gnugo.el::defvar.gnugo-program][gnugo-program]], set "ready" state
|
||||
***** rat concessions :-/
|
||||
***** (?) ootb ‘gnugo-image-display-mode’ in ‘gnugo-start-game-hook’
|
||||
* fix bugs
|
||||
*** empty tree from many back/forw
|
||||
***** intermittent, grr
|
||||
***** manifests as ‘()’ (empty list) in .sgf (on write)
|
||||
*** {next,previous}-line weirdness in the presence of images
|
||||
*** no error-handling in SGF parsing
|
||||
* performance
|
||||
*** ‘compare-strings’ approach too clever/slow :-/
|
||||
*** cache frolic fruits
|
||||
* ideas / wishlist
|
||||
*** wrap GTP ‘loadsgf’ completely
|
||||
*** revamp image support
|
||||
***** DONE zonk ‘require’
|
||||
***** define simple API
|
||||
*** talk GTP over the network
|
||||
(?) pending [[wrap GTP ‘loadsgf’ completely]]
|
||||
*** make gnugo (the external program) support query (read-only) thread
|
||||
*** extend GNUGO Board mode to manage another subprocess for analysis only
|
||||
*** command to label a position
|
||||
*** SGF tree traversal
|
||||
***** DONE monkey mind
|
||||
***** TODO monkey body
|
||||
*** "undo undo undoing"
|
||||
***** integrate Emacs undo, GTP undo, subgame branching
|
||||
***** (?) use [[file:../undo-tree/][../undo-tree/]]
|
||||
*** make buffer name format configurable (but enforce uniqueness)
|
||||
*** more tilde escapes for [[file:gnugo.el::defvar.gnugo-mode-line][gnugo-mode-line]]
|
||||
*** make veneration configurable (see also [[SVG display]])
|
||||
*** animation finery
|
||||
***** make more configurable
|
||||
***** lift same-color-stones-only restriction
|
||||
***** allow sequencing rather than lock-step
|
||||
***** include sound
|
||||
*** plunder el-go (grok [[info:eieio.info][EIEIO]] first)
|
||||
***** SVG display
|
||||
pending [[revamp image support]]
|
||||
***** (?) SGF support
|
||||
******* IR compat
|
||||
******* error handling
|
||||
***** (?) other "backends"
|
||||
pending [[talk GTP over the network]]
|
||||
*** [your hacking ideas here!]
|
||||
* tested with (newest first)
|
||||
| Emacs | GNU Go |
|
||||
|-----------+--------|
|
||||
| 24.3.50.3 | 3.8 |
|
||||
| ? | 3.6 |
|
||||
| ? | 3.4 |
|
||||
| ? | 3.3.15 |
|
||||
| 22.0.50 | ? |
|
||||
| 21.3 | ? |
|
||||
|-----------+--------|
|
||||
| <l> | <l> |
|
||||
* ChangeLog discipline
|
||||
*** based on [[info:standards#Change%20Logs][GNU Coding Standards]]
|
||||
*** commit-message format
|
||||
***** basic: TITLE LF LF [DISCUSSION...] LF LF CLASSIC
|
||||
***** short: TITLE-FRAGMENT "; nfc." [LF LF DISCUSSION...]
|
||||
*** don't bother w/ ChangeLog for "short" commit-message format
|
||||
* other conventions: see [[file:.dir-locals.el][.dir-locals.el]]
|
||||
* NEWS nostalgia
|
||||
(with-current-buffer (find-file "NEWS")
|
||||
(highlight-phrase "[0-9][.][0-9][.][0-9]+\\|[0-9]+[.][.][0-9]+"
|
||||
'hi-red-b))
|
||||
* etc
|
||||
#+odd
|
||||
|
||||
|
||||
Copyright (C) 2014 Free Software Foundation, Inc.
|
||||
|
||||
Copying and distribution of this file, with or without modification,
|
||||
are permitted provided the copyright notice and this notice are preserved.
|
||||
|
|
@ -0,0 +1,205 @@
|
|||
NEWS for gnugo.el (et al)
|
||||
See the end for copying conditions.
|
||||
|
||||
NB: "RCS: X..Y " means that the particular release includes
|
||||
changes in the RCS repo, revision 1.X through 1.Y (inclusive).
|
||||
|
||||
|
||||
- 3.0.0 | 2014-07-22
|
||||
- bugfixes
|
||||
- on write, use ‘\’ to escape certain chars
|
||||
- preserve whitespace for value type ‘text’
|
||||
- don't special-case property value type ‘none’
|
||||
- handle subtrees on write
|
||||
- display "resign" as "resign" in move history (amazing!)
|
||||
- avoid clobbering SGF property ‘EV’ on resignation
|
||||
- follow main line in subtrees on read
|
||||
- for ‘F’ forced PASS moves, keep subproc informed as well
|
||||
- proper support for ‘-l FILENAME’ / ‘--infile FILENAME’
|
||||
- dropped support for ‘gnugo-program’ of form "PROGRAM OPTIONS..."
|
||||
- dropped command: ‘t’ (gnugo-toggle-dead-group)
|
||||
- changes to ‘gnugo-xpms’
|
||||
- now a normal var, and not a feature
|
||||
- value can be a function to compute XPMs
|
||||
- ‘gnugo-image-display-mode’ replaces ‘gnugo-toggle-image-display-command’
|
||||
- ‘gnugo-grid-mode’ replaces ‘gnugo-toggle-grid’
|
||||
- PASS for SZ <= 19 normalized to "" on read, written as ""
|
||||
- ‘=’ also displays move number of the stone (if any) at that position
|
||||
- ‘C-u F’ adds the (abbreviated) blurb as a comment to the last node
|
||||
- new keybinding for ‘gnugo-undo-one-move’: M-u
|
||||
- you can play a move for GNU Go, e.g., after ‘M-u’
|
||||
- ‘gnugo-undo-one-move’ can optionally arrange for you to play next
|
||||
- new command: ‘S’ (gnugo-request-suggestion)
|
||||
- new command: ‘C’ (gnugo-comment)
|
||||
- new command: ‘o’ (gnugo-oops)
|
||||
- new command: ‘O’ (gnugo-okay)
|
||||
- new command: ‘L’ (gnugo-frolic-in-the-leaves)
|
||||
- new command: ‘C-c C-a’ (gnugo-assist-mode)
|
||||
- new command: ‘C-c C-z’ (gnugo-zombie-mode)
|
||||
- new var: gnugo-undo-reaction
|
||||
- new major mode: GNUGO Frolic (gnugo-frolic-mode)
|
||||
- separate feature/file: ‘gnugo-frolic’
|
||||
- ‘gnugo-frolic-in-the-leaves’ autoloaded
|
||||
- new support for dynamic XPM generation
|
||||
- separate feature/file: ‘gnugo-imgen’
|
||||
- func ‘gnugo-imgen-create-xpms’ suitable for ‘gnugo-xpms’ (see above)
|
||||
- GNUGO Board mode now derived from Special mode
|
||||
- position arg validated for direct GTP commands ‘undo’, ‘gg-undo’
|
||||
- undo commands no longer signal error on overkill
|
||||
- SGF prop ‘AP’ set only for modified gametrees
|
||||
- SGF I/O commands change ‘default-directory’
|
||||
- performance improvements
|
||||
- of interest to hackers (see source, BI => backward incompatible)
|
||||
- dropped var: ‘gnugo-inhibit-refresh’ (BI)
|
||||
- ‘gnugo/sgf-read-file’ renamed to ‘gnugo/sgf-create’ and enhanced
|
||||
- ‘:sgf-gametree’ internal representation inverted (BI)
|
||||
- ‘gnugo-magic-undo’ internalized
|
||||
- new func: ‘gnugo-current-player’
|
||||
- new hook: ‘gnugo-start-game-hook’
|
||||
- ‘gnugo-board-mode-hook’ now unsuitable for prop munging (BI)
|
||||
- changes to ‘gnugo-move-history’
|
||||
- dropped ‘(gnugo-move-history 'count)’ (BI)
|
||||
- returns last two moves w/ RSEL ‘two’
|
||||
- returns position of last placed stone w/ RSEL ‘bpos’ + 2nd arg COLOR
|
||||
|
||||
- 2.3.1 | 2014-02-27
|
||||
- portability fixes
|
||||
|
||||
- 2.3.0 | 2014-02-24
|
||||
- now part of ELPA, tweaked for GNU Emacs 24.x
|
||||
- dropped support for XEmacs and older Emacs
|
||||
- use ‘user-error’ for user errors
|
||||
- bugfixes
|
||||
- handle sudden jump in captured stones correctly
|
||||
- rename hook-communication var w/ "gnugo-" prefix
|
||||
- (w/ images) grid top/bottom row spacing
|
||||
- on SGF save/load indicate buffer not modified
|
||||
- documentation improvements
|
||||
- version numbering scheme documented: MAJOR.MINOR.PATCH
|
||||
- keybinding constructs for ‘gnugo’ and ‘gnugo-board-mode’
|
||||
- message for worm/dragon animation avoids underscore
|
||||
- new commands
|
||||
- ‘A’ (gnugo-switch-to-another)
|
||||
- ‘_’ and ‘M-_’ (gnugo-boss-is-near) -- was ‘bury-buffer’
|
||||
- new keybinding for ‘gnugo-undo-two-moves’: DEL
|
||||
|
||||
- 2.2.14 | 2008-03-03
|
||||
- start error message w/ a capital letter
|
||||
- use ‘(error "%s" X)’ instead of ‘(error X)’
|
||||
- improve ‘gnugo-animation-string’ docstring
|
||||
|
||||
- 2.2.13 | 2006-04-10
|
||||
- grid (letters and numbers) visibility can be toggled
|
||||
- display bug workaround
|
||||
- performance improvements
|
||||
|
||||
- 2.2.12 | 2006-04-06
|
||||
- bugfix: handle "" as "PASS"
|
||||
|
||||
- 2.2.11 | 2005-04-06
|
||||
- new mode-line specifier: ‘~m’
|
||||
- directory no longer accepted as SGF "file name"
|
||||
|
||||
- 2.2.10 | 2005-02-04
|
||||
- bugfix: detect "game over" more precisely
|
||||
- new command: ‘C-c C-p’ (gnugo-describe-internal-properties)
|
||||
- don't include comment in sgf write
|
||||
- set ‘AP’ (application) property in gametree
|
||||
|
||||
- 2.2.9 | 2004-12-29
|
||||
- backward-portability fix
|
||||
|
||||
- 2.2.8 | 2004-11-15
|
||||
- new command: ‘h’ (gnugo-move-history)
|
||||
- improve font-lock support
|
||||
- support "count of moves" SPEC via prefix-arg to ‘U’
|
||||
|
||||
- 2.2.7 | 2004-11-10
|
||||
- bugfix: inform backend of PASS
|
||||
- new command: ‘u’ (gnugo-undo-two-moves)
|
||||
|
||||
- 2.2.6 | 2004-11-05
|
||||
- new commands
|
||||
- ‘l’ (gnugo-read-sgf-file)
|
||||
- ‘U’ (lambda that calls ‘gnugo-magic-undo’)
|
||||
- doc improvements
|
||||
- make some load-time actions one-shot
|
||||
|
||||
- 2.2.5 | 2004-11-02
|
||||
- bugfix: make load-time actions referentially-transparent
|
||||
- require Emacs w/ ‘gethash’, ‘puthash’, ‘make-hash-table’
|
||||
|
||||
- 2.2.4 | 2004-11-01
|
||||
- backward-portability fixes
|
||||
|
||||
- 2.2.3 | 2004-10-30
|
||||
- backward-portability fixes
|
||||
- new command: ‘R’ (gnugo-resign)
|
||||
|
||||
- 2.2.2 | 2004-10-29
|
||||
- backward-portability fixes
|
||||
|
||||
- 2.2.1 | 2004-09-07
|
||||
- SGF bugfix: parse float correctly (for komi)
|
||||
- new command: ‘F’ (gnugo-display-final-score)
|
||||
- font-locking for "X", "O", "[xo]"
|
||||
|
||||
- 2.2.0 | 2004-08-30
|
||||
- uncluttered, letters and numbers hidden, board centered
|
||||
- buffer name shows last move and current player
|
||||
- mode-line customization (var ‘gnugo-mode-line’)
|
||||
- new commands
|
||||
- ‘=’ -- display current position in echo area
|
||||
- ‘s’ (gnugo-write-sgf-file)
|
||||
- program option customization (var ‘gnugo-program’)
|
||||
- new hooks
|
||||
- ‘gnugo-post-move-hook’
|
||||
- ‘gnugo-board-mode-hook’
|
||||
- multiple independent buffers/games
|
||||
- XPM set can be changed on the fly (global and/or local)
|
||||
- RCS: 25..26 (1.24-1.26 diff posted 2003-01-28)
|
||||
|
||||
- 2.1.0 | 2003-01-10
|
||||
- doc fixes
|
||||
- add XPM image support
|
||||
- new keybinding: ‘;’ (gnugo-command)
|
||||
- new commands:
|
||||
- ‘i’ -- toggle image display
|
||||
- ‘mouse-down-1’ (gnugo-mouse-move)
|
||||
- ‘mouse-down-3’ (gnugo-mouse-pass)
|
||||
- ‘gnugo-command’ rewrite
|
||||
- RCS: 19..24
|
||||
|
||||
- 2.0.1 | 2002-11-16
|
||||
- more docstrings
|
||||
- say "GNU Go" instead of "GNU GO"
|
||||
- reverse output order of captured stones
|
||||
- new commands: ‘_’ and ‘M-_’ (bury-buffer)
|
||||
- simplified buffer management
|
||||
- RCS: 15..18
|
||||
|
||||
- 2.0.0 | 2002-11-15
|
||||
- rewrite to use Go Text Protocol
|
||||
- bugfix: don't set process coding system
|
||||
- handle change in process status
|
||||
- new user var: ‘gnugo-option-history’
|
||||
- use calculated screen columns
|
||||
- improve error handling in ‘gnugo-cleanup’
|
||||
- new command: ‘:’ (gnugo-command)
|
||||
- resume game if in progress, w/ confirmation
|
||||
- new command: ‘M-_’ (gnugo-bury)
|
||||
- autoload gnugo.el on command ‘gnugo’
|
||||
- doc improvements
|
||||
- RCS: 1..14
|
||||
|
||||
|
||||
Local Variables:
|
||||
mode: outline
|
||||
outline-regexp: "\\([ ][ ]\\)*- "
|
||||
End:
|
||||
|
||||
_____________________________________________________________________
|
||||
Copyright (C) 2014 Free Software Foundation, Inc.
|
||||
|
||||
Copying and distribution of this file, with or without modification,
|
||||
are permitted provided the copyright notice and this notice are preserved.
|
||||
|
|
@ -0,0 +1,6 @@
|
|||
This directory contains gnugo.el and other files.
|
||||
These work w/ GNU Go:
|
||||
|
||||
http://www.gnu.org/software/gnugo
|
||||
|
||||
and any other program that speaks the Go Text Protocol.
|
||||
|
|
@ -0,0 +1,94 @@
|
|||
;;; gnugo-autoloads.el --- automatically extracted autoloads
|
||||
;;
|
||||
;;; Code:
|
||||
(add-to-list 'load-path (directory-file-name (or (file-name-directory #$) (car load-path))))
|
||||
|
||||
;;;### (autoloads nil "gnugo" "gnugo.el" (22505 22848 889648 864000))
|
||||
;;; Generated autoloads from gnugo.el
|
||||
|
||||
(autoload 'gnugo "gnugo" "\
|
||||
Run gnugo in a buffer, or resume a game in progress.
|
||||
If there is already a game in progress you may resume it instead
|
||||
of starting a new one. Prefix arg means skip the game-in-progress
|
||||
check and start a new game straight away.
|
||||
|
||||
Before starting, Emacs queries you for additional command-line
|
||||
options (Emacs supplies \"--mode gtp --quiet\" automatically).
|
||||
|
||||
Note that specifying \"--infile FILENAME\" (or, \"-l FILENAME\")
|
||||
silently clobbers certain other options, such as \"--color\".
|
||||
For details, see info node `(gnugo) Invoking GNU Go'.
|
||||
|
||||
\\<gnugo-board-mode-map>
|
||||
To play, use \\[gnugo-move] to place a stone or \\[gnugo-pass] to pass.
|
||||
See `gnugo-board-mode' for a full list of commands.
|
||||
|
||||
\(fn &optional NEW-GAME)" t nil)
|
||||
|
||||
;;;***
|
||||
|
||||
;;;### (autoloads nil "gnugo-frolic" "gnugo-frolic.el" (22505 22848
|
||||
;;;;;; 869648 768000))
|
||||
;;; Generated autoloads from gnugo-frolic.el
|
||||
|
||||
(autoload 'gnugo-frolic-in-the-leaves "gnugo-frolic" "\
|
||||
Display the game tree in a *GNUGO Frolic* buffer.
|
||||
This looks something like:
|
||||
|
||||
1 B -- E7 E7 E7 E7
|
||||
2 W -- K10 K10 K10 K10
|
||||
3 B -- E2 E2 E2 E2
|
||||
4 W -- J3 J3 J3 J3
|
||||
5 B -- A6 A6 A6 A6
|
||||
6 W -- C9 C9 C9 C9
|
||||
│
|
||||
├─────┬─────┐
|
||||
│ │ │
|
||||
7 B -- H7 !B8 C8 C8
|
||||
│
|
||||
├─────┐
|
||||
│ │
|
||||
8 W -- D9 D9 D9 E9
|
||||
9 B -- H8 H8
|
||||
10 W -- PASS PASS
|
||||
11 B -- H5 PASS
|
||||
12 W -- PASS
|
||||
13 B -- *PASS
|
||||
|
||||
with 0, 1, ... N (in this case N is 3) in the header line
|
||||
to indicate the branches. Branch 0 is the \"main line\".
|
||||
Point (* in this example) indicates the current position,
|
||||
\"!\" indicates comment properties (e.g., B8, branch 1),
|
||||
and moves not actually on the game tree (e.g., E7, branch 3)
|
||||
are dimmed. Type \\[describe-mode] in that buffer for details.
|
||||
|
||||
\(fn)" t nil)
|
||||
|
||||
;;;***
|
||||
|
||||
;;;### (autoloads nil "gnugo-imgen" "gnugo-imgen.el" (22505 22848
|
||||
;;;;;; 897648 834000))
|
||||
;;; Generated autoloads from gnugo-imgen.el
|
||||
|
||||
(autoload 'gnugo-imgen-create-xpms "gnugo-imgen" "\
|
||||
Return a list of XPM images suitable for BOARD-SIZE.
|
||||
The size and style of the images are determined by
|
||||
`gnugo-imgen-sizing-function' (rounded down to an even number)
|
||||
and `gnugo-imgen-style', respectively. See `gnugo-xpms'.
|
||||
|
||||
The returned list is cached; see also `gnugo-imgen-clear-cache'.
|
||||
|
||||
\(fn BOARD-SIZE)" nil nil)
|
||||
|
||||
;;;***
|
||||
|
||||
;;;### (autoloads nil nil ("gnugo-pkg.el") (22505 22848 885648 885000))
|
||||
|
||||
;;;***
|
||||
|
||||
;; Local Variables:
|
||||
;; version-control: never
|
||||
;; no-byte-compile: t
|
||||
;; no-update-autoloads: t
|
||||
;; End:
|
||||
;;; gnugo-autoloads.el ends here
|
||||
|
|
@ -0,0 +1,509 @@
|
|||
;;; gnugo-frolic.el --- gametree in a buffer -*- lexical-binding: t -*-
|
||||
|
||||
;; Copyright (C) 2014 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Thien-Thi Nguyen <ttn@gnu.org>
|
||||
;; Maintainer: Thien-Thi Nguyen <ttn@gnu.org>
|
||||
|
||||
;; This program is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, 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 for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'cl-lib)
|
||||
(require 'gnugo)
|
||||
(require 'ascii-art-to-unicode) ; for `aa2u'
|
||||
|
||||
(defvar gnugo-frolic-mode-map
|
||||
(let ((map (make-sparse-keymap)))
|
||||
(suppress-keymap map)
|
||||
(mapc (lambda (pair)
|
||||
(define-key map (car pair) (cdr pair)))
|
||||
'(("q" . gnugo-frolic-quit)
|
||||
("Q" . gnugo-frolic-quit)
|
||||
("\C-q" . gnugo-frolic-quit)
|
||||
("C" . gnugo-frolic-quit) ; like ‘View-kill-and-leave’
|
||||
("\C-b" . gnugo-frolic-backward-branch)
|
||||
("\C-f" . gnugo-frolic-forward-branch)
|
||||
("\C-p" . gnugo-frolic-previous-move)
|
||||
("\C-n" . gnugo-frolic-next-move)
|
||||
("t" . gnugo-frolic-tip-move)
|
||||
("j" . gnugo-frolic-exchange-left)
|
||||
("J" . gnugo-frolic-rotate-left)
|
||||
("k" . gnugo-frolic-exchange-right)
|
||||
("K" . gnugo-frolic-rotate-right)
|
||||
("\C-m" . gnugo-frolic-set-as-main-line)
|
||||
("\C-\M-p" . gnugo-frolic-prune-branch)
|
||||
("o" . gnugo-frolic-return-to-origin)))
|
||||
map)
|
||||
"Keymap for GNUGO Frolic mode.")
|
||||
|
||||
(defvar gnugo-frolic-parent-buffer nil)
|
||||
(defvar gnugo-frolic-origin nil)
|
||||
|
||||
(define-derived-mode gnugo-frolic-mode special-mode "GNUGO Frolic"
|
||||
"A special mode for manipulating a GNUGO gametree."
|
||||
(setq truncate-lines t)
|
||||
(buffer-disable-undo))
|
||||
|
||||
(defun gnugo-frolic-quit ()
|
||||
"Kill GNUGO Frolic buffer and switch to its parent buffer."
|
||||
(interactive)
|
||||
(let ((bye (current-buffer)))
|
||||
(switch-to-buffer (when (buffer-live-p gnugo-frolic-parent-buffer)
|
||||
gnugo-frolic-parent-buffer))
|
||||
(kill-buffer bye)))
|
||||
|
||||
(defun gnugo-frolic-return-to-origin ()
|
||||
"Move point to the board's current position."
|
||||
(interactive)
|
||||
(if (not gnugo-frolic-origin)
|
||||
(message "No origin")
|
||||
(goto-char gnugo-frolic-origin)
|
||||
(recenter (- (count-lines (line-beginning-position)
|
||||
(point-max))))))
|
||||
|
||||
;;;###autoload
|
||||
(defun gnugo-frolic-in-the-leaves ()
|
||||
"Display the game tree in a *GNUGO Frolic* buffer.
|
||||
This looks something like:
|
||||
|
||||
1 B -- E7 E7 E7 E7
|
||||
2 W -- K10 K10 K10 K10
|
||||
3 B -- E2 E2 E2 E2
|
||||
4 W -- J3 J3 J3 J3
|
||||
5 B -- A6 A6 A6 A6
|
||||
6 W -- C9 C9 C9 C9
|
||||
│
|
||||
├─────┬─────┐
|
||||
│ │ │
|
||||
7 B -- H7 !B8 C8 C8
|
||||
│
|
||||
├─────┐
|
||||
│ │
|
||||
8 W -- D9 D9 D9 E9
|
||||
9 B -- H8 H8
|
||||
10 W -- PASS PASS
|
||||
11 B -- H5 PASS
|
||||
12 W -- PASS
|
||||
13 B -- *PASS
|
||||
|
||||
with 0, 1, ... N (in this case N is 3) in the header line
|
||||
to indicate the branches. Branch 0 is the \"main line\".
|
||||
Point (* in this example) indicates the current position,
|
||||
\"!\" indicates comment properties (e.g., B8, branch 1),
|
||||
and moves not actually on the game tree (e.g., E7, branch 3)
|
||||
are dimmed. Type \\[describe-mode] in that buffer for details."
|
||||
(interactive)
|
||||
(let* ((buf (get-buffer-create (concat (gnugo-get :diamond)
|
||||
"*GNUGO Frolic*")))
|
||||
(from (or gnugo-frolic-parent-buffer
|
||||
(current-buffer)))
|
||||
;; todo: use defface once we finally succumb to ‘customize’
|
||||
(dimmed-node-face (list :inherit 'default
|
||||
:foreground "gray50"))
|
||||
(tree (gnugo-get :sgf-gametree))
|
||||
(ends (copy-sequence (gnugo--tree-ends tree)))
|
||||
(mnum (gnugo--tree-mnum tree))
|
||||
(seen (gnugo--mkht))
|
||||
(soil (gnugo--mkht))
|
||||
(width (length ends))
|
||||
(lanes (number-sequence 0 (1- width)))
|
||||
(monkey (gnugo-get :monkey))
|
||||
(as-pos (gnugo--as-pos-func))
|
||||
(at (car (aref monkey 0)))
|
||||
(bidx (aref monkey 1))
|
||||
(valid (cl-map 'vector (lambda (end)
|
||||
(gethash (car end) mnum))
|
||||
ends))
|
||||
(max-move-num (apply 'max (append valid nil)))
|
||||
(inhibit-read-only t)
|
||||
finish)
|
||||
(cl-flet
|
||||
((on (node)
|
||||
(gethash node seen))
|
||||
(emph (s face)
|
||||
(propertize s 'face face))
|
||||
(fsi (properties fmt &rest args)
|
||||
(insert (apply 'propertize
|
||||
(apply 'format fmt args)
|
||||
properties))))
|
||||
;; breathe in
|
||||
(cl-loop
|
||||
for bx below width
|
||||
do (cl-loop
|
||||
with fork
|
||||
for node in (aref ends bx)
|
||||
do (if (setq fork (on node))
|
||||
(cl-flet
|
||||
((tip-p (bix)
|
||||
;; todo: ignore non-"move" nodes
|
||||
(eq node (car (aref ends bix))))
|
||||
(link (other)
|
||||
(cl-pushnew other (gethash node soil))))
|
||||
(unless (tip-p bx)
|
||||
(unless (tip-p fork)
|
||||
(link fork))
|
||||
(link bx)))
|
||||
(puthash node bx seen))
|
||||
until fork))
|
||||
;; breathe out
|
||||
(switch-to-buffer buf)
|
||||
(gnugo-frolic-mode)
|
||||
(erase-buffer)
|
||||
(setq header-line-format
|
||||
(let ((full (concat
|
||||
(make-string 11 ?\s)
|
||||
(mapconcat (lambda (n)
|
||||
(format "%-5s" n))
|
||||
lanes
|
||||
" "))))
|
||||
`((:eval
|
||||
(funcall
|
||||
,(lambda ()
|
||||
(cl-flet
|
||||
((sp (w) (propertize
|
||||
" " 'display
|
||||
`(space :width ,w))))
|
||||
(concat
|
||||
(when (eq 'left scroll-bar-mode)
|
||||
(let ((w (or scroll-bar-width
|
||||
(frame-parameter
|
||||
nil 'scroll-bar-width)))
|
||||
(cw (frame-char-width)))
|
||||
(sp (if w
|
||||
(/ w cw)
|
||||
2))))
|
||||
(let ((fc (fringe-columns 'left t)))
|
||||
(unless (zerop fc)
|
||||
(sp fc)))
|
||||
(condition-case nil
|
||||
(substring full (window-hscroll))
|
||||
(error ""))))))))))
|
||||
(set (make-local-variable 'gnugo-frolic-parent-buffer) from)
|
||||
(set (make-local-variable 'gnugo-state)
|
||||
(buffer-local-value 'gnugo-state from))
|
||||
(cl-loop
|
||||
with props
|
||||
for n ; move number
|
||||
from max-move-num downto 1
|
||||
do (setq props (list 'n n))
|
||||
do
|
||||
(cl-loop
|
||||
with (move forks br)
|
||||
initially (progn
|
||||
(goto-char (point-min))
|
||||
(fsi props
|
||||
"%3d %s -- "
|
||||
n (aref ["W" "B"] (logand 1 n))))
|
||||
for bx below width
|
||||
do (let* ((node (unless (< (aref valid bx) n)
|
||||
;; todo: ignore non-"move" nodes
|
||||
(pop (aref ends bx))))
|
||||
(zow `(bx ,bx ,@props))
|
||||
(ok (when node
|
||||
(= bx (on node))))
|
||||
(comment (when ok
|
||||
(cdr (assq :C node))))
|
||||
(s (cond ((not node) "")
|
||||
((not (setq move (gnugo--move-prop node))) "-")
|
||||
(t (funcall as-pos (cdr move))))))
|
||||
(when comment
|
||||
(push comment zow)
|
||||
(push 'help-echo zow))
|
||||
(when (and ok (setq br (gethash node soil)))
|
||||
(push (cons bx (sort br '<))
|
||||
forks))
|
||||
(fsi zow
|
||||
"%c%-5s"
|
||||
(if comment ?! ?\s)
|
||||
(cond ((and (eq at node)
|
||||
(or ok (= bx bidx)))
|
||||
(when (= bx bidx)
|
||||
(setq finish (point-marker)))
|
||||
(emph s (list :inherit 'default
|
||||
:foreground (frame-parameter
|
||||
nil 'cursor-color))))
|
||||
((not ok)
|
||||
(emph s dimmed-node-face))
|
||||
(t s))))
|
||||
finally do
|
||||
(when (progn (fsi props "\n")
|
||||
(setq forks (nreverse forks)))
|
||||
(let* ((margin (make-string 11 ?\s))
|
||||
(heads (mapcar #'car forks))
|
||||
(tails (mapcar #'cdr forks)))
|
||||
(cl-flet*
|
||||
((spaced (lanes func)
|
||||
(mapconcat func lanes " "))
|
||||
;; live to play ~ ~ ()
|
||||
;; play to learn (+) (-) . o O
|
||||
;; learn to live --ttn .M. _____U
|
||||
(dashed (lanes func) ;;; _____ ^^^^
|
||||
(mapconcat func lanes "-----"))
|
||||
(cnxn (lanes set)
|
||||
(spaced lanes (lambda (bx)
|
||||
(if (memq bx set)
|
||||
"|"
|
||||
" "))))
|
||||
(pad-unless (condition)
|
||||
(if condition
|
||||
""
|
||||
" "))
|
||||
(edge (set)
|
||||
(insert margin
|
||||
(cnxn lanes set)
|
||||
"\n")))
|
||||
(edge heads)
|
||||
(cl-loop
|
||||
with bef
|
||||
for ls on forks
|
||||
do (let* ((one (car ls))
|
||||
(yes (append
|
||||
;; "aft" heads
|
||||
(mapcar 'car (cdr ls))
|
||||
;; ‘bef’ tails
|
||||
(apply 'append (mapcar 'cdr bef))))
|
||||
(ord (sort one '<))
|
||||
(beg (car ord))
|
||||
(end (car (last ord))))
|
||||
(cl-flet
|
||||
((also (b e) (cnxn (number-sequence b e)
|
||||
yes)))
|
||||
(insert
|
||||
margin
|
||||
(also 0 (1- beg))
|
||||
(pad-unless (zerop beg))
|
||||
(dashed (number-sequence beg end)
|
||||
(lambda (bx)
|
||||
(cond ((memq bx ord) "+")
|
||||
((memq bx yes) "|")
|
||||
(t "-"))))
|
||||
(pad-unless (>= end width))
|
||||
(also (1+ end) (1- width))
|
||||
"\n"))
|
||||
(push one bef)))
|
||||
(edge (apply 'append tails))
|
||||
(aa2u (line-beginning-position
|
||||
(- (1+ (length forks))))
|
||||
(point))))))))
|
||||
(when finish
|
||||
(set (make-local-variable 'gnugo-frolic-origin) finish)
|
||||
(gnugo-frolic-return-to-origin))))
|
||||
|
||||
(defun gnugo--awake (how)
|
||||
;; Valid HOW elements:
|
||||
;; require-valid-branch
|
||||
;; (line . numeric)
|
||||
;; (line . move-string)
|
||||
;; (omit . [VAR...])
|
||||
;; Invalid elements blissfully ignored. :-D
|
||||
(let* ((tree (gnugo-get :sgf-gametree))
|
||||
(ends (gnugo--tree-ends tree))
|
||||
(width (length ends))
|
||||
(monkey (gnugo-get :monkey))
|
||||
(line (cl-case (cdr (assq 'line how))
|
||||
(numeric
|
||||
(count-lines (point-min) (line-beginning-position)))
|
||||
(move-string
|
||||
(save-excursion
|
||||
(when (re-search-backward "^ *[0-9]+ [BW]" nil t)
|
||||
(match-string 0))))
|
||||
(t nil)))
|
||||
(col (current-column))
|
||||
(a (unless (> 10 col)
|
||||
(let ((try (/ (- col 10)
|
||||
6)))
|
||||
(unless (<= width try)
|
||||
try))))
|
||||
(rv (list a)))
|
||||
(when (memq 'require-valid-branch how)
|
||||
(unless a
|
||||
(user-error "No branch here")))
|
||||
(cl-loop
|
||||
with omit = (cdr (assq 'omit how))
|
||||
for (name . value) in `((line . ,line)
|
||||
(bidx . ,(aref monkey 1))
|
||||
(monkey . ,monkey)
|
||||
(width . ,width)
|
||||
(ends . ,ends)
|
||||
(tree . ,tree))
|
||||
do (unless (memq name omit)
|
||||
(push value rv)))
|
||||
rv))
|
||||
|
||||
(defmacro gnugo--awakened (how &rest body)
|
||||
(declare (indent 1))
|
||||
`(cl-destructuring-bind
|
||||
,(cl-loop
|
||||
with omit = (cdr (assq 'omit how))
|
||||
with ls = (list 'a)
|
||||
for name in '(line bidx monkey
|
||||
width ends
|
||||
tree)
|
||||
do (unless (memq name omit)
|
||||
(push name ls))
|
||||
finally return ls)
|
||||
(gnugo--awake ',how)
|
||||
,@body))
|
||||
|
||||
(defsubst gnugo--move-to-bcol (bidx)
|
||||
(move-to-column (+ 10 (* 6 bidx))))
|
||||
|
||||
(defun gnugo--swiz (direction &optional blunt)
|
||||
(gnugo--awakened (require-valid-branch
|
||||
(omit tree)
|
||||
(line . numeric))
|
||||
(let* ((b (cond ((numberp blunt)
|
||||
(unless (and (< -1 blunt)
|
||||
(< blunt width))
|
||||
(user-error "No such branch: %s" blunt))
|
||||
blunt)
|
||||
(t (mod (+ direction a) width))))
|
||||
(flit (if blunt (lambda (n)
|
||||
(cond ((= n a) b)
|
||||
((= n b) a)
|
||||
(t n)))
|
||||
(lambda (n)
|
||||
(mod (+ direction n) width))))
|
||||
(was (copy-sequence ends))
|
||||
(new-bidx (funcall flit bidx)))
|
||||
(cl-loop
|
||||
for bx below width
|
||||
do (aset ends (funcall flit bx)
|
||||
(aref was bx)))
|
||||
(unless (= new-bidx bidx)
|
||||
(aset monkey 1 new-bidx))
|
||||
(gnugo-frolic-in-the-leaves)
|
||||
(goto-char (point-min))
|
||||
(forward-line line)
|
||||
(gnugo--move-to-bcol b))))
|
||||
|
||||
(defun gnugo-frolic-exchange-left ()
|
||||
"Exchange the current branch with the one to its left."
|
||||
(interactive)
|
||||
(gnugo--swiz -1 t))
|
||||
|
||||
(defun gnugo-frolic-rotate-left ()
|
||||
"Rotate all branches left."
|
||||
(interactive)
|
||||
(gnugo--swiz -1))
|
||||
|
||||
(defun gnugo-frolic-exchange-right ()
|
||||
"Exchange the current branch with the one to its right."
|
||||
(interactive)
|
||||
(gnugo--swiz 1 t))
|
||||
|
||||
(defun gnugo-frolic-rotate-right ()
|
||||
"Rotate all branches right."
|
||||
(interactive)
|
||||
(gnugo--swiz 1))
|
||||
|
||||
(defun gnugo-frolic-set-as-main-line ()
|
||||
"Make the current branch the main line."
|
||||
(interactive)
|
||||
(gnugo--swiz nil 0))
|
||||
|
||||
(defun gnugo-frolic-prune-branch ()
|
||||
"Remove the current branch from the gametree.
|
||||
This fails if there is only one branch in the tree.
|
||||
This fails if the monkey is on the current branch
|
||||
\(a restriction that will probably be lifted Real Soon Now\)."
|
||||
(interactive)
|
||||
(gnugo--awakened (require-valid-branch
|
||||
(line . move-string))
|
||||
;; todo: define meaningful eviction semantics; remove restriction
|
||||
(when (= a bidx)
|
||||
(user-error "Cannot prune with monkey on branch"))
|
||||
(when (= 1 width)
|
||||
(user-error "Cannot prune last remaining branch"))
|
||||
(let ((new (append ends nil)))
|
||||
;; Explicit ignorance avoids byte-compiler warning.
|
||||
(ignore (pop (nthcdr a new)))
|
||||
(gnugo--set-tree-ends tree new))
|
||||
(when (< a bidx)
|
||||
(aset monkey 1 (cl-decf bidx)))
|
||||
(gnugo-frolic-in-the-leaves)
|
||||
(when line
|
||||
(goto-char (point-min))
|
||||
(search-forward line)
|
||||
(gnugo--move-to-bcol (min a (- width 2))))))
|
||||
|
||||
(defun gnugo--sideways (backwards n)
|
||||
(gnugo--awakened ((omit tree ends monkey bidx line))
|
||||
(gnugo--move-to-bcol (mod (if backwards
|
||||
(- (or a width) n)
|
||||
(+ (or a -1) n))
|
||||
width))))
|
||||
|
||||
(defun gnugo-frolic-backward-branch (&optional n)
|
||||
"Move backward N (default 1) branches."
|
||||
(interactive "p")
|
||||
(gnugo--sideways t n))
|
||||
|
||||
(defun gnugo-frolic-forward-branch (&optional n)
|
||||
"Move forward N (default 1) branches."
|
||||
(interactive "p")
|
||||
(gnugo--sideways nil n))
|
||||
|
||||
(defun gnugo--vertical (n direction)
|
||||
(when (> 0 n)
|
||||
(setq n (- n)
|
||||
direction (- direction)))
|
||||
(gnugo--awakened ((line . numeric)
|
||||
(omit tree ends width monkey bidx))
|
||||
(let ((stop (if (> 0 direction)
|
||||
0
|
||||
(max 0 (1- (count-lines (point-min)
|
||||
(point-max))))))
|
||||
(col (unless a
|
||||
(current-column))))
|
||||
(cl-loop
|
||||
while (not (= line stop))
|
||||
do (cl-loop
|
||||
do (progn
|
||||
(forward-line direction)
|
||||
(cl-incf line direction))
|
||||
until (get-text-property (point) 'n))
|
||||
until (zerop (cl-decf n)))
|
||||
(if a
|
||||
(gnugo--move-to-bcol a)
|
||||
(move-to-column col)))))
|
||||
|
||||
(defun gnugo-frolic-previous-move (&optional n)
|
||||
"Move to the Nth (default 1) previous move."
|
||||
(interactive "p")
|
||||
(gnugo--vertical n -1))
|
||||
|
||||
(defun gnugo-frolic-next-move (&optional n)
|
||||
"Move to the Nth (default 1) next move."
|
||||
(interactive "p")
|
||||
(gnugo--vertical n 1))
|
||||
|
||||
(defun gnugo-frolic-tip-move ()
|
||||
"Move to the tip of the current branch."
|
||||
(interactive)
|
||||
(gnugo--awakened ((omit line bidx monkey width)
|
||||
require-valid-branch)
|
||||
(goto-char (point-max))
|
||||
(let ((mnum (gnugo--tree-mnum tree))
|
||||
(node (car (aref ends a))))
|
||||
(re-search-backward (format "^%3d" (gethash node mnum)))
|
||||
(gnugo--move-to-bcol a))))
|
||||
|
||||
;;;---------------------------------------------------------------------------
|
||||
;;; that's it
|
||||
|
||||
(provide 'gnugo-frolic)
|
||||
|
||||
;;; gnugo-frolic.el ends here
|
||||
|
|
@ -0,0 +1,247 @@
|
|||
;;; gnugo-imgen.el --- image generation -*- lexical-binding: t -*-
|
||||
|
||||
;; Copyright (C) 2014 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Thien-Thi Nguyen <ttn@gnu.org>
|
||||
;; Maintainer: Thien-Thi Nguyen <ttn@gnu.org>
|
||||
|
||||
;; This program is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, 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 for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; This file provides func `gnugo-imgen-create-xpms', suitable as
|
||||
;; value for `gnugo-xpms', and several variables to configure it:
|
||||
;;
|
||||
;; `gnugo-imgen-styles'
|
||||
;; `gnugo-imgen-style'
|
||||
;; `gnugo-imgen-sizing-function'
|
||||
;;
|
||||
;; There is also one command: `gnugo-imgen-clear-cache'.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'xpm)
|
||||
(require 'xpm-m2z)
|
||||
(require 'cl-lib)
|
||||
|
||||
(defvar gnugo-imgen-styles
|
||||
'((d-bump ; thanks
|
||||
:background "#FFFFC7C75252"
|
||||
:grid-lines "#000000000000"
|
||||
:circ-edges "#C6C6C3C3C6C6"
|
||||
:white-fill "#FFFFFFFFFFFF"
|
||||
:black-fill "#000000000000")
|
||||
(ttn ; this guy must live in a cave
|
||||
:background "#000000000000"
|
||||
:grid-lines "#AAAA88885555"
|
||||
:circ-edges "#888888888888"
|
||||
:white-fill "#CCCCCCCCCCCC"
|
||||
:black-fill "#444444444444"))
|
||||
"Alist of styles suitable for `gnugo-imgen-create-xpms'.
|
||||
The key is a symbol naming the style. The value is a plist.
|
||||
Here is a list of recognized keywords and their meanings:
|
||||
|
||||
:background -- string that names a color in XPM format, such as
|
||||
:grid-lines \"#000000000000\" or \"black\"; the special string
|
||||
:circ-edges \"None\" makes that component transparent
|
||||
:white-fill
|
||||
:black-fill
|
||||
|
||||
All keywords are required and color values cannot be nil.
|
||||
This restriction may be lifted in the future.")
|
||||
|
||||
(defvar gnugo-imgen-style nil
|
||||
"Which style in `gnugo-imgen-styles' to use.
|
||||
If nil, `gnugo-imgen-create-xpms' defaults to the first one.")
|
||||
|
||||
(defvar gnugo-imgen-sizing-function 'gnugo-imgen-fit-window-height
|
||||
"Function to compute XPM image size from board size.
|
||||
This is called with one arg, integer BOARD-SIZE, and should return
|
||||
a number (float or integer), the number of pixels for the side of
|
||||
a square position on the board. A value less than 8 is taken as 8.")
|
||||
|
||||
(defvar gnugo-imgen-cache (make-hash-table :test 'equal))
|
||||
|
||||
(defun gnugo-imgen-clear-cache ()
|
||||
"Clear the cache."
|
||||
(interactive)
|
||||
(clrhash gnugo-imgen-cache))
|
||||
|
||||
(defun gnugo-imgen-fit-window-height (board-size)
|
||||
"Return the dimension (in pixels) of a square for BOARD-SIZE.
|
||||
This uses the TOP and BOTTOM components as returned by
|
||||
`window-inside-absolute-pixel-edges' and subtracts twice
|
||||
the `frame-char-height' (to leave space for the grid)."
|
||||
(cl-destructuring-bind (L top R bot)
|
||||
(window-inside-absolute-pixel-edges)
|
||||
(ignore L R)
|
||||
(/ (float (- bot top (* 2 (frame-char-height))))
|
||||
board-size)))
|
||||
|
||||
(defconst gnugo-imgen-palette '((32 . :background)
|
||||
(?. . :grid-lines)
|
||||
(?X . :circ-edges)
|
||||
(?- . :black-fill)
|
||||
(?+ . :white-fill)))
|
||||
|
||||
(defun gnugo-imgen-create-xpms-1 (square style)
|
||||
(let* ((kws (mapcar 'cdr gnugo-imgen-palette))
|
||||
(roles (mapcar 'symbol-name kws))
|
||||
(palette (cl-loop
|
||||
for px in (mapcar 'car gnugo-imgen-palette)
|
||||
for role in roles
|
||||
collect (cons px (format "s %s" role))))
|
||||
(resolved (cl-loop
|
||||
with parms = (copy-sequence style)
|
||||
for role in roles
|
||||
for kw in kws
|
||||
collect (cons role (plist-get parms kw))))
|
||||
(sq-m1 (1- square))
|
||||
(half (/ sq-m1 2.0))
|
||||
(half-m1 (truncate (- half 0.5)))
|
||||
(half-p1 (truncate (+ half 0.5)))
|
||||
(background (make-vector 10 nil))
|
||||
(foreground (make-vector 4 nil))
|
||||
rv)
|
||||
(cl-flet
|
||||
((workbuf (n)
|
||||
(xpm-generate-buffer (format "%d_%d" n square)
|
||||
square square 1 palette))
|
||||
(replace-from (buffer)
|
||||
(erase-buffer)
|
||||
(insert-buffer-substring buffer)
|
||||
(xpm-grok t))
|
||||
(nine-from-four (N E W S)
|
||||
(list (list E S)
|
||||
(list E W S)
|
||||
(list W S)
|
||||
(list N E S)
|
||||
(list N E W S)
|
||||
(list N W S)
|
||||
(list N E )
|
||||
(list N E W )
|
||||
(list N W )))
|
||||
(mput-points (px ls)
|
||||
(dolist (coord ls)
|
||||
(apply 'xpm-put-points px coord))))
|
||||
;; background
|
||||
(cl-loop
|
||||
for place from 1 to 9
|
||||
for parts
|
||||
in (cl-flet*
|
||||
((vline (x y1 y2) (list (list x (cons y1 y2))))
|
||||
(v-expand (y1 y2) (append (vline half-m1 y1 y2)
|
||||
(vline half-p1 y1 y2)))
|
||||
(hline (y x1 x2) (list (list (cons x1 x2) y)))
|
||||
(h-expand (x1 x2) (append (hline half-m1 x1 x2)
|
||||
(hline half-p1 x1 x2))))
|
||||
(nine-from-four (v-expand 0 half-p1)
|
||||
(h-expand half-m1 sq-m1)
|
||||
(h-expand 0 half-p1)
|
||||
(v-expand half-m1 sq-m1)))
|
||||
do (aset background place
|
||||
(with-current-buffer (workbuf place)
|
||||
(dolist (part parts)
|
||||
(mput-points ?. part))
|
||||
(current-buffer))))
|
||||
;; foreground
|
||||
(cl-flet
|
||||
((circ (radius)
|
||||
(xpm-m2z-circle half half radius)))
|
||||
(cl-loop
|
||||
with stone = (circ (truncate half))
|
||||
with minim = (circ (/ square 9))
|
||||
for n below 4
|
||||
do (aset foreground n
|
||||
(with-current-buffer (workbuf n)
|
||||
(cl-flet
|
||||
((rast (form b w)
|
||||
(xpm-raster form ?X
|
||||
(if (> 2 n)
|
||||
b
|
||||
w))))
|
||||
(if (cl-evenp n)
|
||||
(rast stone ?- ?+)
|
||||
(replace-from (aref foreground (1- n)))
|
||||
(rast minim ?+ ?-))
|
||||
(current-buffer))))))
|
||||
;; do it
|
||||
(cl-flet
|
||||
((ok (place type finish)
|
||||
(goto-char 25)
|
||||
(delete-char (- (skip-chars-forward "^1-9")))
|
||||
(delete-char 1)
|
||||
(insert (format "%s%d" type place))
|
||||
(push (cons (cons type place)
|
||||
(funcall finish
|
||||
:ascent 'center
|
||||
:color-symbols resolved))
|
||||
rv)))
|
||||
(with-current-buffer (workbuf 5)
|
||||
(replace-from (aref background 5))
|
||||
(xpm-raster
|
||||
;; yes, using an ellipse is bizarre; no, we don't mind;
|
||||
;; maybe, ‘artist-ellipse-generate-quadrant’ is stable.
|
||||
(xpm-m2z-ellipse half half 4 4.5)
|
||||
?. t)
|
||||
(ok 5 'hoshi 'xpm-finish))
|
||||
(cl-loop
|
||||
for place from 1 to 9
|
||||
for decor in (let ((friends (cons half-m1 half-p1)))
|
||||
(nine-from-four (list friends 0)
|
||||
(list sq-m1 friends)
|
||||
(list 0 friends)
|
||||
(list friends sq-m1)))
|
||||
do (with-current-buffer (aref background place)
|
||||
(ok place 'empty 'xpm-finish))
|
||||
do (cl-flet
|
||||
((decorate (px)
|
||||
(mput-points px decor)))
|
||||
(cl-loop
|
||||
for n below 4
|
||||
for type in '(bmoku bpmoku wmoku wpmoku)
|
||||
do (with-current-buffer (aref foreground n)
|
||||
(decorate ?.)
|
||||
(ok place type 'xpm-as-xpm)
|
||||
(decorate 32)))))
|
||||
(mapc 'kill-buffer foreground)
|
||||
(nreverse rv)))))
|
||||
|
||||
;;;###autoload
|
||||
(defun gnugo-imgen-create-xpms (board-size)
|
||||
"Return a list of XPM images suitable for BOARD-SIZE.
|
||||
The size and style of the images are determined by
|
||||
`gnugo-imgen-sizing-function' (rounded down to an even number)
|
||||
and `gnugo-imgen-style', respectively. See `gnugo-xpms'.
|
||||
|
||||
The returned list is cached; see also `gnugo-imgen-clear-cache'."
|
||||
(let* ((square (let ((n (funcall gnugo-imgen-sizing-function
|
||||
board-size)))
|
||||
(unless (numberp n)
|
||||
(error "Invalid BOARD-SIZE: %s" board-size))
|
||||
(max 8 (logand (lognot 1) (truncate n)))))
|
||||
(style (or (unless gnugo-imgen-style (cdar gnugo-imgen-styles))
|
||||
(cdr (assq gnugo-imgen-style gnugo-imgen-styles))
|
||||
(error "No style selected")))
|
||||
(key (cons square style)))
|
||||
(or (gethash key gnugo-imgen-cache)
|
||||
(puthash key (gnugo-imgen-create-xpms-1 square style)
|
||||
gnugo-imgen-cache))))
|
||||
|
||||
;;;---------------------------------------------------------------------------
|
||||
;;; that's it
|
||||
|
||||
(provide 'gnugo-imgen)
|
||||
|
||||
;;; gnugo-imgen.el ends here
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
;; Generated package description from gnugo.el
|
||||
(define-package "gnugo" "3.0.0" "play GNU Go in a buffer" '((ascii-art-to-unicode "1.5") (xpm "1.0.1") (cl-lib "0.5")) :url "http://www.gnuvola.org/software/gnugo/" :keywords '("games" "processes"))
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -1,122 +0,0 @@
|
|||
;;; gtp-pipe.el --- GTP backend through a pipe
|
||||
|
||||
;; Copyright (C) 2013 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Eric Schulte <schulte.eric@gmail.com>
|
||||
;; Created: 2012-05-15
|
||||
;; Version: 0.1
|
||||
;; Keywords: game go sgf
|
||||
|
||||
;; This software is free software: you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; This software 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 for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Code:
|
||||
(require 'go-api)
|
||||
(require 'gtp)
|
||||
(require 'comint)
|
||||
|
||||
(defvar *gtp-pipe-board* nil
|
||||
"Board associated with the current gtp pipe process.")
|
||||
|
||||
(defvar *gtp-pipe-last* nil
|
||||
"Last move of the current game.")
|
||||
|
||||
(defvar *gtp-pipe-inhibit* nil
|
||||
"Prevent infinite loops of commands.")
|
||||
|
||||
(defun gtp-pipe-start (command)
|
||||
"Connect a `gtp-pipe' instance to the process created by COMMAND.
|
||||
Pass \"netcat -lp 6666\" as COMMAND to listen on a local port, or
|
||||
pass \"netcat localhost 6666\" to connect to a listening local
|
||||
port."
|
||||
(interactive "sgtp-pipe command: ")
|
||||
(pop-to-buffer (go-connect (make-instance 'gtp-pipe :command command))))
|
||||
|
||||
(defun gtp-pipe-process-filter (proc string)
|
||||
(go-re-cond string
|
||||
("^\\(black\\|white\\) \\(.*\\)$"
|
||||
(let ((color (go-re-cond (match-string 1 string)
|
||||
("black" :B)
|
||||
("white" :W)))
|
||||
(action (match-string 2 string)))
|
||||
(go-re-cond action
|
||||
("^pass" (let ((*gtp-pipe-inhibit* t)) (go-pass *gtp-pipe-board*)))
|
||||
("^resign" (let ((*gtp-pipe-inhibit* t)) (go-resign *gtp-pipe-board*)))
|
||||
(t (let ((move (gtp-to-pos color action)))
|
||||
(setf *gtp-pipe-last* move)
|
||||
(setf (go-move *gtp-pipe-board*) move))))))
|
||||
("^genmove_\\(black\\|white\\)"
|
||||
(message "gtp-pipe: %s's turn" (match-string 1 string)))
|
||||
("^last_move" (go-to-gtp-command *gtp-pipe-last*))
|
||||
("^quit" (let ((*gtp-pipe-inhibit* t)) (go-quit *gtp-pipe-board*)))
|
||||
("^undo" (let ((*gtp-pipe-inhibit* t)) (go-undo *gtp-pipe-board*)))
|
||||
("^string \\(.*\\)$" (message "gtp-pipe: %S" (match-string 1 string)))
|
||||
(t (message "gtp-pipe unknown command: %S" string))))
|
||||
|
||||
|
||||
;;; Class and interface
|
||||
(defclass gtp-pipe (gtp)
|
||||
((buffer :initarg :buffer :accessor buffer)
|
||||
(command :initarg :command :accessor command)))
|
||||
|
||||
(defmethod go-connect ((gtp-pipe gtp-pipe))
|
||||
(setf (buffer gtp-pipe)
|
||||
(let* ((cmd-&-args (split-string (command gtp-pipe) " " 'omit-nulls))
|
||||
(buf (apply #'make-comint "gtp-pipe"
|
||||
(car cmd-&-args) nil (cdr cmd-&-args))))
|
||||
(with-current-buffer buf
|
||||
(comint-mode)
|
||||
(set (make-local-variable '*gtp-pipe-last*) nil)
|
||||
(set (make-local-variable '*gtp-pipe-inhibit*) nil)
|
||||
(set (make-local-variable '*gtp-pipe-board*)
|
||||
(save-excursion
|
||||
(make-instance 'board
|
||||
:buffer (go-board gtp-pipe (make-instance 'sgf)))))
|
||||
(set-process-filter (get-buffer-process (current-buffer))
|
||||
(make-go-insertion-filter
|
||||
#'gtp-pipe-process-filter)))
|
||||
buf)))
|
||||
|
||||
(defmethod gtp-command ((gtp-pipe gtp-pipe) command)
|
||||
(with-current-buffer (buffer gtp-pipe)
|
||||
(unless *gtp-pipe-inhibit*
|
||||
(goto-char (process-mark (get-buffer-process (current-buffer))))
|
||||
(insert command)
|
||||
(comint-send-input))))
|
||||
|
||||
(defmethod go-comment ((gtp-pipe gtp-pipe))
|
||||
(signal 'unsupported-back-end-command (list gtp-pipe :comment)))
|
||||
|
||||
(defmethod set-go-comment ((gtp-pipe gtp-pipe) comment)
|
||||
(gtp-command gtp-pipe (format "string %s" comment)))
|
||||
|
||||
(defmethod go-color ((gtp-pipe gtp-pipe))
|
||||
(with-current-buffer (buffer gtp-pipe)
|
||||
(go-color *gtp-pipe-board*)))
|
||||
|
||||
(defmethod go-name ((gtp-pipe gtp-pipe)) "GTP pipe")
|
||||
(defmethod go-size ((gtp-pipe gtp-pipe))
|
||||
(read-from-minibuffer "GTP board size: " nil nil 'read))
|
||||
|
||||
(defmethod go-quit ((gtp-pipe gtp-pipe))
|
||||
(gtp-command gtp-pipe "quit")
|
||||
(with-current-buffer (buffer gtp-pipe)
|
||||
(signal-process (get-buffer-process) 'KILL)))
|
||||
|
||||
(defmethod go-player-name ((gtp-pipe gtp-pipe) color) "GTP pipe")
|
||||
|
||||
(defmethod set-player-name ((gtp-pipe gtp-pipe) color name)
|
||||
(signal 'unsupported-back-end-command (list gtp-pipe :set-player-name name)))
|
||||
|
||||
(provide 'gtp-pipe)
|
||||
;;; gtp-pipe.el ends here
|
||||
|
|
@ -1,164 +0,0 @@
|
|||
;;; gtp.el --- GTP GO back-end
|
||||
|
||||
;; Copyright (C) 2008 2012 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Eric Schulte <schulte.eric@gmail.com>
|
||||
;; Created: 2012-05-15
|
||||
;; Version: 0.1
|
||||
;; Keywords: game go sgf gtp gnugo
|
||||
|
||||
;; This software is free software: you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; This software 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 for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;; Commentary:
|
||||
|
||||
;; This file should be useful for translating between sgf and the GO
|
||||
;; text protocol (GTP) see http://www.lysator.liu.se/~gunnar/gtp/.
|
||||
;; The GMP command set may be implemented as an extension.
|
||||
;;
|
||||
;; see http://www.lysator.liu.se/~gunnar/gtp/gtp2-spec-draft2/gtp2-spec.html
|
||||
;;
|
||||
;; The following commands are required by GTP
|
||||
;; - protocol_version
|
||||
;; - name
|
||||
;; - version
|
||||
;; - known_command
|
||||
;; - list_commands
|
||||
;; - quit
|
||||
;; - boardsize
|
||||
;; - clear_board
|
||||
;; - komi
|
||||
;; - play
|
||||
;; - genmove
|
||||
|
||||
;; Code:
|
||||
(require 'go-api)
|
||||
|
||||
(defun gtp-expand-color (turn)
|
||||
(case turn
|
||||
(:B "black")
|
||||
(:W "white")
|
||||
(t (error "gtp: unknown turn %S" turn))))
|
||||
|
||||
(defun go-pos-to-gtp (pos)
|
||||
(format "%c%d" (num-to-char (1+ (car pos))) (1+ (cdr pos))))
|
||||
|
||||
(defun gtp-to-pos (color gtp)
|
||||
(cons color (cons :pos (cons (char-to-num (aref gtp 0))
|
||||
(1- (read (substring gtp 1)))))))
|
||||
|
||||
(defun go-to-gtp-command (element)
|
||||
"Convert an go ELEMENT to a gtp command."
|
||||
(let ((key (car element))
|
||||
(val (cdr element)))
|
||||
(case key
|
||||
(:B (format "black %s" (go-pos-to-gtp (aget (list val) :pos))))
|
||||
(:W (format "white %s" (go-pos-to-gtp (aget (list val) :pos))))
|
||||
((:SZ :S) (format "boardsize %s" val))
|
||||
(:KM (format "komi %s" val))
|
||||
(t nil))))
|
||||
|
||||
(defun gtp-territory (gtp color)
|
||||
(let ((output (ecase color
|
||||
(:B (gtp-command gtp "final_status_list black_territory"))
|
||||
(:W (gtp-command gtp "final_status_list white_territory")))))
|
||||
(mapcar (lambda (gtp-point) (gtp-to-pos color gtp-point))
|
||||
(mapcar #'symbol-name
|
||||
(read (format "(%s)" output))))))
|
||||
|
||||
|
||||
;;; Class and interface
|
||||
(defclass gtp nil nil "Class for the GTP GO GO back end.")
|
||||
|
||||
(defgeneric gtp-command (back-end command)
|
||||
"Send gtp COMMAND to OBJECT and return any output.")
|
||||
|
||||
(defmethod go-size ((gtp gtp))
|
||||
(read (gtp-command gtp "query_boardsize")))
|
||||
|
||||
(defmethod set-go-size ((gtp gtp) size)
|
||||
(gtp-command gtp (format "boardsize %d" size)))
|
||||
|
||||
(defmethod go-level ((gtp gtp))
|
||||
(signal 'unsupported-back-end-command (list gtp :go-level)))
|
||||
|
||||
(defmethod set-go-level ((gtp gtp) level)
|
||||
(gtp-command gtp (format "level %d" level)))
|
||||
|
||||
(defmethod go-name ((gtp gtp))
|
||||
(gtp-command gtp "name"))
|
||||
|
||||
(defmethod set-go-name ((gtp gtp) name)
|
||||
(signal 'unsupported-back-end-command (list gtp :set-name name)))
|
||||
|
||||
(defmethod go-move ((gtp gtp))
|
||||
(let* ((color (go-color gtp))
|
||||
(move (case color
|
||||
(:B (gtp-command gtp "genmove_black"))
|
||||
(:W (gtp-command gtp "genmove_white")))))
|
||||
(if (string= move "PASS")
|
||||
:pass
|
||||
(gtp-to-pos color move))))
|
||||
|
||||
(defmethod set-go-move ((gtp gtp) move)
|
||||
(gtp-command gtp (go-to-gtp-command move)))
|
||||
|
||||
(defmethod go-labels ((gtp gtp))
|
||||
(signal 'unsupported-back-end-command (list gtp :labels)))
|
||||
|
||||
(defmethod set-go-labels ((gtp gtp) labels)
|
||||
(signal 'unsupported-back-end-command (list gtp :set-labels labels)))
|
||||
|
||||
(defmethod go-comment ((gtp gtp))
|
||||
(signal 'unsupported-back-end-command (list gtp :comment)))
|
||||
|
||||
(defmethod set-go-comment ((gtp gtp) comment)
|
||||
(signal 'unsupported-back-end-command (list gtp :set-comment comment)))
|
||||
|
||||
(defmethod go-alt ((gtp gtp))
|
||||
(signal 'unsupported-back-end-command (list gtp :alt)))
|
||||
|
||||
(defmethod set-go-alt ((gtp gtp) alt)
|
||||
(signal 'unsupported-back-end-command (list gtp :set-alt alt)))
|
||||
|
||||
(defmethod go-color ((gtp gtp))
|
||||
(case (condition-case err
|
||||
(intern (car (split-string (gtp-command gtp "last_move"))))
|
||||
(error 'white)) ('white :B) ('black :W)))
|
||||
|
||||
(defmethod set-go-color ((gtp gtp) color)
|
||||
(signal 'unsupported-back-end-command (list gtp :set-color color)))
|
||||
|
||||
;; non setf'able generic functions
|
||||
(defmethod go-undo ((gtp gtp)) (gtp-command gtp "undo"))
|
||||
|
||||
(defmethod go-pass ((gtp gtp))
|
||||
(gtp-command gtp (format "%s pass" (gtp-expand-color (go-color gtp)))))
|
||||
|
||||
(defmethod go-resign ((gtp gtp))
|
||||
(gtp-command gtp (format "%s resign" (gtp-expand-color (go-color gtp)))))
|
||||
|
||||
(defmethod go-reset ((gtp gtp)) (gtp-command gtp "clear_board"))
|
||||
|
||||
(defmethod go-quit ((gtp gtp)) (gtp-command gtp "quit"))
|
||||
|
||||
(defmethod go-score ((gtp gtp)) (gtp-command gtp "final_score"))
|
||||
|
||||
(defmethod go-territory ((gtp gtp))
|
||||
(append (gtp-territory gtp :B) (gtp-territory gtp :W)))
|
||||
|
||||
(defmethod go-dead ((gtp gtp))
|
||||
(signal 'unsupported-back-end-command (list gtp :dead)))
|
||||
|
||||
(provide 'gtp)
|
||||
;;; gtp.el ends here
|
||||
|
|
@ -1,501 +0,0 @@
|
|||
;;; igs.el --- IGS GO back-end
|
||||
|
||||
;; Copyright (C) 2012-2013 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Eric Schulte <schulte.eric@gmail.com>
|
||||
;; Created: 2012-05-15
|
||||
;; Version: 0.1
|
||||
;; Keywords: game go sgf igs
|
||||
|
||||
;; This software is free software: you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; This software 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 for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;; Commentary:
|
||||
|
||||
;; http://www.pandanet.co.jp/English/commands/term/Summary.html
|
||||
|
||||
;; Code:
|
||||
(require 'go-api)
|
||||
(require 'list-buffer)
|
||||
|
||||
(defvar igs-ignore-shouts t
|
||||
"Ignore shouts on the IGS server.")
|
||||
|
||||
(defvar igs-telnet-command "telnet"
|
||||
"Telnet command used by igs.")
|
||||
|
||||
(defvar igs-server "igs.joyjoy.net"
|
||||
"Address of the IGS server.")
|
||||
|
||||
(defvar igs-port 6969
|
||||
"Port to use when connecting to an IGS server.")
|
||||
|
||||
(defvar igs-username "guest"
|
||||
"User name to use when connecting to an IGS server.")
|
||||
|
||||
(defvar igs-process-name "igs"
|
||||
"Name for the igs process.")
|
||||
|
||||
(defvar igs-server-ping-delay 300
|
||||
"Minimum time between pings to remind the IGS server we're still listening.")
|
||||
|
||||
(defvar igs-message-types
|
||||
'((:unknown . 0)
|
||||
(:automat . 35) ;; Automatch announcement
|
||||
(:autoask . 36) ;; Automatch accept
|
||||
(:choices . 38) ;; game choices
|
||||
(:clivrfy . 41) ;; Client verify message
|
||||
(:beep . 2) ;; \7 telnet
|
||||
(:board . 3) ;; Board being drawn
|
||||
(:down . 4) ;; The server is going down
|
||||
(:error . 5) ;; An error reported
|
||||
(:fil . 6) ;; File being sent
|
||||
(:games . 7) ;; Games listing
|
||||
(:help . 8) ;; Help file
|
||||
(:info . 9) ;; Generic info
|
||||
(:last . 10) ;; Last command
|
||||
(:kibitz . 11) ;; Kibitz strings
|
||||
(:load . 12) ;; Loading a game
|
||||
(:look_m . 13) ;; Look
|
||||
(:message . 14) ;; Message listing
|
||||
(:move . 15) ;; Move #:(B) A1
|
||||
(:observe . 16) ;; Observe report
|
||||
(:prompt . 1) ;; A Prompt (never)
|
||||
(:refresh . 17) ;; Refresh of a board
|
||||
(:saved . 18) ;; Stored command
|
||||
(:say . 19) ;; Say string
|
||||
(:score_m . 20) ;; Score report
|
||||
(:sgf_m . 34) ;; SGF variation
|
||||
(:shout . 21) ;; Shout string
|
||||
(:show . 29) ;; Shout string
|
||||
(:status . 22) ;; Current Game status
|
||||
(:stored . 23) ;; Stored games
|
||||
(:teach . 33) ;; teaching game
|
||||
(:tell . 24) ;; Tell string
|
||||
(:dot . 40) ;; your . string
|
||||
(:thist . 25) ;; Thist report
|
||||
(:tim . 26) ;; times command
|
||||
(:trans . 30) ;; Translation info
|
||||
(:ttt_board . 37) ;; tic tac toe
|
||||
(:who . 27) ;; who command
|
||||
(:undo . 28) ;; Undo report
|
||||
(:user . 42) ;; Long user report
|
||||
(:version . 39) ;; IGS Version
|
||||
(:yell . 32))) ;; Channel yelling
|
||||
|
||||
(defvar *igs-instance* nil
|
||||
"IGS instance associated with the current buffer.")
|
||||
|
||||
(defvar *igs-time-last-sent* nil
|
||||
"Time stamp of the last command sent.
|
||||
This is used to re-send messages to keep the IGS server from timing out.")
|
||||
|
||||
(defvar *igs-last-command* nil
|
||||
"Last command sent to the IGS process.")
|
||||
|
||||
(defvar *igs-games* nil
|
||||
"List holding the current games on the IGS server.")
|
||||
|
||||
(defvar *igs-current-game* nil
|
||||
"Number of the current IGS game (may change frequently).")
|
||||
|
||||
|
||||
;;; Class and interface
|
||||
(defclass igs ()
|
||||
((buffer :initarg :buffer :accessor buffer :initform nil)
|
||||
;; number of an observed IGS game
|
||||
(number :initarg :number :accessor number :initform nil)
|
||||
(active :initarg :active :accessor active :initform t)))
|
||||
|
||||
(defmethod go-connect ((igs igs)) (igs-connect igs))
|
||||
|
||||
(defmacro with-igs (igs &rest body)
|
||||
(declare (indent 1))
|
||||
`(with-current-buffer (buffer ,igs) ,@body))
|
||||
|
||||
(defmethod go-level ((igs igs))
|
||||
(signal 'unsupported-back-end-command (list igs :level)))
|
||||
|
||||
(defmethod set-go-level ((igs igs) level)
|
||||
(signal 'unsupported-back-end-command (list igs :set-level level)))
|
||||
|
||||
(defmethod go-size ((igs igs))
|
||||
(with-igs igs (aget (igs-current-game) :size)))
|
||||
|
||||
(defmethod set-go-size ((igs igs) size)
|
||||
(signal 'unsupported-back-end-command (list igs :set-size size)))
|
||||
|
||||
(defmethod go-name ((igs igs))
|
||||
(with-igs igs (let ((game (igs-current-game)))
|
||||
(format "%s(%s) vs %s(%s)"
|
||||
(aget game :white-name)
|
||||
(aget game :white-rank)
|
||||
(aget game :black-name)
|
||||
(aget game :black-rank)))))
|
||||
|
||||
(defmethod set-go-name ((igs igs) name)
|
||||
(signal 'unsupported-back-end-command (list igs :set-name name)))
|
||||
|
||||
(defmethod go-move ((igs igs))
|
||||
(signal 'unsupported-back-end-command (list igs :move)))
|
||||
|
||||
(defmethod set-go-move ((igs igs) move)
|
||||
(signal 'unsupported-back-end-command (list igs :set-move move)))
|
||||
|
||||
(defmethod go-labels ((igs igs))
|
||||
(signal 'unsupported-back-end-command (list igs :labels)))
|
||||
|
||||
(defmethod set-go-labels ((igs igs) labels)
|
||||
(signal 'unsupported-back-end-command (list igs :set-labels labels)))
|
||||
|
||||
(defmethod go-comment ((igs igs))
|
||||
(signal 'unsupported-back-end-command (list igs :comment)))
|
||||
|
||||
(defmethod set-go-comment ((igs igs) comment)
|
||||
(signal 'unsupported-back-end-command (list igs :set-comment comment)))
|
||||
|
||||
(defmethod go-alt ((igs igs))
|
||||
(signal 'unsupported-back-end-command (list igs :alt)))
|
||||
|
||||
(defmethod set-go-alt ((igs igs) alt)
|
||||
(signal 'unsupported-back-end-command (list igs :set-alt alt)))
|
||||
|
||||
(defmethod go-color ((igs igs))
|
||||
(signal 'unsupported-back-end-command (list igs :color)))
|
||||
|
||||
(defmethod set-go-color ((igs igs) color)
|
||||
(signal 'unsupported-back-end-command (list igs :set-color color)))
|
||||
|
||||
(defmethod go-player-name ((igs igs) color)
|
||||
(with-igs igs (aget (igs-current-game)
|
||||
(case color
|
||||
(:W :white-name)
|
||||
(:B :black-name)))))
|
||||
|
||||
(defmethod set-go-player-name ((igs igs) color name)
|
||||
(signal 'unsupported-back-end-command (list igs :set-player-name color name)))
|
||||
|
||||
(defmethod go-player-time ((igs igs) color)
|
||||
(signal 'unsupported-back-end-command (list igs :player-time color)))
|
||||
|
||||
(defmethod set-go-player-time ((igs igs) color time)
|
||||
(signal 'unsupported-back-end-command (list igs :set-player-time color time)))
|
||||
|
||||
;; non setf'able generic functions
|
||||
(defmethod go-undo ((igs igs))
|
||||
(signal 'unsupported-back-end-command (list igs :undo)))
|
||||
|
||||
(defmethod go-pass ((igs igs))
|
||||
(signal 'unsupported-back-end-command (list igs :pass)))
|
||||
|
||||
(defmethod go-resign ((igs igs))
|
||||
(signal 'unsupported-back-end-command (list igs :resign)))
|
||||
|
||||
(defmethod go-reset ((igs igs))
|
||||
(signal 'unsupported-back-end-command (list igs :reset)))
|
||||
|
||||
(defmethod go-quit ((igs igs))
|
||||
(with-igs igs
|
||||
(if (number igs)
|
||||
(progn
|
||||
;; TOOD: ensure still on our server-side observation list
|
||||
;; (e.g., hasn't been removed after a resignation)
|
||||
(when (active igs)
|
||||
(igs-send (format "observe %d" (number igs))))
|
||||
(setf (number igs) nil))
|
||||
(igs-send "quit"))))
|
||||
|
||||
(defmethod go-score ((igs igs))
|
||||
(signal 'unsupported-back-end-command (list igs :score)))
|
||||
|
||||
(defmethod go-territory ((igs igs))
|
||||
(signal 'unsupported-back-end-command (list igs :territory)))
|
||||
|
||||
(defmethod go-dead ((igs igs))
|
||||
(signal 'unsupported-back-end-command (list igs :dead)))
|
||||
|
||||
(defmacro igs-w-proc (proc &rest body)
|
||||
(declare (indent 1))
|
||||
`(with-current-buffer (process-buffer proc) ,@body))
|
||||
(def-edebug-spec igs-w-proc (form body))
|
||||
|
||||
(defun igs-send (command)
|
||||
"Send string COMMAND to the IGS process in the current buffer."
|
||||
(goto-char (process-mark (get-buffer-process (current-buffer))))
|
||||
(insert command)
|
||||
(setq *igs-time-last-sent* (current-time))
|
||||
(setq *igs-last-command* (and (string-match "^\\([^ ]*\\)" command)
|
||||
(match-string 1 command)))
|
||||
(comint-send-input))
|
||||
|
||||
(defun igs-process-filter (proc string)
|
||||
(when (string-match "^\\([[:digit:]]+\\) \\(.+\\)$" string)
|
||||
(let* ((number (read (match-string 1 string)))
|
||||
(type (car (rassoc number igs-message-types)))
|
||||
(content (match-string 2 string)))
|
||||
(case type
|
||||
(:prompt
|
||||
(go-re-cond (or *igs-last-command* "")
|
||||
("^games" (igs-list-games *igs-instance* *igs-games*))
|
||||
(t nil))
|
||||
(setq *igs-last-command* nil))
|
||||
(:info
|
||||
(go-re-cond content
|
||||
;; Game NN: name1 vs name2 has adjourned.
|
||||
("^Game \\([0-9]*\\): .*adjourned.$"
|
||||
(igs-handle-adjournment (match-string 1 content)))
|
||||
;; {Game NN: name1 vs name2 : color resigns.}
|
||||
("^{Game \\([0-9]*\\): \\(Black\\|White\\) resigns.}$"
|
||||
(igs-handle-resignation (go-re-cond (match-string 2 content)
|
||||
("black" :black)
|
||||
("white" :white))))
|
||||
(t (unless (string= content "yes")
|
||||
(message "igs-info: %s" content)))))
|
||||
(:games (igs-w-proc proc (igs-handle-game content)))
|
||||
(:move (igs-w-proc proc (igs-handle-move content)))
|
||||
(:kibitz (message "igs-kibitz: %s" content))
|
||||
(:tell (igs-handle-tell content))
|
||||
(:beep nil)
|
||||
(:shout (unless igs-ignore-shouts (igs-handle-shout content)))
|
||||
(t (message "igs-unknown: [%s]%s" type content)))
|
||||
(when (and *igs-time-last-sent*
|
||||
(> (time-to-seconds (time-since *igs-time-last-sent*))
|
||||
igs-server-ping-delay))
|
||||
(igs-send "ayt")))))
|
||||
|
||||
(defun igs-connect (igs)
|
||||
"Open a connection to `igs-server'."
|
||||
(cl-flet ((wait (prompt)
|
||||
(message "IGS waiting for %S..." prompt)
|
||||
(while (and (goto-char (or comint-last-input-end (point-min)))
|
||||
(not (re-search-forward prompt nil t)))
|
||||
(accept-process-output proc))))
|
||||
(let ((buffer (apply 'make-comint
|
||||
igs-process-name
|
||||
igs-telnet-command nil
|
||||
(list igs-server (number-to-string igs-port)))))
|
||||
(setf (buffer igs) buffer)
|
||||
(with-current-buffer buffer
|
||||
(comint-mode)
|
||||
(set (make-local-variable '*igs-instance*) igs)
|
||||
(set (make-local-variable '*igs-last-command*) "")
|
||||
(set (make-local-variable '*igs-games*) nil)
|
||||
(set (make-local-variable '*igs-current-game*) nil)
|
||||
(set (make-local-variable '*go-partial-line*) nil)
|
||||
(set (make-local-variable '*igs-time-last-sent*) (current-time))
|
||||
(let ((proc (get-buffer-process (current-buffer))))
|
||||
(wait "^Login:")
|
||||
(goto-char (process-mark proc))
|
||||
(igs-send igs-username)
|
||||
(wait "^\#> ")
|
||||
(igs-toggle "client" t)
|
||||
(set-process-filter
|
||||
proc (make-go-insertion-filter #'igs-process-filter))))
|
||||
buffer)))
|
||||
|
||||
(defun igs-toggle (setting value)
|
||||
(igs-send (format "toggle %s %s" setting (if value "true" "false"))))
|
||||
|
||||
(defun igs-observe (game) (igs-send (format "observe %s" game)))
|
||||
|
||||
(defun igs-list-games (instance games)
|
||||
(lexical-let ((instance instance))
|
||||
(list-buffer-create
|
||||
"*igs-game-list*"
|
||||
(cl-mapcar #'cons
|
||||
(mapcar #'car games)
|
||||
(mapcar (curry #'mapcar #'cdr) (mapcar #'cdr games)))
|
||||
'("#" "white" "rk" "black" "rk" "move" "size" "H" "Komi" "by" "fr" "#")
|
||||
(lambda (row col)
|
||||
(let ((id (car (nth row *buffer-list*))))
|
||||
(with-igs instance (igs-observe id))))
|
||||
(lambda (row col)
|
||||
(message "refreshing games list...")
|
||||
(igs-get-games instance)))))
|
||||
|
||||
|
||||
;;; Specific handlers
|
||||
(defvar igs-player-name-re
|
||||
"[[:alpha:][:digit:]]+"
|
||||
"Regular expression used to match igs player name.")
|
||||
|
||||
(defvar igs-player-rating-re
|
||||
"[[:digit:]]+[kd]\\*?"
|
||||
"Regular expression used to match igs player rating.")
|
||||
|
||||
(defvar igs-player-game-info-re "([-[:digit:]]+ [-[:digit:]]+ [-[:digit:]]+)"
|
||||
"Regular expression used to match igs player game info.")
|
||||
|
||||
(defvar igs-player-re
|
||||
(format "\\(%s\\) +\\[ *\\(%s\\)\\]" igs-player-name-re igs-player-rating-re)
|
||||
"Regular expression used to parse igs player name and rating.")
|
||||
|
||||
(defvar igs-game-re
|
||||
(format
|
||||
"\\[\\([[:digit:]]+\\)\\] +%s +vs. +%s +\\((.+)\\) \\((.+)\\)[[:space:]]*$"
|
||||
igs-player-re igs-player-re)
|
||||
"Regular expression used to parse igs game listings.")
|
||||
|
||||
(defvar igs-move-piece-re
|
||||
"[[:digit:]]+(\\([WB]\\)): \\([[:alpha:]][[:digit:]]+\\)"
|
||||
"Regular expression used to match an IGS move.")
|
||||
|
||||
(defvar igs-move-time-re "TIME")
|
||||
|
||||
(defvar igs-move-props-re "GAMEPROPS")
|
||||
|
||||
(defvar igs-move-game-re
|
||||
(format "Game \\([[:digit:]]+\\) I: \\(%s\\) \\(%s\\) vs \\(%s\\) \\(%s\\)"
|
||||
igs-player-name-re igs-player-game-info-re
|
||||
igs-player-name-re igs-player-game-info-re)
|
||||
"Regular expression used to match Game updates.")
|
||||
|
||||
(defun igs-handle-game (game-string)
|
||||
;; [##] white name [ rk ] black name [ rk ] (Move size H Komi BY FR) (###)
|
||||
(when (string-match igs-game-re game-string)
|
||||
(let* ((num (match-string 1 game-string))
|
||||
(white-name (match-string 2 game-string))
|
||||
(white-rank (match-string 3 game-string))
|
||||
(black-name (match-string 4 game-string))
|
||||
(black-rank (match-string 5 game-string))
|
||||
(other1 (read (match-string 6 game-string)))
|
||||
(other2 (read (match-string 7 game-string))))
|
||||
(push `(,(read num)
|
||||
(:white-name . ,white-name)
|
||||
(:white-rank . ,white-rank)
|
||||
(:black-name . ,black-name)
|
||||
(:black-rank . ,black-rank)
|
||||
(:move . ,(nth 0 other1))
|
||||
(:size . ,(nth 1 other1))
|
||||
(:h . ,(nth 2 other1))
|
||||
(:komi . ,(nth 3 other1))
|
||||
(:by . ,(nth 4 other1))
|
||||
(:fr . ,(nth 5 other1))
|
||||
(:other . ,(car other2)))
|
||||
*igs-games*)
|
||||
;; update the game list buffer
|
||||
(when (get-buffer "*igs-game-list*")
|
||||
(save-excursion
|
||||
(set-buffer (get-buffer "*igs-game-list*"))
|
||||
(list-buffer-refresh))))))
|
||||
|
||||
(defun igs-handle-adjournment (number-string)
|
||||
(if (aget (igs-current-game) :board)
|
||||
(with-current-buffer (buffer (aget (igs-current-game) :board))
|
||||
(with-backends backend
|
||||
(when (equal (class-of backend) 'igs)
|
||||
(setf (active backend) nil))))
|
||||
(error "igs-handle-adjournment: no board!")))
|
||||
|
||||
(defun igs-handle-resignation (color)
|
||||
(if (aget (igs-current-game) :board)
|
||||
(progn
|
||||
(go-resign (aget (igs-current-game) :board))
|
||||
(with-current-buffer (buffer (aget (igs-current-game) :board))
|
||||
(with-backends backend
|
||||
(when (equal (class-of backend) 'igs)
|
||||
(setf (active backend) nil)))))
|
||||
(error "igs-handle-adjournment: no board!")))
|
||||
|
||||
(defun igs-to-pos (color igs)
|
||||
(cons (make-keyword color)
|
||||
(cons :pos
|
||||
(cons (char-to-num (aref igs 0))
|
||||
(1- (read (substring igs 1)))))))
|
||||
|
||||
(defun igs-current-game ()
|
||||
(aget *igs-games* *igs-current-game*))
|
||||
|
||||
(defun set-igs-current-game (new)
|
||||
(setf (aget *igs-games* *igs-current-game*) new))
|
||||
|
||||
(defsetf igs-current-game set-igs-current-game)
|
||||
|
||||
(defun igs-handle-tell (string)
|
||||
(unless (string-match (format "\\*\\(%s\\)\\*: \\(.*\\)$" igs-player-name-re)
|
||||
string)
|
||||
(error "igs: malformed tell string %S" string))
|
||||
;; TODO: keep a message buffer for each user in which conversations
|
||||
;; may be saved... during games store messages as SGF comments.
|
||||
(message "igs[%s]: %s" (match-string 1 string) (match-string 2 string)))
|
||||
|
||||
(defun igs-handle-shout (string)
|
||||
(unless (string-match "^\\([^:]*\\): \\(.*\\)$" string)
|
||||
(error "igs: malformed shout string %S" string))
|
||||
(message "IGS[%s]: %s" (match-string 1 string) (match-string 2 string)))
|
||||
|
||||
(defun igs-apply-move (move)
|
||||
(if (aget (igs-current-game) :board)
|
||||
(setf (go-move (aget (igs-current-game) :board)) move)
|
||||
(message "igs-apply-move: no board!")))
|
||||
|
||||
(defun igs-register-game (number)
|
||||
(setq *igs-current-game* number)
|
||||
(unless (aget (igs-current-game) :board)
|
||||
(setf (aget (igs-current-game) :board)
|
||||
(save-excursion
|
||||
(setf (number *igs-instance*) number)
|
||||
(make-instance 'board
|
||||
:buffer (go-board *igs-instance*
|
||||
(make-instance 'sgf)))))
|
||||
(when (aget (igs-current-game) :board)
|
||||
(igs-send (format "moves %s" number)))))
|
||||
|
||||
(defun igs-update-game-info (info)
|
||||
(let ((color (car info))
|
||||
(name (cadr info))
|
||||
(other (cddr info)))
|
||||
;; (message "[%s] %s: %s" color name other)
|
||||
))
|
||||
|
||||
(defun igs-handle-move (move-string)
|
||||
(go-re-cond move-string
|
||||
(igs-move-piece-re (igs-apply-move
|
||||
(igs-to-pos (match-string 1 move-string)
|
||||
(match-string 2 move-string))))
|
||||
(igs-move-time-re nil)
|
||||
(igs-move-props-re nil)
|
||||
(igs-move-game-re
|
||||
(let ((number (read (match-string 1 move-string)))
|
||||
(white-info (cons (match-string 2 move-string)
|
||||
(read (match-string 3 move-string))))
|
||||
(black-info (cons (match-string 4 move-string)
|
||||
(read (match-string 5 move-string)))))
|
||||
(igs-register-game number)
|
||||
(igs-update-game-info (cons :W white-info))
|
||||
(igs-update-game-info (cons :B black-info))))))
|
||||
|
||||
|
||||
;;; Interface
|
||||
;;
|
||||
;; If we find another backend providing game lists and observations
|
||||
;; then this could be generalized to an interface.
|
||||
(defun igs-start (&optional name)
|
||||
"Connect to an IGS server and return the `igs' instance."
|
||||
(interactive)
|
||||
(set-buffer (get-buffer-create (or name "*igs*")))
|
||||
(if (get-buffer-process (current-buffer))
|
||||
*igs-instance*
|
||||
(let ((*igs* (make-instance 'igs)))
|
||||
(igs-connect *igs*)
|
||||
*igs*)))
|
||||
|
||||
(defun igs-get-games (&optional instance)
|
||||
"List the games of the igs instance."
|
||||
(interactive)
|
||||
(set-buffer (buffer (or instance (igs-start))))
|
||||
(setf *igs-games* nil)
|
||||
(igs-send "games"))
|
||||
|
||||
(provide 'igs)
|
||||
;;; igs.el ends here
|
||||
|
|
@ -1,196 +0,0 @@
|
|||
;;; sgf.el --- SGF GO back end
|
||||
|
||||
;; Copyright (C) 2012 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Eric Schulte <schulte.eric@gmail.com>
|
||||
;; Created: 2012-05-15
|
||||
;; Version: 0.1
|
||||
;; Keywords: game go sgf
|
||||
|
||||
;; This software is free software: you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; This software 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 for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;; Commentary:
|
||||
|
||||
;; This file implements an `go-trans' interface into an SGF file.
|
||||
|
||||
;; Code:
|
||||
(require 'go-api)
|
||||
|
||||
(defun sgf-nthcdr (sgf index)
|
||||
(let ((part sgf))
|
||||
(while (cdr index)
|
||||
(setq part (nth (car index) part))
|
||||
(setq index (cdr index)))
|
||||
(setq part (nthcdr (car index) part))
|
||||
part))
|
||||
|
||||
(defun sgf-ref (sgf index)
|
||||
(let ((part sgf))
|
||||
(while (car index)
|
||||
(setq part (nth (car index) part))
|
||||
(setq index (cdr index)))
|
||||
part))
|
||||
|
||||
(defun set-sgf-ref (sgf index new)
|
||||
(eval `(setf ,(reduce (lambda (acc el) (list 'nth el acc))
|
||||
index :initial-value 'sgf)
|
||||
',new)))
|
||||
|
||||
(defsetf sgf-ref set-sgf-ref)
|
||||
|
||||
|
||||
;;; Class
|
||||
(defclass sgf nil
|
||||
((self :initarg :self :accessor self :initform nil)
|
||||
(index :initarg :index :accessor index :initform (list 0)))
|
||||
"Class for the SGF back end.")
|
||||
|
||||
(defun sgf-from-file (file)
|
||||
(interactive "f")
|
||||
(make-instance 'sgf :self (sgf2el-file-to-el file)))
|
||||
|
||||
(defun sgf-to-file (sgf file)
|
||||
(interactive "F")
|
||||
(when (and (file-exists-p file)
|
||||
(not (y-or-n-p (format "overwrite %s? " file))))
|
||||
(error "aborted"))
|
||||
(with-temp-file file
|
||||
(delete-region (point-min) (point-max))
|
||||
(insert (pp (self sgf)))))
|
||||
|
||||
(defmethod current ((sgf sgf))
|
||||
(sgf-ref (self sgf) (index sgf)))
|
||||
|
||||
(defun set-current (sgf new)
|
||||
(setf (sgf-ref (self sgf) (index sgf)) new))
|
||||
|
||||
(defsetf current set-current)
|
||||
|
||||
(defmethod root ((sgf sgf))
|
||||
(sgf-ref (self sgf) '(0)))
|
||||
|
||||
(defun set-root (sgf new)
|
||||
(if (self sgf)
|
||||
(setf (car (self sgf)) new)
|
||||
(setf (self sgf) (list new))))
|
||||
|
||||
(defsetf root set-root)
|
||||
|
||||
(defmethod next ((sgf sgf))
|
||||
(incf (car (last (index sgf)))))
|
||||
|
||||
(defmethod prev ((sgf sgf))
|
||||
(decf (car (last (index sgf)))))
|
||||
|
||||
|
||||
;;; interface
|
||||
(defmethod go-size ((sgf sgf))
|
||||
(or (aget (root sgf) :S)
|
||||
(aget (root sgf) :SZ)))
|
||||
|
||||
(defmethod set-go-size ((sgf sgf) size)
|
||||
(cond
|
||||
((aget (root sgf) :S) (setf (cdr (assoc :S (root sgf))) size))
|
||||
((aget (root sgf) :SZ) (setf (cdr (assoc :SZ (root sgf))) size))
|
||||
(t (push (cons :S size) (root sgf)))))
|
||||
|
||||
(defmethod go-level ((sgf sgf))
|
||||
(signal 'unsupported-back-end-command (list sgf :go-level)))
|
||||
|
||||
(defmethod set-go-level ((sgf sgf) level)
|
||||
(signal 'unsupported-back-end-command (list sgf :set-go-level level)))
|
||||
|
||||
(defmethod go-name ((sgf sgf))
|
||||
(or (aget (root sgf) :GN)
|
||||
(aget (root sgf) :EV)))
|
||||
|
||||
(defmethod set-go-name ((sgf sgf) name)
|
||||
(cond
|
||||
((aget (root sgf) :GN) (setf (cdr (assoc :GN (root sgf))) name))
|
||||
((aget (root sgf) :EV) (setf (cdr (assoc :EV (root sgf))) name))
|
||||
(t (push (cons :GN name) (root sgf)))))
|
||||
|
||||
(defmethod go-move ((sgf sgf))
|
||||
(next sgf)
|
||||
(let ((turn (current sgf)))
|
||||
(if turn
|
||||
(or (assoc :B turn) (assoc :W turn))
|
||||
(prev sgf)
|
||||
(error "sgf: no more moves"))))
|
||||
|
||||
;; TODO: currently this only works with linear sgf files w/o alternatives
|
||||
(defmethod set-go-move ((sgf sgf) move)
|
||||
(next sgf)
|
||||
(if (current sgf)
|
||||
(setf (current sgf) (list move))
|
||||
(setf (self sgf) (rcons (list move) (self sgf)))))
|
||||
|
||||
(defmethod go-labels ((sgf sgf))
|
||||
(let ((turn (current sgf)))
|
||||
(if turn
|
||||
(remove-if-not (lambda (pair) (member (car pair) '(:LB :LW))) turn)
|
||||
(prev sgf)
|
||||
(error "sgf: no more moves"))))
|
||||
|
||||
(defmethod set-go-lables ((sgf sgf) labels)
|
||||
(if (current sgf)
|
||||
(setf (current sgf) (cons (or (assoc :B (current sgf))
|
||||
(assoc :W (current sgf)))
|
||||
labels))
|
||||
(rpush labels (sgf-ref (self sgf) (butlast (index sgf))))))
|
||||
|
||||
(defmethod go-comment ((sgf sgf))
|
||||
(aget (current sgf) :C))
|
||||
|
||||
(defmethod set-go-comment ((sgf sgf) comment)
|
||||
(if (aget (current sgf) :C)
|
||||
(setf (cdr (assoc :C (current sgf))) comment)
|
||||
(push (cons :C comment) (current sgf))))
|
||||
|
||||
(defmethod go-alt ((sgf sgf))
|
||||
(error "sgf: go-alt not yet supported"))
|
||||
|
||||
(defmethod set-go-alt ((sgf sgf) alt)
|
||||
(error "sgf: set-go-alt not yet supported"))
|
||||
|
||||
(defmethod go-color ((sgf sgf))
|
||||
(signal 'unsupported-back-end-command (list sgf :move)))
|
||||
|
||||
(defmethod set-go-color ((sgf sgf) color)
|
||||
(signal 'unsupported-back-end-command (list sgf :set-color color)))
|
||||
|
||||
;; non setf'able generic functions
|
||||
(defmethod go-undo ((sgf sgf)) (prev sgf))
|
||||
|
||||
(defmethod go-pass ((sgf sgf))
|
||||
(signal 'unsupported-back-end-command (list sgf :pass)))
|
||||
|
||||
(defmethod go-resign ((sgf sgf))
|
||||
(signal 'unsupported-back-end-command (list sgf :resign)))
|
||||
|
||||
(defmethod go-quit ((sgf sgf))
|
||||
(when (y-or-n-p "Save game to file: ")
|
||||
(sgf-to-file sgf (read-file-name "Save game to: "))))
|
||||
|
||||
(defmethod go-score ((sgf sgf))
|
||||
(signal 'unsupported-back-end-command (list sgf :score)))
|
||||
|
||||
(defmethod go-territory ((sgf sgf))
|
||||
(signal 'unsupported-back-end-command (list sgf :territory)))
|
||||
|
||||
(defmethod go-dead ((sgf sgf))
|
||||
(signal 'unsupported-back-end-command (list sgf :dead)))
|
||||
|
||||
(provide 'sgf)
|
||||
;;; sgf.el ends here
|
||||
|
|
@ -1,188 +0,0 @@
|
|||
;;; sgf2el.el --- conversion between sgf and emacs-lisp
|
||||
|
||||
;; Copyright (C) 2012 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Eric Schulte <schulte.eric@gmail.com>
|
||||
;; Created: 2012-05-15
|
||||
;; Version: 0.1
|
||||
;; Keywords: game go sgf
|
||||
|
||||
;; This software is free software: you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; This software 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 for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Code:
|
||||
(require 'go-util)
|
||||
|
||||
(defvar prop-re
|
||||
"\\([[:alpha:]]+\\)\\(\\(\\[\\]\\|[[:space:]]*\\[[^\000]*?[^\\]\\]\\)+\\)")
|
||||
|
||||
(defvar prop-val-re
|
||||
"\\(\\[\\]\\|\\[\\([^\000]*?[^\\]\\)\\]\\)")
|
||||
|
||||
(defvar sgf2el-special-properties nil
|
||||
"A-list of properties and functions to specially convert their values.")
|
||||
|
||||
(defun make-keyword (string)
|
||||
(intern (concat ":" (upcase string))))
|
||||
|
||||
(defun sgf2el-convert-prop-key (key)
|
||||
"Convert a keyerty name to elisp."
|
||||
(save-match-data (make-keyword key)))
|
||||
|
||||
(defun sgf2el-read-prop (val)
|
||||
(when (and (stringp val) (not (equal val "")))
|
||||
(or (go-number-p val) val)))
|
||||
|
||||
(defun sgf2el-convert-prop-vals (key vals)
|
||||
"Convert a property value to elisp."
|
||||
(save-match-data
|
||||
(let ((func (cdr (assoc key sgf2el-special-properties))))
|
||||
(if func
|
||||
(funcall func vals)
|
||||
(delete nil (mapcar #'sgf2el-read-prop vals))))))
|
||||
|
||||
(defun sgf2el-all-matches (str re &optional sub-exp)
|
||||
(save-match-data
|
||||
(with-temp-buffer
|
||||
(insert str)
|
||||
(goto-char (point-min))
|
||||
(loop while (re-search-forward re nil t)
|
||||
collect (go-clean-text-properties
|
||||
(match-string (or sub-exp 0)))))))
|
||||
|
||||
(defun sgf2el-region (&optional start end)
|
||||
(interactive "r")
|
||||
(let ((start (copy-marker (or start (point-min))))
|
||||
(end (copy-marker (or end (point-max))))
|
||||
(re (format "\\(%s\\|%s\\)" prop-re "\\(([[:space:]]*\\)*\\(;\\)"))
|
||||
last-node)
|
||||
(save-excursion (goto-char start)
|
||||
(while (re-search-forward re end t)
|
||||
(let ((start (marker-position start)))
|
||||
(message "parsing %.2f%%"
|
||||
(* 100 (/ (float (- (point) start))
|
||||
(float (- (marker-position end) start))))))
|
||||
(if (string= (match-string 6) ";")
|
||||
(progn
|
||||
(replace-match "(" nil nil nil 6)
|
||||
(when last-node
|
||||
(save-excursion (goto-char (match-beginning 0)) (insert ")")))
|
||||
(setq last-node t))
|
||||
(let* ((key (sgf2el-convert-prop-key (match-string 2)))
|
||||
(val (sgf2el-convert-prop-vals key
|
||||
(sgf2el-all-matches (match-string 3) prop-val-re 2)))
|
||||
(rep (format "%S " (cons key (if (= 1 (length val))
|
||||
(car val) val)))))
|
||||
(replace-match rep nil 'literal))))
|
||||
(when last-node (insert ")")))
|
||||
(message "parsing DONE")))
|
||||
|
||||
(defun sgf2el-normalize (&optional buffer)
|
||||
"Cleanup the formatting of the elisp sgf data in BUFFER."
|
||||
(interactive)
|
||||
(let ((buffer (or buffer (current-buffer))) temp)
|
||||
(sgf2el-set-to-var temp buffer)
|
||||
(with-current-buffer buffer
|
||||
(save-excursion
|
||||
(delete-region (point-min) (point-max))
|
||||
(insert (pp temp))))
|
||||
temp))
|
||||
|
||||
(defun sgf2el (&optional sgf-buffer)
|
||||
"Convert the content of SGF-BUFFER to emacs-lisp in a new buffer."
|
||||
(interactive)
|
||||
(let* ((sgf-buffer (or sgf-buffer (current-buffer)))
|
||||
(buffer (generate-new-buffer (concat (buffer-name sgf-buffer) "-el")))
|
||||
(sgf-str (with-current-buffer sgf-buffer (buffer-string))))
|
||||
(with-current-buffer buffer
|
||||
(insert sgf-str)
|
||||
(goto-char (point-min))
|
||||
(sgf2el-region)
|
||||
(emacs-lisp-mode))
|
||||
(pop-to-buffer buffer)))
|
||||
|
||||
(defun sgf2el-read (&optional buf)
|
||||
(with-current-buffer (or buf (current-buffer))
|
||||
(goto-char (point-min))
|
||||
(read (current-buffer))))
|
||||
|
||||
(defun sgf2el-buffer-to-el (&optional bufffer)
|
||||
"Convert the sgf contents of BUFFER to emacs lisp."
|
||||
(interactive "b")
|
||||
(with-current-buffer (or bufffer (current-buffer))
|
||||
(sgf2el-region (point-min) (point-max))
|
||||
(sgf2el-read)))
|
||||
|
||||
(defun sgf2el-str-to-el (str)
|
||||
"Convert a string of sgf into the equivalent Emacs Lisp."
|
||||
(interactive)
|
||||
(with-temp-buffer (insert str) (sgf2el-buffer-to-el)))
|
||||
|
||||
(defun sgf2el-file-to-el (file)
|
||||
"Convert the sgf contents of FILE to emacs lisp."
|
||||
(interactive "f")
|
||||
(with-temp-buffer
|
||||
(insert-file-contents-literally file)
|
||||
(sgf2el-buffer-to-el)))
|
||||
|
||||
|
||||
;;; Specific property converters
|
||||
(defun process-date (date-args)
|
||||
(save-match-data (parse-time-string
|
||||
(if (> 1 (length date-args))
|
||||
(mapconcat #'number-to-string date-args " ")
|
||||
(car date-args)))))
|
||||
(add-to-list 'sgf2el-special-properties (cons :DT #'process-date))
|
||||
|
||||
(defun process-position (position-string)
|
||||
(cl-flet ((char-to-num (char)
|
||||
(cond
|
||||
((or (< char ?A) (< ?z char))
|
||||
(error "sgf: invalid char %s" char))
|
||||
((< char ?a) (+ 26 (- char ?A)))
|
||||
(t (- char ?a)))))
|
||||
(cons (char-to-num (aref position-string 0))
|
||||
(char-to-num (aref position-string 1)))))
|
||||
|
||||
(defun process-move (move-args)
|
||||
(list (cons :pos (process-position (car move-args)))))
|
||||
(add-to-list 'sgf2el-special-properties (cons :B #'process-move))
|
||||
(add-to-list 'sgf2el-special-properties (cons :W #'process-move))
|
||||
|
||||
(defun process-label (label-args)
|
||||
(let ((res (mapcar (lambda (l-arg)
|
||||
(if (string-match "\\([[:alpha:]]+\\):\\(.*\\)" l-arg)
|
||||
(list
|
||||
(cons :label (match-string 2 l-arg))
|
||||
(cons :pos (process-position
|
||||
(match-string 1 l-arg))))
|
||||
(error "sgf: malformed label %S" l-arg)))
|
||||
label-args)))
|
||||
(if (= 1 (length label-args)) (list res) res)))
|
||||
(add-to-list 'sgf2el-special-properties (cons :LB #'process-label))
|
||||
(add-to-list 'sgf2el-special-properties (cons :LW #'process-label))
|
||||
|
||||
(defun process-comment (comments)
|
||||
(let ((replacements '(("\\(" . "(")
|
||||
("\\)" . ")")
|
||||
("\\[" . "[")
|
||||
("\\]" . "]"))))
|
||||
(mapcar (lambda (comment)
|
||||
(dolist (pair replacements comment)
|
||||
(setq comment (replace-regexp-in-string
|
||||
(regexp-quote (car pair)) (cdr pair) comment))))
|
||||
comments)))
|
||||
(add-to-list 'sgf2el-special-properties (cons :C #'process-comment))
|
||||
|
||||
(provide 'sgf2el)
|
||||
;;; sgf2el.el ends here
|
||||
|
|
@ -1,78 +0,0 @@
|
|||
;;; go-api.el --- a uniform API for communication between GO back-ends
|
||||
|
||||
;; Copyright (C) 2012 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Eric Schulte <schulte.eric@gmail.com>
|
||||
;; Created: 2012-05-15
|
||||
;; Version: 0.1
|
||||
;; Keywords: game go sgf
|
||||
|
||||
;; This software is free software: you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; This software 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 for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; A board-based interface to GO games which may be connected to a
|
||||
;; number of GO back-ends through a generic API. To play a game of GO
|
||||
;; against the gnugo back-end run `play-go'. Current back-ends
|
||||
;; include the following.
|
||||
;; - the SGF format
|
||||
;; - the Go Text Protocol (GTP)
|
||||
;; - TODO: the IGS protocol
|
||||
|
||||
;;; Code:
|
||||
(require 'go-util)
|
||||
(require 'eieio)
|
||||
|
||||
(put 'unsupported-back-end-command
|
||||
'error-conditions
|
||||
'(error unsupported-back-end-command))
|
||||
|
||||
(defmacro ignoring-unsupported (&rest body)
|
||||
`(condition-case err ,@body
|
||||
(unsupported-back-end-command nil)))
|
||||
|
||||
(defmacro defgeneric-w-setf (name doc)
|
||||
(let ((set-name (intern (concat "set-" (symbol-name name)))))
|
||||
`(progn
|
||||
(defgeneric ,name (back-end) ,doc)
|
||||
(defgeneric ,set-name (back-end new))
|
||||
(defsetf ,name ,set-name))))
|
||||
|
||||
;; setf'able back-end access
|
||||
(defgeneric-w-setf go-size "Access BACK-END size.")
|
||||
(defgeneric-w-setf go-level "Access level of BACK-END.")
|
||||
(defgeneric-w-setf go-name "Access BACK-END name.")
|
||||
(defgeneric-w-setf go-move "Access current BACK-END move.")
|
||||
(defgeneric-w-setf go-labels "Access current BACK-END labels.")
|
||||
(defgeneric-w-setf go-comment "Access current BACK-END comment.")
|
||||
(defgeneric-w-setf go-alt "Access current BACK-END alternative move.")
|
||||
(defgeneric-w-setf go-color "Access current BACK-END turn color.")
|
||||
(defgeneric-w-setf go-player-name "Access current BACK-END player name.")
|
||||
(defgeneric-w-setf go-player-time "Access current BACK-END player time.")
|
||||
(defgeneric-w-setf
|
||||
go-player-prisoners "Access current BACK-END player prisoners.")
|
||||
|
||||
;; sending messages to the back-end
|
||||
(defgeneric go-connect (back-end) "Connect to BACK-END.")
|
||||
(defgeneric go-undo (back-end) "Send undo to BACK-END.")
|
||||
(defgeneric go-pass (back-end) "Send pass to BACK-END.")
|
||||
(defgeneric go-resign (back-end) "Send resign to BACK-END.")
|
||||
(defgeneric go-reset (back-end) "Send reset to BACK-END.")
|
||||
(defgeneric go-quit (back-end) "Quit the BACK-END.")
|
||||
(defgeneric go-score (back-end) "Ask BACK-END to report the score.")
|
||||
(defgeneric go-territory (back-end) "Ask BACK-END to report the territory.")
|
||||
(defgeneric go-dead (back-end) "Ask BACK-END to dead stones.")
|
||||
|
||||
(provide 'go-api)
|
||||
;;; go-api.el ends here
|
||||
|
|
@ -1,32 +0,0 @@
|
|||
;;; go-autoloads.el --- automatically extracted autoloads
|
||||
;;
|
||||
;;; Code:
|
||||
(add-to-list 'load-path (or (file-name-directory #$) (car load-path)))
|
||||
|
||||
;;;### (autoloads nil "go" "go.el" (22490 32825 89857 211000))
|
||||
;;; Generated autoloads from go.el
|
||||
|
||||
(autoload 'go-play "go" "\
|
||||
Play a game of GO.
|
||||
|
||||
\(fn)" t nil)
|
||||
|
||||
(autoload 'go-view-sgf "go" "\
|
||||
View an SGF file.
|
||||
|
||||
\(fn &optional FILE)" t nil)
|
||||
|
||||
;;;***
|
||||
|
||||
;;;### (autoloads nil nil ("go-api.el" "go-board-faces.el" "go-board.el"
|
||||
;;;;;; "go-pkg.el" "go-util.el" "list-buffer.el") (22490 32825 112091
|
||||
;;;;;; 153000))
|
||||
|
||||
;;;***
|
||||
|
||||
;; Local Variables:
|
||||
;; version-control: never
|
||||
;; no-byte-compile: t
|
||||
;; no-update-autoloads: t
|
||||
;; End:
|
||||
;;; go-autoloads.el ends here
|
||||
|
|
@ -1,177 +0,0 @@
|
|||
;;; go-board-faces.el -- Color for GO boards
|
||||
|
||||
;; Copyright (C) 2012 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Eric Schulte <schulte.eric@gmail.com>
|
||||
;; Created: 2012-05-15
|
||||
;; Version: 0.1
|
||||
;; Keywords: game go sgf
|
||||
|
||||
;; This software is free software: you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; This software 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 for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Code:
|
||||
(defface go-board-background
|
||||
'((t (:background "#b36108" :foreground "#6f3c04")))
|
||||
"woodsy background")
|
||||
|
||||
(defface go-board-hoshi
|
||||
'((t (:background "#b36108" :foreground "#6d3300")))
|
||||
"woodsy background with darker hoshi mark")
|
||||
|
||||
(defface go-board-black
|
||||
'((t (:background "#b36108" :foreground "black")))
|
||||
"black piece on woodsy background")
|
||||
|
||||
(defface go-board-white
|
||||
'((t (:background "#b36108" :foreground "white")))
|
||||
"white piece on woodsy background")
|
||||
|
||||
(defface go-board-black-territory-background
|
||||
'((t (:background "#6a4014" :foreground "#6f3c04")))
|
||||
"woodsy background")
|
||||
|
||||
(defface go-board-black-territory-hoshi
|
||||
'((t (:background "#6a4014" :foreground "#6d3300")))
|
||||
"woodsy background with darker hoshi mark")
|
||||
|
||||
(defface go-board-black-territory-black
|
||||
'((t (:background "#6a4014" :foreground "black")))
|
||||
"black piece on black territory")
|
||||
|
||||
(defface go-board-black-territory-white
|
||||
'((t (:background "#6a4014" :foreground "#6b6b6b")))
|
||||
"white piece on black territory")
|
||||
|
||||
(defface go-board-white-territory-background
|
||||
'((t (:background "#cd9c67" :foreground "#6f3c04")))
|
||||
"white territory")
|
||||
|
||||
(defface go-board-white-territory-hoshi
|
||||
'((t (:background "#cd9c67" :foreground "#6d3300")))
|
||||
"white territory with darker hoshi mark")
|
||||
|
||||
(defface go-board-white-territory-black
|
||||
'((t (:background "#cd9c67" :foreground "#6b6b6b")))
|
||||
"black piece on white territory")
|
||||
|
||||
(defface go-board-white-territory-white
|
||||
'((t (:background "#cd9c67" :foreground "white")))
|
||||
"white piece on white territory")
|
||||
|
||||
;; Maybe use `face-remap-add-relative' to change image sizes.
|
||||
|
||||
|
||||
;;; Image utility functions
|
||||
(defun go-board-svg-trans (list)
|
||||
(if (and (listp list) (listp (car list)))
|
||||
(concat (format "<%s%s" (caar list) (if (cdar list) " " ""))
|
||||
(mapconcat (lambda (pair) (format "%s=\"%s\"" (car pair) (cdr pair)))
|
||||
(cdar list) " ")
|
||||
(if (cdr list)
|
||||
(concat ">"
|
||||
(mapconcat #'go-board-svg-trans (cdr list) " ")
|
||||
(format "</%s>" (caar list)))
|
||||
"/>"))
|
||||
list))
|
||||
|
||||
(defun go-board-cross (color)
|
||||
(mapconcat #'go-board-svg-trans
|
||||
`(((line (x1 . 3.125) (y1 . 3.125) (x2 . 21.875) (y2 . 21.875)
|
||||
(style . ,(format "stroke: %s;" color))))
|
||||
((line (x1 . 3.125) (y1 . 21.875) (x2 . 21.875) (y2 . 3.125)
|
||||
(style . ,(format "stroke: %s;" color)))))
|
||||
""))
|
||||
|
||||
(defun go-board-label (color label)
|
||||
(go-board-svg-trans
|
||||
`((text (x . 8.75) (y . 16.25) (r . 12.25)
|
||||
(style . ,(format "font-size:12.5;fill:%s;" color)))
|
||||
,label)))
|
||||
|
||||
(defun go-board-mark (overlay mark)
|
||||
"Write MARK over top of the SVG image in OVERLAY."
|
||||
(let* ((disp (cdr (copy-tree (overlay-get overlay 'display))))
|
||||
(data (plist-get disp :data)))
|
||||
(when (and data (string-match (regexp-quote "</svg>") data))
|
||||
(plist-put disp :data (concat (substring data 0 (match-beginning 0))
|
||||
mark
|
||||
(substring data (match-beginning 0))))
|
||||
(overlay-put overlay 'display (cons 'image disp)))))
|
||||
|
||||
(defmacro go-board-wrap (&rest body)
|
||||
`(concat
|
||||
"<?xml version=\"1.0\" encoding=\"UTF-8\"?>"
|
||||
(go-board-svg-trans
|
||||
'((svg (xmlns . "http://www.w3.org/2000/svg")
|
||||
(xmlns:xlink . "http://www.w3.org/1999/xlink")
|
||||
(width . 25) (height . 25) (version . 1.0))
|
||||
,@body))))
|
||||
|
||||
;; TODO: To allow images to scale with text, this should return a
|
||||
;; function instead of a list. This function should take a base
|
||||
;; size (e.g., 12.5), and should return the image list
|
||||
;; appropriate for that size.
|
||||
(defmacro go-board-image (&rest body)
|
||||
``(image :type svg :ascent center :data
|
||||
,(go-board-wrap
|
||||
((rect (width . 25) (height . 25) (fill . "#dcb35c")))
|
||||
,@body)))
|
||||
|
||||
(defmacro go-board-image-sides (name &rest base)
|
||||
(declare (indent 1))
|
||||
`(progn
|
||||
,@(mapcar
|
||||
(lambda (p)
|
||||
`(defvar ,(sym-cat 'go-board-image name (car p))
|
||||
(go-board-image
|
||||
,(when (cdr p)
|
||||
`((path (stroke . "#000") (stroke-width . 1) (d . ,(cdr p)))))
|
||||
,@base)))
|
||||
'((left . "M12,12.5H25M12.5,0V25")
|
||||
(right . "M0,12.5H13M12.5,0V25")
|
||||
(top . "M0,12.5H25M12.5,12V25")
|
||||
(bottom . "M0,12.5H25M12.5,0V12.5")
|
||||
(top-left . "M12,12.5H25M12.5,12V25")
|
||||
(top-right . "M0,12.5H13M12.5,12V25")
|
||||
(bottom-left . "M12,12.5H25M12.5,0V13")
|
||||
(bottom-right . "M0,12.5H13M12.5,0V13")
|
||||
(nil . "M0,12.5H25M12.5,0V25")))))
|
||||
|
||||
|
||||
;;; SVG Images
|
||||
(go-board-image-sides background)
|
||||
|
||||
(go-board-image-sides black
|
||||
((defs)
|
||||
((radialGradient (id . "$rg") (cx . ".3") (cy . ".3") (r . ".8"))
|
||||
((stop (offset . 0) (stop-color . "#777")))
|
||||
((stop (offset . 0.3) (stop-color . "#222")))
|
||||
((stop (offset . 1) (stop-color . "#000")))))
|
||||
((circle (cx . 12.5) (cy . 12.5) (r . 9.375) (fill . "url(#$rg)"))))
|
||||
|
||||
(go-board-image-sides white
|
||||
((defs)
|
||||
((radialGradient (id . "$rg") (cx . ".47") (cy . ".49") (r . ".48"))
|
||||
((stop (offset . 0.7) (stop-color . "#FFF")))
|
||||
((stop (offset . 0.9) (stop-color . "#DDD")))
|
||||
((stop (offset . 1) (stop-color . "#777")))))
|
||||
((circle (cx . 12.5) (cy . 12.5) (r . 9.375) (fill . "url(#$rg)"))))
|
||||
|
||||
(defvar go-board-image-hoshi
|
||||
(go-board-image
|
||||
((path (stroke . "#000") (stroke-width . 1) (d . "M0,12.5H25M12.5,0V25")))
|
||||
((circle (cx . 12.5) (cy . 12.5) (r . 2.5)))))
|
||||
|
||||
(provide 'go-board-faces)
|
||||
;;; go-board-faces.el ends here
|
||||
|
|
@ -1,578 +0,0 @@
|
|||
;;; go-board.el --- Smart Game Format GO board visualization
|
||||
|
||||
;; Copyright (C) 2012-2013 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Eric Schulte <schulte.eric@gmail.com>
|
||||
;; Created: 2012-05-15
|
||||
;; Version: 0.1
|
||||
;; Keywords: game go sgf
|
||||
|
||||
;; This software is free software: you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; This software 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 for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Code:
|
||||
(require 'go-util)
|
||||
(require 'go-api)
|
||||
(require 'go-board-faces)
|
||||
|
||||
(defvar *history* nil "Holds the board history for a GO buffer.")
|
||||
(defvar *size* nil "Holds the board size.")
|
||||
(defvar *turn* nil "Holds the color of the current turn.")
|
||||
(defvar *black* nil "Plist of info on black player.")
|
||||
(defvar *white* nil "Plist of info on white player.")
|
||||
(defvar *back-end* nil "Holds the primary back-end connected to a board.")
|
||||
(defvar *trackers* nil "Holds a list of back-ends which should track the game.")
|
||||
(defvar *autoplay* nil "Should `*back-end*' automatically respond to moves.")
|
||||
|
||||
(defvar black-piece "X")
|
||||
(defvar white-piece "O")
|
||||
|
||||
(defvar go-board-use-images t)
|
||||
(defvar *go-board-overlays* nil
|
||||
"List of overlays carrying GO board painting information.")
|
||||
|
||||
(defvar go-board-use-move-sound nil)
|
||||
(defvar go-board-move-sound
|
||||
`(sound :file ,(expand-file-name "stone.wav"
|
||||
(file-name-directory
|
||||
(or load-file-name (buffer-file-name))))))
|
||||
|
||||
|
||||
;;; Board manipulation functions
|
||||
(defun make-board (size) (make-vector (* size size) nil))
|
||||
|
||||
(defun board-size (board) (round (sqrt (length board))))
|
||||
|
||||
(defun go-player-get (color property)
|
||||
(plist-get (case color (:W *white*) (:B *black*)) property))
|
||||
|
||||
(defun go-player-set (color property value)
|
||||
(let ((player (case color (:W *white*) (:B *black*))))
|
||||
(plist-put player property value)))
|
||||
|
||||
(defsetf go-player-get go-player-set)
|
||||
|
||||
(defun move-type (move)
|
||||
(cond
|
||||
((member (car move) '(:B :W)) :move)
|
||||
((member (car move) '(:LB :LW)) :label)))
|
||||
|
||||
(defun other-color (color)
|
||||
(if (equal color :B) :W :B))
|
||||
|
||||
(defun point-of-pos (pos)
|
||||
(catch 'found-pos
|
||||
(dotimes (p (1- (point-max)) (error "go: pos %S not found" pos))
|
||||
(let ((pos-at-point (get-text-property (1+ p) :pos)))
|
||||
(when (and pos-at-point (tree-equal pos pos-at-point))
|
||||
(throw 'found-pos (1+ p)))))))
|
||||
|
||||
(defun apply-turn-to-board (moves)
|
||||
(let ((board (pieces-to-board (car *history*) *size*)))
|
||||
(clear-labels board)
|
||||
(when go-board-use-move-sound (play-sound go-board-move-sound))
|
||||
(dolist (move moves) (apply-move board move))
|
||||
(push (board-to-pieces board) *history*)
|
||||
(update-display (current-buffer))))
|
||||
|
||||
(defun apply-move (board move)
|
||||
(cl-flet ((bset (val data)
|
||||
(let ((data (if (listp (car data)) data (list data))))
|
||||
(setf (aref board (pos-to-index (aget data :pos)
|
||||
(board-size board)))
|
||||
(case val
|
||||
(:B :B)
|
||||
(:W :W)
|
||||
(:LB (aget data :label))
|
||||
(:LW (aget data :label))
|
||||
(t nil))))))
|
||||
(case (move-type move)
|
||||
(:move
|
||||
(bset (car move) (cdr move))
|
||||
(let ((color (if (equal :B (car move)) :B :W)))
|
||||
(remove-dead board (other-color color))
|
||||
(remove-dead board color)))
|
||||
(:label
|
||||
(dolist (data (cdr move)) (bset (car move) data))))))
|
||||
|
||||
(defun clear-labels (board)
|
||||
(dotimes (point (length board) board)
|
||||
(when (aref board point)
|
||||
(unless (member (aref board point) '(:B :W))
|
||||
(setf (aref board point) nil)))))
|
||||
|
||||
(defun neighbors (board piece)
|
||||
(let ((size (board-size board))
|
||||
neighbors)
|
||||
(when (not (= (mod piece size) (1- size))) (push (1+ piece) neighbors))
|
||||
(when (not (= (mod piece size) 0)) (push (1- piece) neighbors))
|
||||
(when (< (+ piece size) (length board)) (push (+ piece size) neighbors))
|
||||
(when (> (- piece size) 0) (push (- piece size) neighbors))
|
||||
neighbors))
|
||||
|
||||
(defun alive-p (board piece &optional already)
|
||||
(let* ((val (aref board piece))
|
||||
(enemy (other-color val))
|
||||
(neighbors (remove-if (lambda (n) (member n already))
|
||||
(neighbors board piece)))
|
||||
(neighbor-vals (mapcar (lambda (n) (aref board n)) neighbors))
|
||||
(friendly (delete nil (mapcar
|
||||
(lambda (n) (when (equal (aref board n) val) n))
|
||||
neighbors)))
|
||||
(already (cons piece already)))
|
||||
(or (some (lambda (v) (not (or (equal v enemy) ; touching open space
|
||||
(equal v val))))
|
||||
neighbor-vals)
|
||||
(some (lambda (n) (alive-p board n already)) ; touching alive dragon
|
||||
friendly))))
|
||||
|
||||
(defun remove-dead (board color)
|
||||
;; must remove one color at a time for ko situations
|
||||
(let (cull)
|
||||
(dotimes (n (length board) board)
|
||||
(when (and (equal (aref board n) color) (not (alive-p board n)))
|
||||
(push n cull)))
|
||||
(incf (go-player-get (other-color color) :prisoners) (length cull))
|
||||
(dolist (n cull cull) (setf (aref board n) nil))))
|
||||
|
||||
(defun board-to-pieces (board)
|
||||
(let (pieces)
|
||||
(dotimes (n (length board) pieces)
|
||||
(let ((val (aref board n)))
|
||||
(when val (push (cons val n) pieces))))))
|
||||
|
||||
(defun pieces-to-board (pieces size)
|
||||
(let ((board (make-vector (* size size) nil)))
|
||||
(dolist (piece pieces board)
|
||||
(setf (aref board (cdr piece)) (car piece)))))
|
||||
|
||||
|
||||
;;; Visualization
|
||||
(defun board-header (board)
|
||||
(cl-flet ((hd (str hd)
|
||||
(put-text-property 0 1 :type `(,hd . :offboard) str)
|
||||
str))
|
||||
(let ((size (board-size board)))
|
||||
(concat " "
|
||||
(hd " " :filler)
|
||||
(mapconcat (lambda (n)
|
||||
(let ((char (+ ?A n)))
|
||||
(when (>= char ?I) (setq char (+ 1 char)))
|
||||
(hd (string char) :header)))
|
||||
(range size) (hd " " :filler))))))
|
||||
|
||||
(defun board-pos-to-string (board pos)
|
||||
(let ((size (board-size board)))
|
||||
(cl-flet ((emph (n)
|
||||
(cond
|
||||
((= size 19)
|
||||
(or (= 3 n)
|
||||
(= 4 (- size n))
|
||||
(= n (/ (- size 1) 2))))
|
||||
((= size 13)
|
||||
(or (= 3 n)
|
||||
(= 9 n)))
|
||||
((= size 9)
|
||||
(or (= 2 n)
|
||||
(= 6 n)))))
|
||||
(put (str prop val) (put-text-property 0 (length str) prop val str)))
|
||||
(let* ((val (aref board (pos-to-index pos size)))
|
||||
(str (cond
|
||||
((equal val :W) white-piece)
|
||||
((equal val :B) black-piece)
|
||||
((and (stringp val) (= 1 (length val)) val))
|
||||
(t (if (and (emph (car pos)) (emph (cdr pos))) "+" ".")))))
|
||||
(put str :type
|
||||
(cons (cond ;; foreground
|
||||
((string= str white-piece) :white)
|
||||
((string= str black-piece) :black)
|
||||
((string= str "+") :hoshi)
|
||||
((string= str ".") :background-1)
|
||||
(t :background))
|
||||
(cond ;; background
|
||||
((and (= 0 (car pos)) (= 0 (cdr pos))) :bl)
|
||||
((and (= 0 (car pos)) (= (1- size) (cdr pos))) :br)
|
||||
((and (= (1- size) (car pos)) (= 0 (cdr pos))) :tl)
|
||||
((and (= (1- size) (car pos)) (= (1- size) (cdr pos))) :tr)
|
||||
((= 0 (car pos)) :b)
|
||||
((= (1- size) (car pos)) :t)
|
||||
((= 0 (cdr pos)) :l)
|
||||
((= (1- size) (cdr pos)) :r)
|
||||
(t nil))))
|
||||
(put str :pos (cons (cdr pos) (car pos)))
|
||||
str))))
|
||||
|
||||
(defun board-row-to-string (board row)
|
||||
(let* ((size (board-size board))
|
||||
(label (format "%3d" (1+ row)))
|
||||
(row-body "")
|
||||
(filler " "))
|
||||
(put-text-property 0 1 :type (cons :background nil) filler)
|
||||
(dotimes (n size)
|
||||
(setq row-body
|
||||
(concat row-body
|
||||
(board-pos-to-string board (cons row n))
|
||||
filler)))
|
||||
(concat label " " (substring row-body 0 (1- (length row-body))) label)))
|
||||
|
||||
(defun board-body-to-string (board)
|
||||
(let ((board (transpose-array board)))
|
||||
(mapconcat (lambda (m) (board-row-to-string board m))
|
||||
(reverse (range (board-size board))) "\n")))
|
||||
|
||||
(defun board-to-string (board)
|
||||
(let ((header (board-header board))
|
||||
(body (board-body-to-string board)))
|
||||
(mapconcat #'identity (list header body header) "\n")))
|
||||
|
||||
(defun go-board-paint (&optional start end)
|
||||
(interactive "r")
|
||||
(cl-flet ((ov (point face &optional back)
|
||||
(let ((ovly (make-overlay point (1+ point))))
|
||||
(overlay-put ovly 'go-pt point)
|
||||
(overlay-put ovly 'face (sym-cat 'go-board face))
|
||||
(when go-board-use-images
|
||||
(overlay-put ovly 'display
|
||||
(if (equal face 'filler)
|
||||
'(space :width (18))
|
||||
(eval (sym-cat 'go-board 'image face back)))))
|
||||
(push ovly *go-board-overlays*)))
|
||||
(hide (point)
|
||||
(let ((ovly (make-overlay point (1+ point))))
|
||||
(overlay-put ovly 'invisible t)
|
||||
(push ovly *go-board-overlays*))))
|
||||
(let ((start (or start (point-min)))
|
||||
(end (or end (point-max))))
|
||||
(dolist (point (range start end))
|
||||
(if (get-text-property point :turn)
|
||||
(font-lock-prepend-text-property point (1+ point) 'face 'underline)
|
||||
(let ((back (case (cdr (get-text-property point :type))
|
||||
(:tl 'top-left)
|
||||
(:tr 'top-right)
|
||||
(:bl 'bottom-left)
|
||||
(:br 'bottom-right)
|
||||
(:t 'top)
|
||||
(:b 'bottom)
|
||||
(:l 'left)
|
||||
(:r 'right)
|
||||
(:offboard 'offboard))))
|
||||
(case (car (get-text-property point :type))
|
||||
(:header nil)
|
||||
(:filler (ov point 'filler back))
|
||||
(:hoshi (ov point 'hoshi))
|
||||
(:white (ov point 'white back))
|
||||
(:black (ov point 'black back))
|
||||
(:background (if go-board-use-images
|
||||
(hide point)
|
||||
(ov point 'background)))
|
||||
(:background-1 (ov point 'background back)))))))))
|
||||
|
||||
(defun player-to-string (color)
|
||||
(format "%10s: %3d"
|
||||
(let ((name (go-player-get color :name)))
|
||||
(put-text-property 0 (length name) :turn (equal *turn* color) name)
|
||||
name)
|
||||
(go-player-get color :prisoners)))
|
||||
|
||||
(defun update-display (buffer)
|
||||
(with-current-buffer buffer
|
||||
(let ((point (point)))
|
||||
(delete-region (point-min) (point-max))
|
||||
(insert "\n"
|
||||
(board-to-string
|
||||
(pieces-to-board (car *history*) *size*)) "\n\n"
|
||||
(player-to-string :W) "\n"
|
||||
(player-to-string :B) "\n")
|
||||
(let ((comment (ignoring-unsupported (go-comment *back-end*))))
|
||||
(when comment
|
||||
(insert (make-string (+ 6 (* 2 *size*)) ?=)
|
||||
"\n\n"
|
||||
comment)))
|
||||
(go-board-paint)
|
||||
(goto-char point)))
|
||||
buffer)
|
||||
|
||||
(defun go-board (back-end &rest trackers)
|
||||
(let ((buffer (generate-new-buffer "*GO*")))
|
||||
(with-current-buffer buffer
|
||||
(go-board-mode)
|
||||
(let ((name (go-name back-end)))
|
||||
(when name
|
||||
(rename-buffer (ear-muffs name) 'unique)
|
||||
(mapcar (lambda (tr) (setf (go-name tr) name)) trackers)))
|
||||
(set (make-local-variable '*back-end*) back-end)
|
||||
(set (make-local-variable '*turn*) :B)
|
||||
(set (make-local-variable '*black*) '(:name "black" :prisoners 0))
|
||||
(set (make-local-variable '*white*) '(:name "white" :prisoners 0))
|
||||
(set (make-local-variable '*size*) (go-size back-end))
|
||||
(set (make-local-variable '*autoplay*) nil)
|
||||
(set (make-local-variable '*go-board-overlays*) nil)
|
||||
(mapcar (lambda (tr) (setf (go-size tr) *size*)) trackers)
|
||||
(set (make-local-variable '*history*)
|
||||
(list (board-to-pieces (make-board *size*))))
|
||||
(set (make-local-variable '*trackers*) trackers))
|
||||
(pop-to-buffer buffer)
|
||||
(plist-put *black* :prisoners 0)
|
||||
(plist-put *white* :prisoners 0)
|
||||
(setq truncate-lines t)
|
||||
(update-display buffer)))
|
||||
|
||||
|
||||
;;; User input
|
||||
(defmacro with-trackers (sym &rest body)
|
||||
(declare (indent 1))
|
||||
`(ignoring-unsupported
|
||||
(mapcar (lambda (tr) (let ((,sym tr)) ,@body)) *trackers*)))
|
||||
|
||||
(defmacro with-backends (sym &rest body)
|
||||
(declare (indent 1))
|
||||
`(save-window-excursion
|
||||
(ignoring-unsupported
|
||||
(prog1 (let ((,sym *back-end*)) ,@body)
|
||||
(with-trackers ,sym ,@body)))))
|
||||
(def-edebug-spec with-backends (sexp body))
|
||||
|
||||
(defvar go-board-actions '(move resign undo comment)
|
||||
"List of actions which may be taken on an GO board.")
|
||||
|
||||
(defun go-board-act ()
|
||||
"Send a command to the current GO board."
|
||||
(interactive)
|
||||
(let ((command (go-completing-read
|
||||
"Action: " (mapcar #'symbol-name go-board-actions))))
|
||||
(case (intern command)
|
||||
(move (message "make a move"))
|
||||
(resign (message "game over"))
|
||||
(undo (message "loser"))
|
||||
(comment (message "what?")))))
|
||||
|
||||
(defun go-board-move (&optional pos)
|
||||
(interactive)
|
||||
(let* ((color (case *turn* (:B "black") (:W "white")))
|
||||
(pos (or pos (cons (char-to-num
|
||||
(aref (downcase
|
||||
(go-completing-read
|
||||
(format "[%s] X pos: " color)
|
||||
(mapcar #'string
|
||||
(mapcar #'gtp-num-to-char
|
||||
(range 1 *size*)))))
|
||||
0))
|
||||
(1- (string-to-number
|
||||
(go-completing-read
|
||||
(format "[%s] Y pos: " color)
|
||||
(mapcar #'number-to-string
|
||||
(range 1 *size*))))))))
|
||||
(move (cons *turn* (cons :pos pos))))
|
||||
(with-backends back
|
||||
(setf (go-move back) move))
|
||||
(setf *turn* (other-color *turn*))
|
||||
(apply-turn-to-board (list move)))
|
||||
(when *autoplay* (go-board-next)))
|
||||
|
||||
(defun go-board-refresh ()
|
||||
(interactive)
|
||||
(update-display (current-buffer)))
|
||||
|
||||
(defun go-board-resign ()
|
||||
(interactive)
|
||||
(with-backends back (go-resign back)))
|
||||
|
||||
(defun go-board-mark-point (point mark)
|
||||
(mapc (lambda (ov) (go-board-mark ov mark)) (overlays-at point)))
|
||||
|
||||
(defun go-board-pass ()
|
||||
(interactive)
|
||||
(with-backends back (go-pass back))
|
||||
(save-window-excursion
|
||||
(setf *turn* (other-color *turn*))
|
||||
(when *autoplay*
|
||||
(when (equalp :pass (go-board-next))
|
||||
;; mark open points
|
||||
(mapc (lambda (move)
|
||||
(go-board-mark-point (point-of-pos (cddr move))
|
||||
(go-board-cross (ecase (car move)
|
||||
(:B 'black)
|
||||
(:W 'white)))))
|
||||
(with-backends back (go-territory back)))
|
||||
;; mark dead stones
|
||||
(mapc (lambda (move)
|
||||
(let* ((point (point-of-pos (cddr move)))
|
||||
(color (car (get-text-property point :type))))
|
||||
(go-board-mark-point point
|
||||
(go-board-cross (ecase color
|
||||
(:black 'white)
|
||||
(:white 'black))))))
|
||||
(with-backends back (go-dead back)))
|
||||
(message "final score: %s" (with-backends back (go-score back)))))))
|
||||
|
||||
(defun go-board-undo (&optional num)
|
||||
(interactive "p")
|
||||
(with-backends back (go-undo back))
|
||||
(pop *history*)
|
||||
(update-display (current-buffer))
|
||||
(setf *turn* (other-color *turn*)))
|
||||
|
||||
(defun go-board-comment (&optional comment)
|
||||
(interactive "MComment: ")
|
||||
(with-backends back (setf (go-comment back) comment)))
|
||||
|
||||
(defun go-board-level (&optional level)
|
||||
(interactive "nLevel: ")
|
||||
(with-backends back (setf (go-level back) level)))
|
||||
|
||||
(defun go-board-next (&optional count)
|
||||
(interactive "p")
|
||||
(let (move)
|
||||
(dotimes (n (or count 1) move)
|
||||
(setf move (go-move *back-end*))
|
||||
(if (equal move :pass)
|
||||
(message "pass")
|
||||
(setf *turn* (other-color *turn*))
|
||||
(apply-turn-to-board
|
||||
(cons move (ignoring-unsupported (go-labels *back-end*)))))
|
||||
(with-trackers tr (setf (go-move tr) move))
|
||||
(if (equal move :pass)
|
||||
(goto-char (point-min))
|
||||
(goto-char (point-of-pos (cddr move)))))))
|
||||
|
||||
(defun go-board-mouse-move (ev)
|
||||
(interactive "e")
|
||||
(go-board-move (get-text-property (posn-point (event-start ev)) :pos)))
|
||||
|
||||
(defun go-board-quit ()
|
||||
(interactive)
|
||||
(when (y-or-n-p "quit: ")
|
||||
(kill-buffer (current-buffer))))
|
||||
|
||||
(defun go-board-safe-quit ()
|
||||
(ignore-errors (with-backends tr (go-quit tr)))
|
||||
t)
|
||||
|
||||
|
||||
;;; Display mode
|
||||
(defvar go-board-mode-map
|
||||
(let ((map (make-sparse-keymap)))
|
||||
(define-key map (kbd "<mouse-1>") 'go-board-mouse-move)
|
||||
(define-key map (kbd "m") 'go-board-move)
|
||||
(define-key map (kbd "r") 'go-board-refresh)
|
||||
(define-key map (kbd "R") 'go-board-resign)
|
||||
(define-key map (kbd "u") 'go-board-undo)
|
||||
(define-key map (kbd "c") 'go-board-comment)
|
||||
(define-key map (kbd "l") 'go-board-level)
|
||||
(define-key map (kbd "p") 'go-board-pass)
|
||||
(define-key map (kbd "<right>") 'go-board-next)
|
||||
(define-key map (kbd "<left>") 'go-board-undo)
|
||||
(define-key map (kbd "q") 'go-board-quit)
|
||||
map)
|
||||
"Keymap for `go-board-mode'.")
|
||||
|
||||
(define-derived-mode go-board-mode nil "GO"
|
||||
"Major mode for viewing a GO board."
|
||||
(set (make-local-variable 'kill-buffer-query-functions)
|
||||
(add-to-list 'kill-buffer-query-functions 'go-board-safe-quit)))
|
||||
|
||||
|
||||
;;; Class and interface
|
||||
(defclass board ()
|
||||
((buffer :initarg :buffer :accessor buffer :initform nil)))
|
||||
|
||||
(defmacro with-board (board &rest body)
|
||||
(declare (indent 1))
|
||||
`(with-current-buffer (buffer ,board) ,@body))
|
||||
|
||||
(defmethod go-size ((board board))
|
||||
(with-board board *size*))
|
||||
|
||||
(defmethod set-go-size ((board board) size)
|
||||
(with-board board (setq *size* size)))
|
||||
|
||||
(defmethod go-name ((board board))
|
||||
(un-ear-muffs (buffer-name (buffer board))))
|
||||
|
||||
(defmethod set-go-name ((board board) name)
|
||||
(with-board board (rename-buffer name 'unique)))
|
||||
|
||||
(defmethod go-move ((board board))
|
||||
(signal 'unsupported-back-end-command (list board :move)))
|
||||
|
||||
(defmethod set-go-move ((board board) move)
|
||||
(with-board board
|
||||
(setf *turn* (other-color *turn*))
|
||||
(apply-turn-to-board (list move))
|
||||
(goto-char (point-of-pos (cddr move)))
|
||||
(with-trackers tr (setf (go-move tr) move))))
|
||||
|
||||
(defmethod go-labels ((board board))
|
||||
(signal 'unsupported-back-end-command (list board :labels)))
|
||||
|
||||
(defmethod set-go-labels ((board board) labels)
|
||||
(signal 'unsupported-back-end-command (list board :set-labels labels)))
|
||||
|
||||
(defmethod go-comment ((board board))
|
||||
(signal 'unsupported-back-end-command (list board :comment)))
|
||||
|
||||
(defmethod set-go-comment ((board board) comment)
|
||||
(signal 'unsupported-back-end-command (list board :set-comment comment)))
|
||||
|
||||
(defmethod go-alt ((board board))
|
||||
(signal 'unsupported-back-end-command (list board :alt)))
|
||||
|
||||
(defmethod set-go-alt ((board board) alt)
|
||||
(signal 'unsupported-back-end-command (list board :set-alt alt)))
|
||||
|
||||
(defmethod go-color ((board board))
|
||||
(with-board board *turn*))
|
||||
|
||||
(defmethod set-go-color ((board board) color)
|
||||
(with-board board (setq *turn* color)))
|
||||
|
||||
(defmethod go-player-name ((board board) color)
|
||||
(with-board board (go-player-get color :name)))
|
||||
|
||||
(defmethod set-go-player-name ((board board) color name)
|
||||
(with-board board (go-player-set color :name name)))
|
||||
|
||||
(defmethod go-player-time ((board board) color)
|
||||
(with-board board (go-player-get color :time)))
|
||||
|
||||
(defmethod set-go-player-time ((board board) color time)
|
||||
(with-board board (go-player-set color :time time)))
|
||||
|
||||
(defmethod go-player-prisoners ((board board) color)
|
||||
(with-board board (go-player-get color :prisoners)))
|
||||
|
||||
(defmethod set-go-player-prisoners ((board board) color prisoners)
|
||||
(with-board board (go-player-set color :prisoners prisoners)))
|
||||
|
||||
;; non setf'able generic functions
|
||||
(defmethod go-undo ((board board))
|
||||
(with-board board (go-board-undo)))
|
||||
|
||||
(defmethod go-pass ((board board))
|
||||
(with-board board
|
||||
(message "pass")
|
||||
(setf *turn* (other-color *turn*))))
|
||||
|
||||
(defmethod go-resign ((board board))
|
||||
(with-board board (message "%s resign" *turn*)))
|
||||
|
||||
(defmethod go-reset ((board board))
|
||||
(with-board board
|
||||
(setf *history* nil)
|
||||
(update-display)))
|
||||
|
||||
(defmethod go-quit ((board board))
|
||||
(with-board board (go-quit)))
|
||||
|
||||
(provide 'go-board)
|
||||
;;; go-board.el ends here
|
||||
|
|
@ -1,7 +0,0 @@
|
|||
(define-package "go" "20160430.1739" "Play GO, translate and transfer between GO back ends"
|
||||
'((emacs "24"))
|
||||
:url "http://eschulte.github.io/el-go/" :keywords
|
||||
'("game" "go" "sgf"))
|
||||
;; Local Variables:
|
||||
;; no-byte-compile: t
|
||||
;; End:
|
||||
|
|
@ -1,177 +0,0 @@
|
|||
;;; go-util.el --- utility functions for GO functions
|
||||
|
||||
;; Copyright (C) 2012 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Eric Schulte <schulte.eric@gmail.com>
|
||||
;; Created: 2012-05-15
|
||||
;; Version: 0.1
|
||||
;; Keywords: game go sgf
|
||||
|
||||
;; This software is free software: you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; This software 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 for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Code:
|
||||
(eval-when-compile (require 'cl))
|
||||
(require 'assoc)
|
||||
|
||||
(defun curry (function &rest arguments)
|
||||
(lexical-let ((function function)
|
||||
(arguments arguments))
|
||||
(lambda (&rest more) (apply function (append arguments more)))))
|
||||
|
||||
(defun rcurry (function &rest arguments)
|
||||
(lexical-let ((function function)
|
||||
(arguments arguments))
|
||||
(lambda (&rest more) (apply function (append more arguments)))))
|
||||
|
||||
(defun compose (function &rest more-functions)
|
||||
(cl-reduce (lambda (f g)
|
||||
(lexical-let ((f f) (g g))
|
||||
(lambda (&rest arguments)
|
||||
(funcall f (apply g arguments)))))
|
||||
more-functions
|
||||
:initial-value function))
|
||||
|
||||
(defun indexed (list)
|
||||
(loop for el in list as i from 0 collect (list i el)))
|
||||
|
||||
(defun rcons (x lst)
|
||||
(append lst (list x)))
|
||||
|
||||
(defmacro rpush (x place)
|
||||
"Insert X at the back of the list stored in PLACE."
|
||||
(if (symbolp place) (list 'setq place (list 'rcons x place))
|
||||
(list 'callf2 'rcons x place)))
|
||||
|
||||
(defun range (a &optional b)
|
||||
(block nil
|
||||
(let (tmp)
|
||||
(unless b
|
||||
(cond ((> a 0) (decf a))
|
||||
((= a 0) (return nil))
|
||||
((> 0 a) (incf a)))
|
||||
(setq b a a 0))
|
||||
(if (> a b) (setq tmp a a b b tmp))
|
||||
(let ((res (number-sequence a b)))
|
||||
(if tmp (nreverse res) res)))))
|
||||
|
||||
(defun take (num list) (subseq list 0 num))
|
||||
|
||||
(defun set-aget (list key new)
|
||||
(if (aget list key)
|
||||
(setf (cdr (assoc key list)) new)
|
||||
(setf (cdr (last list)) (list (cons key new)))))
|
||||
|
||||
(defsetf aget set-aget)
|
||||
|
||||
(defmacro until (test &rest body)
|
||||
(declare (indent 1))
|
||||
`(while (not ,test) ,@body))
|
||||
|
||||
(defun alistp (list)
|
||||
(and (listp list)
|
||||
(listp (car list))
|
||||
(not (listp (caar list)))))
|
||||
|
||||
(defun pos-to-index (pos size)
|
||||
(+ (car pos) (* (cdr pos) size)))
|
||||
|
||||
(defun transpose-array (board)
|
||||
(let ((size (round (sqrt (length board))))
|
||||
(trans (make-vector (length board) nil)))
|
||||
(dotimes (row size trans)
|
||||
(dotimes (col size)
|
||||
(setf (aref trans (pos-to-index (cons row col) size))
|
||||
(aref board (pos-to-index (cons col row) size)))))))
|
||||
|
||||
(defun ear-muffs (str) (concat "*" str "*"))
|
||||
|
||||
(defun un-ear-muffs (str)
|
||||
(let ((pen-ult (1- (length str))))
|
||||
(if (and (= ?\* (aref str 0))
|
||||
(= ?\* (aref str pen-ult)))
|
||||
(substring str 1 pen-ult)
|
||||
str)))
|
||||
|
||||
(defun char-to-num (char)
|
||||
(cl-flet ((err () (error "gtp: invalid char %s" char)))
|
||||
(cond
|
||||
((< char ?A) (err))
|
||||
((< char ?I) (- char ?A))
|
||||
((<= char ?T) (1- (- char ?A)))
|
||||
((< char ?a) (err))
|
||||
((< char ?i) (- char ?a))
|
||||
((<= char ?t) (1- (- char ?a)))
|
||||
(t (err)))))
|
||||
|
||||
(defun num-to-char (num)
|
||||
(cl-flet ((err () (error "gtp: invalid num %s" num)))
|
||||
(cond
|
||||
((< num 1) (err))
|
||||
((< num 9) (+ ?A (1- num)))
|
||||
(t (+ ?A num)))))
|
||||
|
||||
(defun sym-cat (&rest syms)
|
||||
(intern (mapconcat #'symbol-name (delq nil syms) "-")))
|
||||
|
||||
(defun go-number-p (string)
|
||||
"If STRING represents a number return its value."
|
||||
(if (and (string-match "[0-9]+" string)
|
||||
(string-match "^-?[0-9]*\\.?[0-9]*$" string)
|
||||
(= (length (substring string (match-beginning 0)
|
||||
(match-end 0)))
|
||||
(length string)))
|
||||
(string-to-number string)))
|
||||
|
||||
(defun go-clean-text-properties (string)
|
||||
(set-text-properties 0 (length string) nil string) string)
|
||||
|
||||
(defmacro go-re-cond (string &rest body)
|
||||
(declare (indent 1))
|
||||
`(save-match-data
|
||||
(cond ,@(mapcar
|
||||
(lambda (part)
|
||||
(cons (if (or (keywordp (car part)) (eq t (car part)))
|
||||
(car part)
|
||||
`(string-match ,(car part) ,string))
|
||||
(cdr part)))
|
||||
body))))
|
||||
(def-edebug-spec go-re-cond (form body))
|
||||
|
||||
(defvar *go-partial-line* nil "Holds partial lines of input from a process.")
|
||||
(defun make-go-insertion-filter (func)
|
||||
(lexical-let ((func func))
|
||||
(lambda (proc string)
|
||||
(with-current-buffer (process-buffer proc)
|
||||
(let ((moving (= (point) (process-mark proc))))
|
||||
(save-excursion
|
||||
(goto-char (process-mark proc))
|
||||
(insert string)
|
||||
(set-marker (process-mark proc) (point))
|
||||
(let ((lines (split-string (if *go-partial-line*
|
||||
(concat *go-partial-line* string)
|
||||
string)
|
||||
"[\n\r]")))
|
||||
(if (string-match "[\n\r]$" (car (last lines)))
|
||||
(setf *go-partial-line* nil)
|
||||
(setf *go-partial-line* (car (last lines)))
|
||||
(setf lines (butlast lines)))
|
||||
(mapc (lambda (s) (funcall func proc s)) lines)))
|
||||
(when moving (goto-char (process-mark proc))))))))
|
||||
|
||||
(defalias 'go-completing-read (if (fboundp 'org-icompleting-read)
|
||||
'org-icompleting-read
|
||||
'completing-read))
|
||||
|
||||
(provide 'go-util)
|
||||
;;; go-util.el ends here
|
||||
|
|
@ -1,87 +0,0 @@
|
|||
;;; go.el --- Play GO, translate and transfer between GO back ends
|
||||
|
||||
;; Copyright (C) 2012 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Eric Schulte <schulte.eric@gmail.com>
|
||||
;; Maintainer: Eric Schulte <schulte.eric@gmail.com>
|
||||
;; Version: 0.0.1
|
||||
;; Package-Requires: ((emacs "24"))
|
||||
;; Created: 2012-05-15
|
||||
;; Keywords: game go sgf
|
||||
;; URL: http://eschulte.github.io/el-go/
|
||||
|
||||
;; This software is free software: you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; This software 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 for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; A board-based interface to GO games which may be connected to a
|
||||
;; number of GO back-ends through a generic API. To play a game of GO
|
||||
;; against the gnugo back-end run `play-go'. Current back-ends
|
||||
;; include the following.
|
||||
;; - the SGF format
|
||||
;; - the Go Text Protocol (GTP)
|
||||
;; - TODO: the IGS protocol
|
||||
|
||||
;;; Code:
|
||||
(let ((load-path
|
||||
(cons (file-name-directory (or load-file-name (buffer-file-name)))
|
||||
load-path)))
|
||||
(require 'go-util "go-util.el")
|
||||
(require 'go-api "go-api.el")
|
||||
(require 'go-board "go-board.el")
|
||||
(require 'go-board-faces "go-board-faces.el")
|
||||
(require 'gtp "back-ends/gtp.el")
|
||||
(require 'gnugo "back-ends/gnugo.el")
|
||||
(require 'sgf "back-ends/sgf.el")
|
||||
(require 'sgf2el "back-ends/sgf2el.el")
|
||||
(require 'igs "back-ends/igs.el")
|
||||
(require 'gtp-pipe "back-ends/gtp-pipe.el"))
|
||||
|
||||
(defun go-instantiate (back-end)
|
||||
(interactive)
|
||||
;; TODO: read and set handicap.
|
||||
(let ((it (make-instance back-end))
|
||||
(size (read (go-completing-read
|
||||
"board size: "
|
||||
(mapcar #'number-to-string '(19 13 9))))))
|
||||
(go-connect it)
|
||||
(setf (go-size it) size)
|
||||
it))
|
||||
|
||||
;;;###autoload
|
||||
(defun go-play ()
|
||||
"Play a game of GO."
|
||||
(interactive)
|
||||
(let ((back-end (case (intern (go-completing-read
|
||||
"play against: " '("gnugo" "person")))
|
||||
(gnugo (go-instantiate 'gnugo))
|
||||
(person (go-instantiate 'sgf)))))
|
||||
(with-current-buffer (apply #'go-board
|
||||
(cons back-end
|
||||
(unless (equal (class-of back-end) 'sgf)
|
||||
(list (make-instance 'sgf)))))
|
||||
(unless (equal (class-of back-end) 'sgf)
|
||||
(setq *autoplay* t)))))
|
||||
|
||||
;;;###autoload
|
||||
(defun go-view-sgf (&optional file)
|
||||
"View an SGF file."
|
||||
(interactive "fSGF file: ")
|
||||
(let* ((sgf (make-instance 'sgf :self (sgf2el-file-to-el file) :index '(0)))
|
||||
(buffer (go-board sgf)))
|
||||
(with-current-buffer buffer
|
||||
(setf (index *back-end*) (list 0)))))
|
||||
|
||||
(provide 'go)
|
||||
;;; go.el ends here
|
||||
|
|
@ -1,192 +0,0 @@
|
|||
;;; list-buffer.el --- view a list as a table in a buffer
|
||||
|
||||
;; Copyright (C) 2013 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Eric Schulte <schulte.eric@gmail.com>
|
||||
;; Created: 2013-08-02
|
||||
;; Version: 0.1
|
||||
;; Keywords: list buffer cl
|
||||
|
||||
;; This software is free software: you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; This software 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 for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Code:
|
||||
(eval-when-compile (require 'cl))
|
||||
(require 'go-util)
|
||||
|
||||
(defvar *buffer-list* nil
|
||||
"List associated with the current list buffer.")
|
||||
|
||||
(defvar *buffer-headers* nil
|
||||
"Headers associated with the current list buffer.")
|
||||
|
||||
(defvar *buffer-width* nil
|
||||
"Width associated with the current list buffer.")
|
||||
|
||||
(defvar *enter-function* nil
|
||||
"Function used to enter a list element.
|
||||
The function should take two arguments, the current row and
|
||||
column respectively and may access the current buffer list
|
||||
through the `*buffer-list*' variable.")
|
||||
|
||||
(defvar *refresh-function* nil
|
||||
"Function used to refresh a list element or the whole list.
|
||||
The function should take two arguments, the current row and
|
||||
column respectively and may access the current buffer list
|
||||
through the `*buffer-list*' variable.")
|
||||
|
||||
(defun list-buffer-create
|
||||
(buffer list &optional headers enter-function refresh-function)
|
||||
(pop-to-buffer buffer)
|
||||
(list-mode)
|
||||
(set (make-local-variable '*buffer-width*) (window-total-width))
|
||||
(set (make-local-variable '*buffer-list*) list)
|
||||
(set (make-local-variable '*buffer-headers*)
|
||||
(mapcar (curry #'format "%s") headers))
|
||||
(set (make-local-variable '*enter-function*)
|
||||
(or enter-function
|
||||
(lambda (row col)
|
||||
(message "enter %S" (nth col (nth row *buffer-list*))))))
|
||||
(set (make-local-variable '*refresh-function*)
|
||||
(or refresh-function
|
||||
(lambda (row col)
|
||||
(message "refresh %S" (nth col (nth row *buffer-list*))))))
|
||||
;; refresh every time the buffer changes size
|
||||
(set (make-local-variable 'window-size-change-functions)
|
||||
(cons (lambda (b)
|
||||
(when (or (not (numberp *buffer-width*))
|
||||
(not (equal *buffer-width* (window-total-width))))
|
||||
(set '*buffer-width* (window-total-width))
|
||||
(list-buffer-refresh)))
|
||||
window-size-change-functions))
|
||||
(goto-char (point-min))
|
||||
(list-buffer-refresh))
|
||||
|
||||
(defun list-format-row (widths row &optional row-num)
|
||||
(cl-flet ((num (type number string)
|
||||
(put-text-property 0 (length string) type number string)
|
||||
string))
|
||||
(let ((col 0))
|
||||
(num :row row-num
|
||||
(apply #'concat
|
||||
(cl-mapcar
|
||||
(lambda (width cell)
|
||||
(prog1
|
||||
(num :col col
|
||||
(if (< (length cell) width)
|
||||
(concat cell
|
||||
(make-list (- width (length cell))
|
||||
?\ ))
|
||||
(concat (subseq cell 0 (- width 2)) "… ")))
|
||||
(incf col)))
|
||||
widths row))))))
|
||||
|
||||
(defun list-buffer-refresh ()
|
||||
(when *buffer-list*
|
||||
(let* ((start (point))
|
||||
(strings (mapcar (curry #'mapcar (curry #'format "%s")) *buffer-list*))
|
||||
(lengths (mapcar (curry #'mapcar #'length)
|
||||
(if *buffer-headers*
|
||||
(cons *buffer-headers* strings)
|
||||
strings)))
|
||||
(widths (apply #'cl-mapcar (compose '1+ #'max) lengths))
|
||||
;; scale widths by buffer width
|
||||
(widths (mapcar (compose #'floor (curry #'* (/ (window-total-width)
|
||||
(float (apply #'+ widths)))))
|
||||
widths)))
|
||||
;; write headers
|
||||
(when *buffer-headers*
|
||||
(set (make-local-variable 'header-line-format)
|
||||
(concat " " (list-format-row widths *buffer-headers*))))
|
||||
;; write rows
|
||||
(delete-region (point-min) (point-max))
|
||||
(insert (mapconcat (compose (curry #'apply #'list-format-row widths) #'reverse)
|
||||
(indexed strings) "\n"))
|
||||
(goto-char start))))
|
||||
|
||||
(defun list-buffer-sort (col predicate)
|
||||
(set '*buffer-list* (cl-sort *buffer-list* predicate :key (curry #'nth col)))
|
||||
(list-buffer-refresh))
|
||||
|
||||
(defun list-current-row () (get-text-property (point) :row))
|
||||
|
||||
(defun list-current-col () (get-text-property (point) :col))
|
||||
|
||||
(defun list< (a b)
|
||||
(cond
|
||||
((and (numberp a) (numberp b) (< a b)))
|
||||
((and (stringp a) (stringp b) (string< a b)))))
|
||||
|
||||
(defun list> (a b)
|
||||
(cond
|
||||
((and (numberp a) (numberp b) (> a b)))
|
||||
((and (stringp a) (stringp b) (string> a b)))))
|
||||
|
||||
(defun list-up ()
|
||||
(interactive)
|
||||
(list-buffer-sort (get-text-property (point) :col) #'list<))
|
||||
|
||||
(defun list-down ()
|
||||
(interactive)
|
||||
(list-buffer-sort (get-text-property (point) :col) #'list>))
|
||||
|
||||
(defun list-enter ()
|
||||
(interactive)
|
||||
(funcall *enter-function* (list-current-row) (list-current-col)))
|
||||
|
||||
(defun list-refresh ()
|
||||
(interactive)
|
||||
(funcall *refresh-function* (list-current-row) (list-current-col)))
|
||||
|
||||
(defun list-filter ()
|
||||
(interactive)
|
||||
(error "not implemented."))
|
||||
|
||||
(defun list-move-col (direction)
|
||||
(cl-flet ((col () (or (get-text-property (point) :col) start-col)))
|
||||
(let ((start-col (col)))
|
||||
(while (= start-col (col))
|
||||
(case direction
|
||||
(:forward (forward-char))
|
||||
(:backward (backward-char))))
|
||||
(when (eql direction :backward)
|
||||
(let ((end-col (col)))
|
||||
(while (= end-col (col)) (backward-char))
|
||||
(forward-char))))))
|
||||
|
||||
(defun list-next-col () (interactive) (list-move-col :forward))
|
||||
(defun list-prev-col () (interactive) (list-move-col :backward))
|
||||
|
||||
(defvar list-mode-map
|
||||
(let ((map (make-sparse-keymap)))
|
||||
;; navigation
|
||||
(define-key map (kbd "j") 'next-line)
|
||||
(define-key map (kbd "k") 'previous-line)
|
||||
(define-key map (kbd "u") 'scroll-down-command)
|
||||
(define-key map (kbd "<tab>") 'list-next-col)
|
||||
(define-key map (kbd "<S-iso-lefttab>") 'list-prev-col)
|
||||
;; list functions
|
||||
(define-key map (kbd "<up>") 'list-up)
|
||||
(define-key map (kbd "<down>") 'list-down)
|
||||
(define-key map (kbd "f") 'list-filter)
|
||||
(define-key map (kbd "r") 'list-refresh)
|
||||
(define-key map (kbd "RET") 'list-enter)
|
||||
(define-key map (kbd "q") 'bury-buffer)
|
||||
map)
|
||||
"Keymap for `list-mode'.")
|
||||
|
||||
(define-derived-mode list-mode nil "list"
|
||||
"Major mode for viewing a list.")
|
||||
|
||||
(provide 'list-buffer)
|
||||
;;; list-buffer.el ends here
|
||||
Binary file not shown.
Loading…
Reference in New Issue