gergely/my-emacs-d
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Move from go to gnugo

Browse Source
This commit is contained in:
Gergely Polonkai 2016-09-26 19:35:49 +02:00
parent ef6c0c41f2
commit b8052b9da2
24 changed files with 6389 additions and 2499 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
elpa/gnugo-3.0.0/.dir-locals.el Normal file
View File

@ -0,0 +1,5 @@
;;; .dir-locals.el
((emacs-lisp-mode . ((indent-tabs-mode . nil))))
;;; .dir-locals.el ends here

2486
elpa/gnugo-3.0.0/ChangeLog Normal file
View File

File diff suppressed because it is too large Load Diff

82
elpa/gnugo-3.0.0/HACKING Normal file
View File

@ -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.

205
elpa/gnugo-3.0.0/NEWS Normal file
View File

@ -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.

6
elpa/gnugo-3.0.0/README Normal file
View File

@ -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.

94
elpa/gnugo-3.0.0/gnugo-autoloads.el Normal file
View File

@ -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

509
elpa/gnugo-3.0.0/gnugo-frolic.el Normal file
View File

@ -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

247
elpa/gnugo-3.0.0/gnugo-imgen.el Normal file
View File

@ -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

2
elpa/gnugo-3.0.0/gnugo-pkg.el Normal file
View File

@ -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"))

2753
elpa/gnugo-3.0.0/gnugo.el Normal file
View File

File diff suppressed because it is too large Load Diff

122
elpa/go-20160430.1739/back-ends/gtp-pipe.el
View File

@ -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

164
elpa/go-20160430.1739/back-ends/gtp.el
View File

@ -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

501
elpa/go-20160430.1739/back-ends/igs.el
View File

@ -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

196
elpa/go-20160430.1739/back-ends/sgf.el
View File

@ -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

188
elpa/go-20160430.1739/back-ends/sgf2el.el
View File

@ -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

78
elpa/go-20160430.1739/go-api.el
View File

@ -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

32
elpa/go-20160430.1739/go-autoloads.el
View File

@ -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

177
elpa/go-20160430.1739/go-board-faces.el
View File

@ -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

578
elpa/go-20160430.1739/go-board.el
View File

@ -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

7
elpa/go-20160430.1739/go-pkg.el
View File

@ -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:

177
elpa/go-20160430.1739/go-util.el
View File

@ -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

87
elpa/go-20160430.1739/go.el
View File

@ -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

192
elpa/go-20160430.1739/list-buffer.el
View File

@ -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

BIN
elpa/go-20160430.1739/stone.wav
View File

Binary file not shown.