diff options
Diffstat (limited to 'lisp/play/gametree.el')
| -rw-r--r-- | lisp/play/gametree.el | 465 |
1 files changed, 465 insertions, 0 deletions
diff --git a/lisp/play/gametree.el b/lisp/play/gametree.el new file mode 100644 index 00000000000..40cd2bfd207 --- /dev/null +++ b/lisp/play/gametree.el @@ -0,0 +1,465 @@ +;;; gametree.el --- manage game analysis trees in Emacs + +;; Copyright (C) 1997 Free Software Foundation, Inc + +;; Author: Ian T Zimmerman <itz@rahul.net> +;; Created: Wed Dec 10 07:41:46 PST 1997 +;; Keywords: games + +;; This file is part of GNU Emacs. + +;; GNU Emacs 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 2, or (at your option) +;; any later version. + +;; GNU Emacs 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; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; This little hack has enabled me to keep track of my email chess +;; games in Emacs. For a long time I dreamt about writing a real, +;; graphical tree editor; but, then the idea struck me, why do it +;; graphically, when it can be done in Emacs? :-) And in fact Emacs +;; almost had what I needed out of the box, namely the powerful +;; Outline mode. This code is built entirely on Outline mode, it +;; only adds two commands that I found indispensable when dealing +;; with the special kind of trees that analysis trees comprise. + +;; The built-in documentation should be enough to explain the use, +;; along with the following example (yes, this is a real game). + +;; *** 23. f4 ef 24. Nf3 Rf3 -/+ +;; 25. Rf3 Qh2 26. Kh1 Qh1 27. Ke2 Qg2 -+ +;; ******* 25. gf3 Nce3 26. Qe2 Nf1 -/+ +;; 27. Qe5 Ne5 28. Kf1 Nf3 -/+ +;; 27. Kf1 Nh2 28. Kf2 Ng4 29. fg4 Rf8 30. Ke1 Qg3 31. Kd1 Rf2 -+ + +;; Place the preceding in a scratch buffer, load this code, and do +;; M-x gametree-mode. Now place the cursor just after the `Nf3' and +;; before the `Rf3' on the first line, and do C-c C-j. The result is + +;; *** 23. f4 ef 24. Nf3 +;; ****** 24: Rf3 -/+ +;; 25. Rf3 Qh2 26. Kh1 Qh1 27. Ke2 Qg2 -+ +;; ******* 25. gf3 Nce3 26. Qe2 Nf1 -/+ +;; 27. Qe5 Ne5 28. Kf1 Nf3 -/+ +;; 27. Kf1 Nh2 28. Kf2 Ng4 29. fg4 Rf8 30. Ke1 Qg3 31. Kd1 Rf2 -+ + +;; Now you can add another subvariation on Black's 24th move: with +;; the cursor still on the first line, do C-c C-v, and voila + +;; *** 23. f4 ef 24. Nf3 +;; 24: +;; ****** 24: Rf3 -/+ +;; 25. Rf3 Qh2 26. Kh1 Qh1 27. Ke2 Qg2 -+ +;; ******* 25. gf3 Nce3 26. Qe2 Nf1 -/+ +;; 27. Qe5 Ne5 28. Kf1 Nf3 -/+ +;; 27. Kf1 Nh2 28. Kf2 Ng4 29. fg4 Rf8 30. Ke1 Qg3 31. Kd1 Rf2 -+ + +;; and the cursor is positioned on the new line just after the move +;; number, so you can start typing the new analysis. That's it, +;; quite simple. If you want more, read on. + +;;; ToDo: + +;; BIG: automatic score reducer. It should be possible to label the +;; leaf variations with numeric scores (instead of the Informant-like +;; symbols used in the example) and have the program apply the +;; min-max algorithm to score the internal nodes. That's about as +;; far as one can go in a postal game while honestly claiming not to +;; use computer analysis. + +;; I'd definitely like to hear from you if you use this, and even +;; more if you have suggestions for improvement, ranging from bug +;; reports to feature requests. (But be warned that I am a fan of +;; simplicity and orthogonality). + +;;; Code: + +(require 'derived) +(require 'outline) + +;;;; Configuration variables + +(defvar gametree-half-ply-regexp (regexp-quote ":") + "*Matches ends of numbers of moves by the \"second\" player. +For instance, it is an almost universal convention in chess to postfix +numbers of moves by Black (if considered in isolation) by the ellipsis +\"...\". This is NOT a good choice for this program, though, because it +conflicts with the use of ellipsis by Outline mode to denote collapsed +subtrees. The author uses \":\" because it agrees nicely with a set of +LaTeX macros he uses for typesetting annotated games.") + +(defvar gametree-full-ply-regexp (regexp-quote ".") + "*Matches ends of numbers of moves by the \"first\" player. +For instance, it is an almost universal convention in chess to postfix +numbers of moves by White (if considered in isolation) by the dot \".\".") + +(defvar gametree-half-ply-format "%d:" + "*Output format for move numbers of moves by the \"second\" player. +Has to contain \"%d\" to output the actual number.") + +(defvar gametree-full-ply-format "%d." + "*Output format for move numbers of moves by the \"first\" player. +Has to contain \"%d\" to output the actual number.") + +(defvar gametree-make-heading-function + (function (lambda (level) + (insert (make-string level ?*)))) + "A function of one numeric argument, LEVEL, to insert a heading at point. +You should change this if you change `outline-regexp'.") + +(defvar gametree-local-layout nil + "A list encoding the layout (i.e. the show or hide state) of the file. +If Emacs notices a local variable specification of this variable in +the first line of the buffer while saving the buffer to the visited +file, the local value will be saved there and restored the next time +the file is visited (subject to the usual restriction via +`enable-local-variables'), and the layout will be set accordingly.") + +;;;; Helper functions + +(defun gametree-prettify-heading () + "Insert/delete space between leading asterisks and heading text. +If the current variation is an internal node (i.e. starts with one or +more asterisks), ensure there's at least one space between the +asterisks and the text. If on the other hand this is a leaf, there +should be no leading white space." + (save-excursion + (beginning-of-line 1) + (if (re-search-forward (concat "\\=" outline-regexp) nil t) + (if (not (looking-at "[ \t]+")) (insert " ")) + (delete-char (save-excursion (skip-chars-forward " \t")))) + (if (re-search-forward (concat "\\=[ \t]*[1-9][0-9]*\\(" + gametree-full-ply-regexp "\\|" + gametree-half-ply-regexp "\\)") nil t) + (if (not (looking-at "[ \t]+")) (insert " ") + (delete-char (1- (save-excursion (skip-chars-forward " \t")))))))) + +(defun gametree-looking-at-ply () + "Read and return the number of the ply under point." + (if (eobp) 0 + (let ((boundary (concat "[ \t]*\\([1-9][0-9]*\\)\\(" + gametree-full-ply-regexp "\\|" + gametree-half-ply-regexp "\\)")) + (limit (save-excursion (beginning-of-line 1) (point)))) + (if (looking-at boundary) + (+ (* 2 (string-to-int (match-string 1))) + (if (string-match gametree-half-ply-regexp (match-string 2)) 1 0)) + (save-excursion + (re-search-backward boundary limit) + (skip-chars-backward "0123456789") + (1+ (* 2 (string-to-int + (buffer-substring (point) (match-end 1)))))))))) + +(defun gametree-current-branch-ply () + "Return the ply number of the first move of the current variation." + (save-excursion + (beginning-of-line 1) + (re-search-forward (concat "\\=" outline-regexp) nil t) + (gametree-looking-at-ply))) + +(defun gametree-current-branch-depth () + "Return the depth of the current variation in the analysis tree. +This value is simply the outline heading level of the current line." + (save-excursion + (beginning-of-line 1) + (if (looking-at outline-regexp) + (outline-level) 0))) + +;;;; Functions related to the task of saving and restoring current +;;;; outline layout + +(defun gametree-show-children-and-entry () + (show-children) + (show-entry)) + +(defun gametree-entry-shown-p () + (save-excursion + (forward-line 1) + (and (bolp) (not (eobp)) (not (looking-at outline-regexp))))) + +(defun gametree-children-shown-p () + (save-excursion + (condition-case nil + (let ((depth (gametree-current-branch-depth))) + (outline-next-visible-heading 1) + (< depth (gametree-current-branch-depth))) + (error nil)))) + +(defun gametree-current-layout (depth &optional top-level) + (let ((layout nil) (first-time t)) + (while (save-excursion + (condition-case nil + (progn + (or (and first-time top-level + (bolp) (looking-at outline-regexp)) + (setq first-time nil) + (outline-next-visible-heading 1)) + (< depth (gametree-current-branch-depth))) + (error nil))) + (if (not first-time) + (outline-next-visible-heading 1)) + (setq first-time nil) + (if (not (gametree-children-shown-p)) + (setq layout + (nconc layout + (if (gametree-entry-shown-p) + (list 'show-entry) + (list nil)))) + (setq layout (nconc layout (if (gametree-entry-shown-p) + (list 'gametree-show-children-and-entry) + (list 'show-children)))) + (let ((sub-layout + (gametree-current-layout (gametree-current-branch-depth)))) + (setq layout (nconc layout (list sub-layout)))))) + layout)) + +(defun gametree-save-layout () + (save-excursion + (goto-char (point-min)) + (setq gametree-local-layout (gametree-current-layout 0 t)))) + +(defun gametree-apply-layout (layout depth &optional top-level) + (let ((first-time t)) + (while (and layout + (save-excursion + (condition-case nil + (progn + (or (and first-time top-level + (bolp) (looking-at outline-regexp)) + (setq first-time nil) + (outline-next-visible-heading 1)) + (< depth (gametree-current-branch-depth))) + (error nil)))) + (if (not first-time) + (outline-next-visible-heading 1)) + (setq first-time nil) + (hide-subtree) + (if (nth 0 layout) + (funcall (nth 0 layout))) + (if (not (and (nth 1 layout) (listp (nth 1 layout)))) + (setq layout (cdr layout)) + (gametree-apply-layout (nth 1 layout) + (gametree-current-branch-depth)) + (setq layout (cdr (cdr layout))))))) + +(defun gametree-restore-layout () + (save-excursion + (goto-char (point-min)) + (gametree-apply-layout gametree-local-layout 0 t))) + +(defun gametree-hack-file-layout () + (save-excursion + (goto-char (point-min)) + (if (looking-at "[^\n]*-\*-[^\n]*gametree-local-layout: \\([^;\n]*\\);") + (progn + (goto-char (match-beginning 1)) + (delete-region (point) (match-end 1)) + (let ((standard-output (current-buffer))) + (princ gametree-local-layout)))))) + +;;;; Commands + +(defun gametree-insert-new-leaf (&optional at-depth) + "Start a new leaf variation under the current branching point. +The new variation can later be split to be a branching point itself, +with \\[gametree-break-line-here]. If the point is currently on a +leaf variation, this command won't work; use \\[gametree-break-line-here] +on the current line first. + +With a numeric arg AT-DEPTH, first go up the tree until a node of +depth AT-DEPTH or smaller is found." + (interactive "P") + (if (zerop (gametree-current-branch-depth)) + (outline-up-heading 0)) + (if at-depth + (while (> (gametree-current-branch-depth) + (prefix-numeric-value at-depth)) + (outline-up-heading 1))) + (beginning-of-line 1) + (let ((parent-depth (gametree-current-branch-depth))) + (show-entry) + (condition-case nil + (outline-next-visible-heading 1) + (error + (goto-char (point-max)) + (if (not (bolp)) (insert "\n")))) + (let ((starting-plys + (if (> (gametree-current-branch-depth) parent-depth) + (gametree-current-branch-ply) + (save-excursion (forward-line -1) + (gametree-current-branch-ply))))) + (goto-char (1- (point))) + (insert "\n") + (insert (format (if (= 0 (mod starting-plys 2)) + gametree-full-ply-format + gametree-half-ply-format) + (/ starting-plys 2)))))) + +(defun gametree-break-line-here (&optional at-move) + "Split the variation node at the point position. +This command works whether the current variation node is a leaf, or is +already branching at its end. The new node is created at a level that +reflects the number of game plys between the beginning of the current +variation and the breaking point. + +With a numerical argument AT-MOVE, split the variation before +White's AT-MOVEth move, or Black's if negative. The last option will +only work of Black's moves are explicitly numbered, for instance +`1. e4 1: e5'." + (interactive "P") + (if at-move (progn + (end-of-line 1) + (let ((limit (point))) + (beginning-of-line 1) + (re-search-forward + (concat + (regexp-quote + (int-to-string (abs (prefix-numeric-value at-move)))) + (if (> at-move 0) gametree-full-ply-regexp + gametree-half-ply-regexp)) limit)) + (goto-char (match-beginning 0)))) + (let* ((pt (set-marker (make-marker) (point))) + (plys (gametree-current-branch-ply)) + (depth (gametree-current-branch-depth)) + (old-depth depth)) + (if (= depth 0) + (progn + (save-excursion + (outline-previous-visible-heading 1) + (setq depth + (let ((old-branch-ply + (condition-case nil + (gametree-current-branch-ply) + (error 0)))) + (if (zerop old-branch-ply) + (1+ (gametree-current-branch-depth)) + (+ (gametree-current-branch-depth) + (- plys old-branch-ply)))))) + (save-excursion + (beginning-of-line 1) + (funcall gametree-make-heading-function depth) + (gametree-prettify-heading)))) + (save-excursion + (if (not (looking-at (concat "[ \t]*[1-9][0-9]*\\(" + gametree-full-ply-regexp "\\|" + gametree-half-ply-regexp "\\)"))) + (progn + (insert (format (if (= 0 (mod (gametree-looking-at-ply) 2)) + gametree-full-ply-format + gametree-half-ply-format) + (/ (gametree-looking-at-ply) 2))) + (gametree-prettify-heading) + (beginning-of-line 1))) + (goto-char pt) + (insert "\n") + (if (not (= 0 old-depth)) + (funcall gametree-make-heading-function + (+ depth (- (gametree-current-branch-ply) plys)))) + (gametree-prettify-heading)))) + +(defun gametree-merge-line () + "Merges a variation with its only child. +Does *not* check if the variation has in fact a unique child; users beware." + (interactive) + (if (zerop (gametree-current-branch-depth)) + (outline-up-heading 0)) + (end-of-line 1) + (let ((prev-depth (save-excursion (forward-line 1) + (gametree-current-branch-depth)))) + (delete-char (1+ prev-depth)) + (if (zerop prev-depth) + (save-excursion + (beginning-of-line 1) + (delete-char (gametree-current-branch-depth)) + (gametree-prettify-heading))))) + +(defun gametree-layout-to-register (register) + "Store current tree layout in register REGISTER. +Use \\[gametree-apply-register-layout] to restore that configuration. +Argument is a character, naming the register." + (interactive "cLayout to register: ") + (save-excursion + (goto-char (point-min)) + (set-register register + (gametree-current-layout 0 t)))) + +(defun gametree-apply-register-layout (char) + "Return to a tree layout stored in a register. +Argument is a character, naming the register." + (interactive "cApply layout from register: ") + (save-excursion + (goto-char (point-min)) + (gametree-apply-layout (get-register char) 0 t))) + +(defun gametree-save-and-hack-layout () + "Save the current tree layout and hack the file local variable spec. +This function saves the current layout in `gametree-local-layout' and, +if a local file varible specification for this variable exists in the +buffer, it is replaced by the new value. See the documentation for +`gametree-local-layout' for more information." + (interactive) + (gametree-save-layout) + (gametree-hack-file-layout) + nil) + +(define-derived-mode gametree-mode outline-mode "GameTree" + "Major mode for managing game analysis trees. +Useful to postal and email chess (and, it is hoped, also checkers, go, +shogi, etc.) players, it is a slightly modified version of Outline mode. + +\\{gametree-mode-map}" +(auto-fill-mode 0) +(make-variable-buffer-local 'write-contents-hooks) +(add-hook 'write-contents-hooks 'gametree-save-and-hack-layout)) + +;;;; Key bindings + +(define-key gametree-mode-map "\C-c\C-j" 'gametree-break-line-here) +(define-key gametree-mode-map "\C-c\C-v" 'gametree-insert-new-leaf) +(define-key gametree-mode-map "\C-c\C-m" 'gametree-merge-line) +(define-key gametree-mode-map "\C-c\C-r " 'gametree-layout-to-register) +(define-key gametree-mode-map "\C-c\C-r/" 'gametree-layout-to-register) +(define-key gametree-mode-map "\C-c\C-rj" 'gametree-apply-register-layout) +(define-key gametree-mode-map "\C-c\C-y" 'gametree-save-and-hack-layout) + +;;;; Goodies for mousing users +(and (fboundp 'track-mouse) + (defun gametree-mouse-break-line-here (event) + (interactive "e") + (mouse-set-point event) + (gametree-break-line-here)) + (defun gametree-mouse-show-children-and-entry (event) + (interactive "e") + (mouse-set-point event) + (gametree-show-children-and-entry)) + (defun gametree-mouse-show-subtree (event) + (interactive "e") + (mouse-set-point event) + (show-subtree)) + (defun gametree-mouse-hide-subtree (event) + (interactive "e") + (mouse-set-point event) + (hide-subtree)) + (define-key gametree-mode-map [M-down-mouse-2 M-mouse-2] + 'gametree-mouse-break-line-here) + (define-key gametree-mode-map [S-down-mouse-1 S-mouse-1] + 'gametree-mouse-show-children-and-entry) + (define-key gametree-mode-map [S-down-mouse-2 S-mouse-2] + 'gametree-mouse-show-subtree) + (define-key gametree-mode-map [S-down-mouse-3 S-mouse-3] + 'gametree-mouse-hide-subtree)) + +(provide 'gametree) + +;;; gametree.el ends here |