1 ;;; gnugo-frolic.el --- gametree in a buffer -*- lexical-binding: t -*-
3 ;; Copyright (C) 2014 Free Software Foundation, Inc.
5 ;; Author: Thien-Thi Nguyen <ttn@gnu.org>
6 ;; Maintainer: Thien-Thi Nguyen <ttn@gnu.org>
8 ;; This program is free software; you can redistribute it and/or modify
9 ;; it under the terms of the GNU General Public License as published by
10 ;; the Free Software Foundation, either version 3 of the License, or
11 ;; (at your option) any later version.
13 ;; This program is distributed in the hope that it will be useful,
14 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 ;; GNU General Public License for more details.
18 ;; You should have received a copy of the GNU General Public License
19 ;; along with this program. If not, see <http://www.gnu.org/licenses/>.
25 (require 'ascii-art-to-unicode) ; for `aa2u'
27 (defvar gnugo-frolic-mode-map
28 (let ((map (make-sparse-keymap)))
31 (define-key map (car pair) (cdr pair)))
32 '(("q" . gnugo-frolic-quit)
33 ("Q" . gnugo-frolic-quit)
34 ("\C-q" . gnugo-frolic-quit)
35 ("C" . gnugo-frolic-quit) ; like ‘View-kill-and-leave’
36 ("\C-b" . gnugo-frolic-backward-branch)
37 ("\C-f" . gnugo-frolic-forward-branch)
38 ("\C-p" . gnugo-frolic-previous-move)
39 ("\C-n" . gnugo-frolic-next-move)
40 ("t" . gnugo-frolic-tip-move)
41 ("j" . gnugo-frolic-exchange-left)
42 ("J" . gnugo-frolic-rotate-left)
43 ("k" . gnugo-frolic-exchange-right)
44 ("K" . gnugo-frolic-rotate-right)
45 ("\C-m" . gnugo-frolic-set-as-main-line)
46 ("\C-\M-p" . gnugo-frolic-prune-branch)
47 ("o" . gnugo-frolic-return-to-origin)))
49 "Keymap for GNUGO Frolic mode.")
51 (defvar gnugo-frolic-parent-buffer nil)
52 (defvar gnugo-frolic-origin nil)
54 (define-derived-mode gnugo-frolic-mode special-mode "GNUGO Frolic"
55 "A special mode for manipulating a GNUGO gametree."
56 (setq truncate-lines t)
57 (buffer-disable-undo))
59 (defun gnugo-frolic-quit ()
60 "Kill GNUGO Frolic buffer and switch to its parent buffer."
62 (let ((bye (current-buffer)))
63 (switch-to-buffer (when (buffer-live-p gnugo-frolic-parent-buffer)
64 gnugo-frolic-parent-buffer))
67 (defun gnugo-frolic-return-to-origin ()
68 "Move point to the board's current position."
70 (if (not gnugo-frolic-origin)
72 (goto-char gnugo-frolic-origin)
73 (recenter (- (count-lines (line-beginning-position)
77 (defun gnugo-frolic-in-the-leaves ()
78 "Display the game tree in a *GNUGO Frolic* buffer.
79 This looks something like:
82 2 W -- K10 K10 K10 K10
101 with 0, 1, ... N (in this case N is 3) in the header line
102 to indicate the branches. Branch 0 is the \"main line\".
103 Point (* in this example) indicates the current position,
104 \"!\" indicates comment properties (e.g., B8, branch 1),
105 and moves not actually on the game tree (e.g., E7, branch 3)
106 are dimmed. Type \\[describe-mode] in that buffer for details."
108 (let* ((buf (get-buffer-create (concat (gnugo-get :diamond)
110 (from (or gnugo-frolic-parent-buffer
112 ;; todo: use defface once we finally succumb to ‘customize’
113 (dimmed-node-face (list :inherit 'default
114 :foreground "gray50"))
115 (tree (gnugo-get :sgf-gametree))
116 (ends (copy-sequence (gnugo--tree-ends tree)))
117 (mnum (gnugo--tree-mnum tree))
120 (width (length ends))
121 (lanes (number-sequence 0 (1- width)))
122 (monkey (gnugo-get :monkey))
123 (as-pos (gnugo--as-pos-func))
124 (at (car (aref monkey 0)))
125 (bidx (aref monkey 1))
126 (valid (cl-map 'vector (lambda (end)
127 (gethash (car end) mnum))
129 (max-move-num (apply 'max (append valid nil)))
130 (inhibit-read-only t)
136 (propertize s 'face face))
137 (fsi (properties fmt &rest args)
138 (insert (apply 'propertize
139 (apply 'format fmt args)
146 for node in (aref ends bx)
147 do (if (setq fork (on node))
150 ;; todo: ignore non-"move" nodes
151 (eq node (car (aref ends bix))))
153 (cl-pushnew other (gethash node soil))))
158 (puthash node bx seen))
161 (switch-to-buffer buf)
164 (setq header-line-format
167 (mapconcat (lambda (n)
177 `(space :width ,w))))
179 (when (eq 'left scroll-bar-mode)
180 (let ((w (or scroll-bar-width
182 nil 'scroll-bar-width)))
183 (cw (frame-char-width)))
187 (let ((fc (fringe-columns 'left t)))
191 (substring full (window-hscroll))
193 (set (make-local-variable 'gnugo-frolic-parent-buffer) from)
194 (set (make-local-variable 'gnugo-state)
195 (buffer-local-value 'gnugo-state from))
199 from max-move-num downto 1
200 do (setq props (list 'n n))
205 (goto-char (point-min))
208 n (aref ["W" "B"] (logand 1 n))))
210 do (let* ((node (unless (< (aref valid bx) n)
211 ;; todo: ignore non-"move" nodes
212 (pop (aref ends bx))))
213 (zow `(bx ,bx ,@props))
217 (cdr (assq :C node))))
218 (s (cond ((not node) "")
219 ((not (setq move (gnugo--move-prop node))) "-")
220 (t (funcall as-pos (cdr move))))))
223 (push 'help-echo zow))
224 (when (and ok (setq br (gethash node soil)))
225 (push (cons bx (sort br '<))
230 (cond ((and (eq at node)
233 (setq finish (point-marker)))
234 (emph s (list :inherit 'default
235 :foreground (frame-parameter
236 nil 'cursor-color))))
238 (emph s dimmed-node-face))
241 (when (progn (fsi props "\n")
242 (setq forks (nreverse forks)))
243 (let* ((margin (make-string 11 ?\s))
244 (heads (mapcar #'car forks))
245 (tails (mapcar #'cdr forks)))
247 ((spaced (lanes func)
248 (mapconcat func lanes " "))
249 ;; live to play ~ ~ ()
250 ;; play to learn (+) (-) . o O
251 ;; learn to live --ttn .M. _____U
252 (dashed (lanes func) ;;; _____ ^^^^
253 (mapconcat func lanes "-----"))
255 (spaced lanes (lambda (bx)
259 (pad-unless (condition)
271 do (let* ((one (car ls))
274 (mapcar 'car (cdr ls))
276 (apply 'append (mapcar 'cdr bef))))
279 (end (car (last ord))))
281 ((also (b e) (cnxn (number-sequence b e)
286 (pad-unless (zerop beg))
287 (dashed (number-sequence beg end)
289 (cond ((memq bx ord) "+")
292 (pad-unless (>= end width))
293 (also (1+ end) (1- width))
296 (edge (apply 'append tails))
297 (aa2u (line-beginning-position
298 (- (1+ (length forks))))
301 (set (make-local-variable 'gnugo-frolic-origin) finish)
302 (gnugo-frolic-return-to-origin))))
304 (defun gnugo--awake (how)
305 ;; Valid HOW elements:
306 ;; require-valid-branch
308 ;; (line . move-string)
310 ;; Invalid elements blissfully ignored. :-D
311 (let* ((tree (gnugo-get :sgf-gametree))
312 (ends (gnugo--tree-ends tree))
313 (width (length ends))
314 (monkey (gnugo-get :monkey))
315 (line (cl-case (cdr (assq 'line how))
317 (count-lines (point-min) (line-beginning-position)))
320 (when (re-search-backward "^ *[0-9]+ [BW]" nil t)
323 (col (current-column))
324 (a (unless (> 10 col)
325 (let ((try (/ (- col 10)
327 (unless (<= width try)
330 (when (memq 'require-valid-branch how)
332 (user-error "No branch here")))
334 with omit = (cdr (assq 'omit how))
335 for (name . value) in `((line . ,line)
336 (bidx . ,(aref monkey 1))
341 do (unless (memq name omit)
345 (defmacro gnugo--awakened (how &rest body)
347 `(cl-destructuring-bind
349 with omit = (cdr (assq 'omit how))
351 for name in '(line bidx monkey
354 do (unless (memq name omit)
360 (defsubst gnugo--move-to-bcol (bidx)
361 (move-to-column (+ 10 (* 6 bidx))))
363 (defun gnugo--swiz (direction &optional blunt)
364 (gnugo--awakened (require-valid-branch
367 (let* ((b (cond ((numberp blunt)
368 (unless (and (< -1 blunt)
370 (user-error "No such branch: %s" blunt))
372 (t (mod (+ direction a) width))))
373 (flit (if blunt (lambda (n)
378 (mod (+ direction n) width))))
379 (was (copy-sequence ends))
380 (new-bidx (funcall flit bidx)))
383 do (aset ends (funcall flit bx)
385 (unless (= new-bidx bidx)
386 (aset monkey 1 new-bidx))
387 (gnugo-frolic-in-the-leaves)
388 (goto-char (point-min))
390 (gnugo--move-to-bcol b))))
392 (defun gnugo-frolic-exchange-left ()
393 "Exchange the current branch with the one to its left."
397 (defun gnugo-frolic-rotate-left ()
398 "Rotate all branches left."
402 (defun gnugo-frolic-exchange-right ()
403 "Exchange the current branch with the one to its right."
407 (defun gnugo-frolic-rotate-right ()
408 "Rotate all branches right."
412 (defun gnugo-frolic-set-as-main-line ()
413 "Make the current branch the main line."
417 (defun gnugo-frolic-prune-branch ()
418 "Remove the current branch from the gametree.
419 This fails if there is only one branch in the tree.
420 This fails if the monkey is on the current branch
421 \(a restriction that will probably be lifted Real Soon Now\)."
423 (gnugo--awakened (require-valid-branch
424 (line . move-string))
425 ;; todo: define meaningful eviction semantics; remove restriction
427 (user-error "Cannot prune with monkey on branch"))
429 (user-error "Cannot prune last remaining branch"))
430 (let ((new (append ends nil)))
431 ;; Explicit ignorance avoids byte-compiler warning.
432 (ignore (pop (nthcdr a new)))
433 (gnugo--set-tree-ends tree new))
435 (aset monkey 1 (cl-decf bidx)))
436 (gnugo-frolic-in-the-leaves)
438 (goto-char (point-min))
439 (search-forward line)
440 (gnugo--move-to-bcol (min a (- width 2))))))
442 (defun gnugo--sideways (backwards n)
443 (gnugo--awakened ((omit tree ends monkey bidx line))
444 (gnugo--move-to-bcol (mod (if backwards
449 (defun gnugo-frolic-backward-branch (&optional n)
450 "Move backward N (default 1) branches."
452 (gnugo--sideways t n))
454 (defun gnugo-frolic-forward-branch (&optional n)
455 "Move forward N (default 1) branches."
457 (gnugo--sideways nil n))
459 (defun gnugo--vertical (n direction)
462 direction (- direction)))
463 (gnugo--awakened ((line . numeric)
464 (omit tree ends width monkey bidx))
465 (let ((stop (if (> 0 direction)
467 (max 0 (1- (count-lines (point-min)
472 while (not (= line stop))
475 (forward-line direction)
476 (cl-incf line direction))
477 until (get-text-property (point) 'n))
478 until (zerop (cl-decf n)))
480 (gnugo--move-to-bcol a)
481 (move-to-column col)))))
483 (defun gnugo-frolic-previous-move (&optional n)
484 "Move to the Nth (default 1) previous move."
486 (gnugo--vertical n -1))
488 (defun gnugo-frolic-next-move (&optional n)
489 "Move to the Nth (default 1) next move."
491 (gnugo--vertical n 1))
493 (defun gnugo-frolic-tip-move ()
494 "Move to the tip of the current branch."
496 (gnugo--awakened ((omit line bidx monkey width)
497 require-valid-branch)
498 (goto-char (point-max))
499 (let ((mnum (gnugo--tree-mnum tree))
500 (node (car (aref ends a))))
501 (re-search-backward (format "^%3d" (gethash node mnum)))
502 (gnugo--move-to-bcol a))))
504 ;;;---------------------------------------------------------------------------
507 (provide 'gnugo-frolic)
509 ;;; gnugo-frolic.el ends here