my-emacs-d/elpa/gnugo-3.0.0/gnugo-frolic.el
2016-09-26 19:35:49 +02:00

510 lines
18 KiB
EmacsLisp
Raw Blame History

This file contains ambiguous Unicode characters

This file contains Unicode characters that might be confused with other characters. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

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