ttn pushed a commit to branch master in repository elpa. commit 73cda40d1795e8fc2d76d3aa9cb4ca2716ca354f Author: Thien-Thi Nguyen <t...@gnu.org> Date: Wed May 21 08:24:28 2014 +0200
[gnugo frolic] Promote frolic mode/funcs to feature. * packages/gnugo/gnugo.el (gnugo-frolic-mode-map) (gnugo-frolic-parent-buffer, gnugo-frolic-origin) (gnugo-frolic-mode, gnugo-frolic-return-to-origin) (gnugo-frolic-in-the-leaves, gnugo--awake, gnugo--awakened) (gnugo--move-to-bcol, gnugo--swiz, gnugo-frolic-exchange-left) (gnugo-frolic-rotate-left, gnugo-frolic-exchange-right) (gnugo-frolic-rotate-right, gnugo-frolic-set-as-main-line) (gnugo-frolic-prune-branch, gnugo--sideways) (gnugo-frolic-backward-branch, gnugo-frolic-forward-branch) (gnugo--vertical, gnugo-frolic-previous-move, gnugo-frolic-next-move) (gnugo-frolic-tip-move, gnugo-frolic-mode-map): Move from here... * packages/gnugo/gnugo-frolic.el: ...to new file; add ‘provide’ form; add autoload cookie for ‘gnugo-frolic-in-the-leaves’. --- packages/gnugo/NEWS | 2 + packages/gnugo/gnugo-frolic.el | 501 ++++++++++++++++++++++++++++++++++++++++ packages/gnugo/gnugo.el | 472 ------------------------------------- 3 files changed, 503 insertions(+), 472 deletions(-) diff --git a/packages/gnugo/NEWS b/packages/gnugo/NEWS index c4d6ae2..da45ca6 100644 --- a/packages/gnugo/NEWS +++ b/packages/gnugo/NEWS @@ -38,6 +38,8 @@ NB: "RCS: X..Y " means that the particular release includes - 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) diff --git a/packages/gnugo/gnugo-frolic.el b/packages/gnugo/gnugo-frolic.el new file mode 100644 index 0000000..71bb0e4 --- /dev/null +++ b/packages/gnugo/gnugo-frolic.el @@ -0,0 +1,501 @@ +;;; gnugo-frolic.el --- gametree in a buffer -*- lexical-binding: t -*- + +;; Copyright (C) 2014 Free Software Foundation, Inc. + +;; 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: + +(defvar gnugo-frolic-mode-map nil + "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. + +\\{gnugo-frolic-mode-map}" + (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 (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 + (loop + for bx below width + do (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) + (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 + (lexical-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)) + (loop + with props + for n ; move number + from max-move-num downto 1 + do (setq props (list 'n n)) + do + (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 (list* '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) + (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 (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"))) + (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)) + `(destructuring-bind ,(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))) + (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 (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)))) + (loop while (not (= line stop)) + do (loop do (progn + (forward-line direction) + (incf line direction)) + until (get-text-property (point) 'n)) + until (zerop (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)))) + +;;;--------------------------------------------------------------------------- +;;; load-time actions + +(unless gnugo-frolic-mode-map + (setq gnugo-frolic-mode-map (make-sparse-keymap)) + (suppress-keymap gnugo-frolic-mode-map) + (mapc (lambda (pair) + (define-key gnugo-frolic-mode-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)))) + +;;;--------------------------------------------------------------------------- +;;; that's it + +(provide 'gnugo-frolic) + +;;; gnugo-frolic.el ends here diff --git a/packages/gnugo/gnugo.el b/packages/gnugo/gnugo.el index 24cd470..bf6ca27 100644 --- a/packages/gnugo/gnugo.el +++ b/packages/gnugo/gnugo.el @@ -115,9 +115,6 @@ For more information on GTP and GNU Go, please visit: (defvar gnugo-board-mode-map nil "Keymap for GNUGO Board mode.") -(defvar gnugo-frolic-mode-map nil - "Keymap for GNUGO Frolic mode.") - (defvar gnugo-board-mode-hook nil "Hook run when entering GNUGO Board mode.") @@ -222,9 +219,6 @@ list of forms.") (defvar gnugo-state nil) ; hint: C-c C-p -(defvar gnugo-frolic-parent-buffer nil) -(defvar gnugo-frolic-origin nil) - (defvar gnugo-btw nil) ;;;--------------------------------------------------------------------------- @@ -823,450 +817,6 @@ For all other values of RSEL, do nothing and return nil." return (funcall as-pos move))) (_ nil))))) -(define-derived-mode gnugo-frolic-mode special-mode "GNUGO Frolic" - "A special mode for manipulating a GNUGO gametree. - -\\{gnugo-frolic-mode-map}" - (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)))))) - -(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 (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 - (loop - for bx below width - do (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) - (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 - (lexical-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)) - (loop - with props - for n ; move number - from max-move-num downto 1 - do (setq props (list 'n n)) - do - (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 (list* '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) - (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 (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"))) - (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)) - `(destructuring-bind ,(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))) - (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 (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)))) - (loop while (not (= line stop)) - do (loop do (progn - (forward-line direction) - (incf line direction)) - until (get-text-property (point) 'n)) - until (zerop (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)))) - (defun gnugo-boss-is-near () "Do `bury-buffer' until the current one is not a GNU Board." (interactive) @@ -2702,28 +2252,6 @@ See `gnugo-board-mode' for a full list of commands." ;;;--------------------------------------------------------------------------- ;;; Load-time actions -(unless gnugo-frolic-mode-map - (setq gnugo-frolic-mode-map (make-sparse-keymap)) - (suppress-keymap gnugo-frolic-mode-map) - (mapc (lambda (pair) - (define-key gnugo-frolic-mode-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)))) - (unless gnugo-board-mode-map (setq gnugo-board-mode-map (make-sparse-keymap)) (suppress-keymap gnugo-board-mode-map)