Initial revision

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