--- /dev/null
+/*
+ *
+ * Copyright (C) 1986 Free Software Foundation, Inc.
+ *
+ * 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA. */
+ *
+ *
+ * For Emacs in SunView/Sun-Windows: (supported by Sun Unix v3.2)
+ * Insert a notifier filter-function to convert all useful input
+ * to "key" sequences that emacs can understand. See: Emacstool(1).
+ *
+ * Author: Jeff Peck, Sun Microsystems, Inc. <peck@sun.com>
+ *
+ * Original Idea: Ian Batten
+ * Updated 15-Mar-88, Jeff Peck: set IN_EMACSTOOL, TERM, TERMCAP
+ *
+ */
+
+#include <suntool/sunview.h>
+#include <suntool/tty.h>
+#include <stdio.h>
+#include <sys/file.h>
+
+#define BUFFER_SIZE 128 /* Size of all the buffers */
+
+/* define WANT_CAPS_LOCK to make f-key T1 (aka F1) behave as CapsLock */
+#define WANT_CAPS_LOCK
+#ifdef WANT_CAPS_LOCK
+int caps_lock; /* toggle indicater for f-key T1 caps lock */
+static char *Caps = "[CAPS] "; /* Caps Lock prefix string */
+#define CAPS_LEN 7 /* strlen (Caps) */
+#endif
+
+static char *mouse_prefix = "\030\000"; /* C-x C-@ */
+static int m_prefix_length = 2; /* mouse_prefix length */
+
+static char *key_prefix = "\030*"; /* C-x * */
+static int k_prefix_length = 2; /* key_prefix length */
+
+static char *emacs_name = "emacs"; /* default run command */
+static char buffer[BUFFER_SIZE]; /* send to ttysw_input */
+static char *title = "Emacstool - "; /* initial title */
+
+Frame frame; /* Base frame for system */
+Tty ttysw; /* Where emacs is */
+int font_width, font_height; /* For translating pixels to chars */
+
+int console_fd = 0; /* for debugging: setenv DEBUGEMACSTOOL */
+FILE *console; /* for debugging: setenv DEBUGEMACSTOOL */
+
+Icon frame_icon;
+/* make an icon_image for the default frame_icon */
+static short default_image[258] =
+{
+#include <images/terminal.icon>
+};
+mpr_static(icon_image, 64, 64, 1, default_image);
+
+\f
+/*
+ * Assign a value to a set of keys
+ */
+int
+button_value (event)
+ Event *event;
+{
+ int retval = 0;
+ /*
+ * Code up the current situation:
+ *
+ * 1 = MS_LEFT;
+ * 2 = MS_MIDDLE;
+ * 4 = MS_RIGHT;
+ * 8 = SHIFT;
+ * 16 = CONTROL;
+ * 32 = META;
+ * 64 = DOUBLE;
+ * 128 = UP;
+ */
+
+ if (MS_LEFT == (event_id (event))) retval = 1;
+ if (MS_MIDDLE == (event_id (event))) retval = 2;
+ if (MS_RIGHT == (event_id (event))) retval = 4;
+
+ if (event_shift_is_down (event)) retval += 8;
+ if (event_ctrl_is_down (event)) retval += 16;
+ if (event_meta_is_down (event)) retval += 32;
+ if (event_is_up (event)) retval += 128;
+ return retval;
+}
+\f
+/*
+ * Variables to store the time of the previous mouse event that was
+ * sent to emacs.
+ *
+ * The theory is that to time double clicks while ignoreing UP buttons,
+ * we must keep track of the accumulated time.
+ *
+ * If someone writes a SUN-SET-INPUT-MASK for emacstool,
+ * That could be used to selectively disable UP events,
+ * and then this cruft wouldn't be necessary.
+ */
+static long prev_event_sec = 0;
+static long prev_event_usec = 0;
+
+/*
+ * Give the time difference in milliseconds, where one second
+ * is considered infinite.
+ */
+int
+time_delta (now_sec, now_usec, prev_sec, prev_usec)
+ long now_sec, now_usec, prev_sec, prev_usec;
+{
+ long sec_delta = now_sec - prev_sec;
+ long usec_delta = now_usec - prev_usec;
+
+ if (usec_delta < 0) { /* "borrow" a second */
+ usec_delta += 1000000;
+ --sec_delta;
+ }
+
+ if (sec_delta >= 10)
+ return (9999); /* Infinity */
+ else
+ return ((sec_delta * 1000) + (usec_delta / 1000));
+}
+
+\f
+/*
+ * Filter function to translate selected input events for emacs
+ * Mouse button events become ^X^@(button x-col y-line time-delta) .
+ * Function keys: ESC-*{c}{lrt} l,r,t for Left, Right, Top;
+ * {c} encodes the keynumber as a character [a-o]
+ */
+static Notify_value
+input_event_filter_function (window, event, arg, type)
+ Window window;
+ Event *event;
+ Notify_arg arg;
+ Notify_event_type type;
+{
+ struct timeval time_stamp;
+
+ if (console_fd) fprintf(console, "Event: %d\n", event_id(event));
+
+ /* UP L1 is the STOP key */
+ if (event_id(event) == WIN_STOP) {
+ ttysw_input(ttysw, "\007\007\007\007\007\007\007", 7);
+ return NOTIFY_IGNORED;
+ }
+
+ /* UP L5 & L7 is Expose & Open, let them pass to sunview */
+ if (event_id(event) == KEY_LEFT(5) || event_id(event) == KEY_LEFT(7))
+ if(event_is_up (event))
+ return notify_next_event_func (window, event, arg, type);
+ else return NOTIFY_IGNORED;
+
+ if (event_is_button (event)) { /* do Mouse Button events */
+/* Commented out so that we send mouse up events too.
+ if (event_is_up (event))
+ return notify_next_event_func (window, event, arg, type);
+*/
+ time_stamp = event_time (event);
+ ttysw_input (ttysw, mouse_prefix, m_prefix_length);
+ sprintf (buffer, "(%d %d %d %d)\015",
+ button_value (event),
+ event_x (event) / font_width,
+ event_y (event) / font_height,
+ time_delta (time_stamp.tv_sec, time_stamp.tv_usec,
+ prev_event_sec, prev_event_usec)
+ );
+ ttysw_input (ttysw, buffer, strlen(buffer));
+ prev_event_sec = time_stamp.tv_sec;
+ prev_event_usec = time_stamp.tv_usec;
+ return NOTIFY_IGNORED;
+ }
+
+ { /* Do the function key events */
+ int d;
+ char c = (char) 0;
+ if ((event_is_key_left (event)) ?
+ ((d = event_id(event) - KEY_LEFT(1) + 'a'), c='l') :
+ ((event_is_key_right (event)) ?
+ ((d = event_id(event) - KEY_RIGHT(1) + 'a'), c='r') :
+ ((event_is_key_top (event)) ?
+ ((d = event_id(event) - KEY_TOP(1) + 'a'), c='t') : 0)))
+ {
+ if (event_is_up(event)) return NOTIFY_IGNORED;
+ if (event_shift_is_down (event)) c = c - 32;
+ /* this will give a non-{lrt} for unshifted keys */
+ if (event_ctrl_is_down (event)) c = c - 64;
+ if (event_meta_is_down (event)) c = c + 128;
+#ifdef WANT_CAPS_LOCK
+/* set a toggle and relabel window so T1 can act like caps-lock */
+ if (event_id(event) == KEY_TOP(1))
+ {
+ /* make a frame label with and without CAPS */
+ strcpy (buffer, Caps);
+ title = &buffer[CAPS_LEN];
+ strncpy (title, (char *)window_get (frame, FRAME_LABEL),
+ BUFFER_SIZE - CAPS_LEN);
+ buffer[BUFFER_SIZE] = (char) 0;
+ if (strncmp (title, Caps, CAPS_LEN) == 0)
+ title += CAPS_LEN; /* already Caps */
+ caps_lock = (caps_lock ? 0 : CAPS_LEN);
+ window_set(frame, FRAME_LABEL, (title -= caps_lock), 0);
+ return NOTIFY_IGNORED;
+ }
+#endif
+ ttysw_input (ttysw, key_prefix, k_prefix_length);
+ sprintf (buffer, "%c%c", d, c);
+ ttysw_input(ttysw, buffer, strlen(buffer));
+
+ return NOTIFY_IGNORED;
+ }
+ }
+ if ((event_is_ascii(event) || event_is_meta(event))
+ && event_is_up(event)) return NOTIFY_IGNORED;
+#ifdef WANT_CAPS_LOCK
+/* shift alpha chars to upper case if toggle is set */
+ if ((caps_lock) && event_is_ascii(event)
+ && (event_id(event) >= 'a') && (event_id(event) <= 'z'))
+ event_set_id(event, (event_id(event) - 32));
+/* crufty, but it works for now. is there an UPCASE(event)? */
+#endif
+ return notify_next_event_func (window, event, arg, type);
+}
+\f
+main (argc, argv)
+ int argc;
+ char **argv;
+{
+ int error_code; /* Error codes */
+
+ if(getenv("DEBUGEMACSTOOL"))
+ console = fdopen (console_fd = open("/dev/console",O_WRONLY), "w");
+
+ /* do this first, so arglist can override it */
+ frame_icon = icon_create (ICON_LABEL, "Emacstool",
+ ICON_IMAGE, &icon_image,
+ 0);
+
+ putenv("IN_EMACSTOOL=t"); /* notify subprocess that it is in emacstool */
+
+ if (putenv("TERM=sun") != 0) /* TTYSW will be a TERM=sun window */
+ {fprintf (stderr, "%s: Could not set TERM=sun, using `%s'\n",
+ argv[0], (char *)getenv("TERM")) ;};
+ /*
+ * If TERMCAP starts with a slash, it is the pathname of the
+ * termcap file, not an entry extracted from it, so KEEP it!
+ * Otherwise, it may not relate to the new TERM, so Nuke-It.
+ * If there is no TERMCAP environment variable, don't make one.
+ */
+ {
+ char *termcap ; /* Current TERMCAP value */
+ termcap = (char *)getenv("TERMCAP") ;
+ if (termcap && (*termcap != '/'))
+ {
+ if (putenv("TERMCAP=") != 0)
+ {fprintf (stderr, "%s: Could not clear TERMCAP\n", argv[0]) ;} ;
+ } ;
+ } ;
+
+ /* find command to run as subprocess in window */
+ if (!(argv[0] = (char *)getenv("EMACSTOOL"))) /* Set emacs command name */
+ argv[0] = emacs_name;
+ for (argc = 1; argv[argc]; argc++) /* Use last one on line */
+ if(!(strcmp ("-rc", argv[argc]))) /* Override if -rc given */
+ {
+ int i = argc;
+ argv[argc--]=0; /* kill the -rc argument */
+ if (argv[i+1]) { /* move to agrv[0] and squeeze the rest */
+ argv[0]=argv[i+1];
+ for (; argv[i+2]; (argv[i]=argv[i+2],argv[++i]=0));
+ }
+ }
+
+ strcpy (buffer, title);
+ strncat (buffer, argv[0], /* append run command name */
+ (BUFFER_SIZE - (strlen (buffer)) - (strlen (argv[0]))) - 1);
+
+ /* Build a frame to run in */
+ frame = window_create ((Window)NULL, FRAME,
+ FRAME_LABEL, buffer,
+ FRAME_ICON, frame_icon,
+ FRAME_ARGC_PTR_ARGV, &argc, argv,
+ 0);
+
+ /* Create a tty with emacs in it */
+ ttysw = window_create (frame, TTY,
+ TTY_QUIT_ON_CHILD_DEATH, TRUE,
+ TTY_BOLDSTYLE, 8,
+ TTY_ARGV, argv,
+ 0);
+
+ window_set(ttysw,
+ WIN_CONSUME_PICK_EVENTS,
+ WIN_STOP,
+ WIN_MOUSE_BUTTONS, WIN_UP_EVENTS,
+ /* LOC_WINENTER, LOC_WINEXIT, LOC_MOVE, */
+ 0,
+
+ WIN_CONSUME_KBD_EVENTS,
+ WIN_STOP,
+ WIN_ASCII_EVENTS,
+ WIN_LEFT_KEYS, WIN_TOP_KEYS, WIN_RIGHT_KEYS,
+ /* WIN_UP_ASCII_EVENTS, */
+ 0,
+
+ 0);
+
+ font_height = (int)window_get (ttysw, WIN_ROW_HEIGHT);
+ font_width = (int)window_get (ttysw, WIN_COLUMN_WIDTH);
+
+ /* Interpose my event function */
+ error_code = (int) notify_interpose_event_func
+ (ttysw, input_event_filter_function, NOTIFY_SAFE);
+
+ if (error_code != 0) /* Barf */
+ {
+ fprintf (stderr, "notify_interpose_event_func got %d.\n", error_code);
+ exit (1);
+ }
+
+ window_main_loop (frame); /* And away we go */
+}
--- /dev/null
+;; Functions for extending the character set and dealing with case tables.
+;; Copyright (C) 1988 Free Software Foundation, Inc.
+
+;; 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+
+;; Written by:
+;; TN/ETX/TX/UMG Howard Gayle UUCP : seismo!enea!erix!howard
+;; Telefonaktiebolaget L M Ericsson Phone: +46 8 719 55 65
+;; Ericsson Telecom Telex: 14910 ERIC S
+;; S-126 25 Stockholm FAX : +46 8 719 64 82
+;; Sweden
+
+(defun describe-buffer-case-table ()
+ "Describe the case table of the current buffer."
+ (interactive)
+ (let ((vector (make-vector 256 nil))
+ (case-table (current-case-table))
+ (i 0))
+ (while (< i 256)
+ (aset vector i
+ (cond ((/= ch (downcase ch))
+ (concat "uppercase, matches "
+ (text-char-description (downcase ch))))
+ ((/= ch (upcase ch))
+ (concat "lowercase, matches "
+ (text-char-description (upcase ch))))
+ (t "case-invariant")))
+ (setq i (1+ i))))
+ (with-output-to-temp-buffer "*Help*"
+ (describe-vector vector)))
+
+(defun invert-case (count)
+ "Change the case of the character just after point and move over it.
+With arg, applies to that many chars.
+Negative arg inverts characters before point but does not move."
+ (interactive "p")
+ (if (< count 0)
+ (progn (setq count (min (1- (point)) (- count)))
+ (forward-char (- count))))
+ (while (> count 0)
+ (let ((oc (following-char))) ; Old character.
+ (cond ((/= (upcase ch) ch)
+ (replace-char (upcase ch)))
+ ((/= (downcase ch) ch)
+ (replace-char (downcase ch)))))
+ (forward-char 1)
+ (setq count (1- count))))
+
+(defun set-case-syntax-delims (l r table)
+ "Make characters L and R a matching pair of non-case-converting delimiters.
+Sets the entries for L and R in standard-case-table,
+standard-syntax-table, and text-mode-syntax-table to indicate
+left and right delimiters."
+ (aset (car table) l l)
+ (aset (car table) r r)
+ (modify-syntax-entry l (concat "(" (char-to-string r) " ")
+ (standard-syntax-table))
+ (modify-syntax-entry l (concat "(" (char-to-string r) " ")
+ text-mode-syntax-table)
+ (modify-syntax-entry r (concat ")" (char-to-string l) " ")
+ (standard-syntax-table))
+ (modify-syntax-entry r (concat ")" (char-to-string l) " ")
+ text-mode-syntax-table))
+
+(defun set-case-syntax-pair (uc lc table)
+ "Make characters UC and LC a pair of inter-case-converting letters.
+Sets the entries for characters UC and LC in
+standard-case-table, standard-syntax-table, and
+text-mode-syntax-table to indicate an (uppercase, lowercase)
+pair of letters."
+ (aset (car table) uc lc)
+ (modify-syntax-entry lc "w " (standard-syntax-table))
+ (modify-syntax-entry lc "w " text-mode-syntax-table)
+ (modify-syntax-entry uc "w " (standard-syntax-table))
+ (modify-syntax-entry uc "w " text-mode-syntax-table))
+
+(defun set-case-syntax (c syntax table)
+ "Make characters C case-invariant with syntax SYNTAX.
+Sets the entries for character C in standard-case-table,
+standard-syntax-table, and text-mode-syntax-table to indicate this.
+SYNTAX should be \" \", \"w\", \".\" or \"_\"."
+ (aset (car table) c c)
+ (modify-syntax-entry c syntax (standard-syntax-table))
+ (modify-syntax-entry c syntax text-mode-syntax-table))
+
+(provide 'case-table)
--- /dev/null
+;; Functions for dealing with char tables.
+;; Copyright (C) 1987 Free Software Foundation, Inc.
+
+;; 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+
+;; Written by Howard Gayle. See case-table.el for details.
+
+(require 'case-table)
+
+(defun rope-to-vector (rope)
+ (let* ((len (/ (length rope) 2))
+ (vector (make-vector len nil))
+ (i 0))
+ (while (< i len)
+ (aset vector i (rope-elt rope i))
+ (setq i (1+ i)))))
+
+(defun describe-display-table (DT)
+ "Describe the display-table DT in a help buffer."
+ (with-output-to-temp-buffer "*Help*"
+ (princ "\nTruncation glyf: ")
+ (prin1 (aref dt 256))
+ (princ "\nWrap glyf: ")
+ (prin1 (aref dt 257))
+ (princ "\nEscape glyf: ")
+ (prin1 (aref dt 258))
+ (princ "\nCtrl glyf: ")
+ (prin1 (aref dt 259))
+ (princ "\nSelective display rope: ")
+ (prin1 (rope-to-vector (aref dt 260)))
+ (princ "\nCharacter display ropes:\n")
+ (let ((vector (make-vector 256 nil))
+ (i 0))
+ (while (< i 256)
+ (aset vector i
+ (if (stringp (aref dt i))
+ (rope-to-vector (aref dt i))
+ (aref dt i)))
+ (setq i (1+ i)))
+ (describe-vector vector))
+ (print-help-return-message)))
+
+(defun describe-current-display-table ()
+ "Describe the display-table in use in the selected window and buffer."
+ (interactive)
+ (describe-display-table
+ (or (window-display-table (selected-window))
+ buffer-display-table
+ standard-display-table)))
+
+(defun make-display-table ()
+ (make-vector 261 nil))
+
+(defun standard-display-8bit (l h)
+ "Display characters in the range [L, H] literally."
+ (while (<= l h)
+ (if (and (>= l ?\ ) (< l 127))
+ (if standard-display-table (aset standard-display-table l nil))
+ (or standard-display-table
+ (setq standard-display-table (make-vector 261 nil)))
+ (aset standard-display-table l l))
+ (setq l (1+ l))))
+
+(defun standard-display-ascii (c s)
+ "Display character C using string S."
+ (or standard-display-table
+ (setq standard-display-table (make-vector 261 nil)))
+ (aset standard-display-table c (apply 'make-rope (append s nil))))
+
+(defun standard-display-g1 (c sc)
+ "Display character C as character SC in the g1 character set."
+ (or standard-display-table
+ (setq standard-display-table (make-vector 261 nil)))
+ (aset standard-display-table c
+ (make-rope (create-glyf (concat "\016" (char-to-string sc) "\017")))))
+
+(defun standard-display-graphic (c gc)
+ "Display character C as character GC in graphics character set."
+ (or standard-display-table
+ (setq standard-display-table (make-vector 261 nil)))
+ (aset standard-display-table c
+ (make-rope (create-glyf (concat "\e(0" (char-to-string gc) "\e(B")))))
+
+(defun standard-display-underline (c uc)
+ "Display character C as character UC plus underlining."
+ (or standard-display-table
+ (setq standard-display-table (make-vector 261 nil)))
+ (aset standard-display-table c
+ (make-rope (create-glyf (concat "\e[4m" (char-to-string uc) "\e[m")))))
+
+(defun create-glyf (string)
+ (let ((i 256))
+ (while (and (< i 65536) (aref glyf-table i)
+ (not (string= (aref glyf-table i) string)))
+ (setq i (1+ i)))
+ (if (= i 65536)
+ (error "No free glyf codes remain"))
+ (aset glyf-table i string)))
+
+(provide 'disp-table)
--- /dev/null
+;; Copyright (C) 1986 Free Software Foundation, Inc.
+
+;; 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+(require 'electric)
+(provide 'ehelp)
+
+(defvar electric-help-map ()
+ "Keymap defining commands available whilst scrolling
+through a buffer in electric-help-mode")
+
+(put 'electric-help-undefined 'suppress-keymap t)
+(if electric-help-map
+ ()
+ (let ((map (make-keymap)))
+ (fillarray map 'electric-help-undefined)
+ (define-key map (char-to-string meta-prefix-char) (copy-keymap map))
+ (define-key map (char-to-string help-char) 'electric-help-help)
+ (define-key map "?" 'electric-help-help)
+ (define-key map " " 'scroll-up)
+ (define-key map "\^?" 'scroll-down)
+ (define-key map "." 'beginning-of-buffer)
+ (define-key map "<" 'beginning-of-buffer)
+ (define-key map ">" 'end-of-buffer)
+ ;(define-key map "\C-g" 'electric-help-exit)
+ (define-key map "q" 'electric-help-exit)
+ (define-key map "Q" 'electric-help-exit)
+ ;;a better key than this?
+ (define-key map "r" 'electric-help-retain)
+
+ (setq electric-help-map map)))
+
+(defun electric-help-mode ()
+ "with-electric-help temporarily places its buffer in this mode
+\(On exit from with-electric-help, the buffer is put in default-major-mode)"
+ (setq buffer-read-only t)
+ (setq mode-name "Help")
+ (setq major-mode 'help)
+ (setq mode-line-buffer-identification '(" Help: %b"))
+ (use-local-map electric-help-map)
+ ;; this is done below in with-electric-help
+ ;(run-hooks 'electric-help-mode-hook)
+ )
+
+(defun with-electric-help (thunk &optional buffer noerase)
+ "Arguments are THUNK &optional BUFFER NOERASE.
+BUFFER defaults to \"*Help*\"
+THUNK is a function of no arguments which is called to initialise
+ the contents of BUFFER. BUFFER will be erased before THUNK is called unless
+ NOERASE is non-nil. THUNK will be called with standard-output bound to
+ the buffer specified by BUFFER
+
+After THUNK has been called, this function \"electrically\" pops up a window
+in which BUFFER is displayed and allows the user to scroll through that buffer
+in electric-help-mode.
+When the user exits (with electric-help-exit, or otherwise) the help
+buffer's window disappears (ie we use save-window-excursion)
+BUFFER is put into default-major-mode (or fundamental-mode) when we exit"
+ (setq buffer (get-buffer-create (or buffer "*Help*")))
+ (let ((one (one-window-p t))
+ (two nil))
+ (save-window-excursion
+ (save-excursion
+ (if one (goto-char (window-start (selected-window))))
+ (let ((pop-up-windows t))
+ (pop-to-buffer buffer))
+ (unwind-protect
+ (progn
+ (save-excursion
+ (set-buffer buffer)
+ (electric-help-mode)
+ (setq buffer-read-only nil)
+ (or noerase (erase-buffer)))
+ (let ((standard-output buffer))
+ (if (funcall thunk)
+ ()
+ (set-buffer buffer)
+ (set-buffer-modified-p nil)
+ (goto-char (point-min))
+ (if one (shrink-window-if-larger-than-buffer (selected-window)))))
+ (set-buffer buffer)
+ (run-hooks 'electric-help-mode-hook)
+ (setq two (electric-help-command-loop))
+ (cond ((eq (car-safe two) 'retain)
+ (setq two (vector (window-height (selected-window))
+ (window-start (selected-window))
+ (window-hscroll (selected-window))
+ (point))))
+ (t (setq two nil))))
+
+ (message "")
+ (set-buffer buffer)
+ (setq buffer-read-only nil)
+ (condition-case ()
+ (funcall (or default-major-mode 'fundamental-mode))
+ (error nil)))))
+ (if two
+ (let ((pop-up-windows t)
+ tem)
+ (pop-to-buffer buffer)
+ (setq tem (- (window-height (selected-window)) (elt two 0)))
+ (if (> tem 0) (shrink-window tem))
+ (set-window-start (selected-window) (elt two 1) t)
+ (set-window-hscroll (selected-window) (elt two 2))
+ (goto-char (elt two 3)))
+ ;;>> Perhaps this shouldn't be done.
+ ;; so that when we say "Press space to bury" we mean it
+ (replace-buffer-in-windows buffer)
+ ;; must do this outside of save-window-excursion
+ (bury-buffer buffer))))
+
+(defun electric-help-command-loop ()
+ (catch 'exit
+ (if (pos-visible-in-window-p (point-max))
+ (progn (message "<<< Press Space to bury the help buffer >>>")
+ (if (= (setq unread-command-char (read-char)) ?\ )
+ (progn (setq unread-command-char -1)
+ (throw 'exit t)))))
+ (let (up down both neither
+ (standard (and (eq (key-binding " ")
+ 'scroll-up)
+ (eq (key-binding "\^?")
+ 'scroll-down)
+ (eq (key-binding "Q")
+ 'electric-help-exit)
+ (eq (key-binding "q")
+ 'electric-help-exit))))
+ (Electric-command-loop
+ 'exit
+ (function (lambda ()
+ (let ((min (pos-visible-in-window-p (point-min)))
+ (max (pos-visible-in-window-p (point-max))))
+ (cond ((and min max)
+ (cond (standard "Press Q to exit ")
+ (neither)
+ (t (setq neither (substitute-command-keys "Press \\[scroll-up] to exit ")))))
+ (min
+ (cond (standard "Press SPC to scroll, Q to exit ")
+ (up)
+ (t (setq up (substitute-command-keys "Press \\[scroll-up] to scroll; \\[electric-help-exit] to exit ")))))
+ (max
+ (cond (standard "Press DEL to scroll back, Q to exit ")
+ (down)
+ (t (setq down (substitute-command-keys "Press \\[scroll-down] to scroll back, \\[scroll-up] to exit ")))))
+ (t
+ (cond (standard "Press SPC to scroll, DEL to scroll back, Q to exit ")
+ (both)
+ (t (setq both (substitute-command-keys "Press \\[scroll-up] to scroll, \\[scroll-down] to scroll back, \\[electric-help-exit] to exit ")))))))))
+ t))))
+
+
+\f
+;(defun electric-help-scroll-up (arg)
+; ">>>Doc"
+; (interactive "P")
+; (if (and (null arg) (pos-visible-in-window-p (point-max)))
+; (electric-help-exit)
+; (scroll-up arg)))
+
+(defun electric-help-exit ()
+ ">>>Doc"
+ (interactive)
+ (throw 'exit t))
+
+(defun electric-help-retain ()
+ "Exit electric-help, retaining the current window/buffer conifiguration.
+\(The *Help* buffer will not be selected, but \\[switch-to-buffer-other-window] RET
+will select it.)"
+ (interactive)
+ (throw 'exit '(retain)))
+
+
+;(defun electric-help-undefined ()
+; (interactive)
+; (let* ((keys (this-command-keys))
+; (n (length keys)))
+; (if (or (= n 1)
+; (and (= n 2)
+; meta-flag
+; (eq (aref keys 0) meta-prefix-char)))
+; (setq unread-command-char last-input-char
+; current-prefix-arg prefix-arg)
+; ;;>>> I don't care.
+; ;;>>> The emacs command-loop is too much pure pain to
+; ;;>>> duplicate
+; ))
+; (throw 'exit t))
+
+(defun electric-help-undefined ()
+ (interactive)
+ (error "%s is undefined -- Press %s to exit"
+ (mapconcat 'single-key-description (this-command-keys) " ")
+ (if (eq (key-binding "Q") 'electric-help-exit)
+ "Q"
+ (substitute-command-keys "\\[electric-help-exit]"))))
+
+
+;>>> this needs to be hairified (recursive help, anybody?)
+(defun electric-help-help ()
+ (interactive)
+ (if (and (eq (key-binding "Q") 'electric-help-exit)
+ (eq (key-binding " ") 'scroll-up)
+ (eq (key-binding "\^?") 'scroll-down))
+ (message "SPC scrolls forward, DEL scrolls back, Q exits and burys help buffer")
+ ;; to give something for user to look at while slow substitute-cmd-keys
+ ;; grinds away
+ (message "Help...")
+ (message "%s" (substitute-command-keys "\\[scroll-up] scrolls forward, \\[scroll-down] scrolls back, \\[electric-help-exit] exits.")))
+ (sit-for 2))
+
+\f
+(defun electric-helpify (fun)
+ (let ((name "*Help*"))
+ (if (save-window-excursion
+ ;; kludge-o-rama
+ (let* ((p (symbol-function 'print-help-return-message))
+ (b (get-buffer name))
+ (m (buffer-modified-p b)))
+ (and b (not (get-buffer-window b))
+ (setq b nil))
+ (unwind-protect
+ (progn
+ (message "%s..." (capitalize (symbol-name fun)))
+ ;; with-output-to-temp-buffer marks the buffer as unmodified.
+ ;; kludging excessively and relying on that as some sort
+ ;; of indication leads to the following abomination...
+ ;;>> This would be doable without such icky kludges if either
+ ;;>> (a) there were a function to read the interactive
+ ;;>> args for a command and return a list of those args.
+ ;;>> (To which one would then just apply the command)
+ ;;>> (The only problem with this is that interactive-p
+ ;;>> would break, but that is such a misfeature in
+ ;;>> any case that I don't care)
+ ;;>> It is easy to do this for emacs-lisp functions;
+ ;;>> the only problem is getting the interactive spec
+ ;;>> for subrs
+ ;;>> (b) there were a function which returned a
+ ;;>> modification-tick for a buffer. One could tell
+ ;;>> whether a buffer had changed by whether the
+ ;;>> modification-tick were different.
+ ;;>> (Presumably there would have to be a way to either
+ ;;>> restore the tick to some previous value, or to
+ ;;>> suspend updating of the tick in order to allow
+ ;;>> things like momentary-string-display)
+ (and b
+ (save-excursion
+ (set-buffer b)
+ (set-buffer-modified-p t)))
+ (fset 'print-help-return-message 'ignore)
+ (call-interactively fun)
+ (and (get-buffer name)
+ (get-buffer-window (get-buffer name))
+ (or (not b)
+ (not (eq b (get-buffer name)))
+ (not (buffer-modified-p b)))))
+ (fset 'print-help-return-message p)
+ (and b (buffer-name b)
+ (save-excursion
+ (set-buffer b)
+ (set-buffer-modified-p m))))))
+ (with-electric-help 'ignore name t))))
+
+\f
+(defun electric-describe-key ()
+ (interactive)
+ (electric-helpify 'describe-key))
+
+(defun electric-describe-mode ()
+ (interactive)
+ (electric-helpify 'describe-mode))
+
+(defun electric-view-lossage ()
+ (interactive)
+ (electric-helpify 'view-lossage))
+
+;(defun electric-help-for-help ()
+; "See help-for-help"
+; (interactive)
+; )
+
+(defun electric-describe-function ()
+ (interactive)
+ (electric-helpify 'describe-function))
+
+(defun electric-describe-variable ()
+ (interactive)
+ (electric-helpify 'describe-variable))
+
+(defun electric-describe-bindings ()
+ (interactive)
+ (electric-helpify 'describe-bindings))
+
+(defun electric-describe-syntax ()
+ (interactive)
+ (electric-helpify 'describe-syntax))
+
+(defun electric-command-apropos ()
+ (interactive)
+ (electric-helpify 'command-apropos))
+
+;(define-key help-map "a" 'electric-command-apropos)
+
+
+
+\f
+;;;; ehelp-map
+
+(defvar ehelp-map ())
+(if ehelp-map
+ nil
+ (let ((map (copy-keymap help-map)))
+ (substitute-key-definition 'describe-key 'electric-describe-key map)
+ (substitute-key-definition 'describe-mode 'electric-describe-mode map)
+ (substitute-key-definition 'view-lossage 'electric-view-lossage map)
+ (substitute-key-definition 'describe-function 'electric-describe-function map)
+ (substitute-key-definition 'describe-variable 'electric-describe-variable map)
+ (substitute-key-definition 'describe-bindings 'electric-describe-bindings map)
+ (substitute-key-definition 'describe-syntax 'electric-describe-syntax map)
+
+ (setq ehelp-map map)
+ (fset 'ehelp-command map)))
+
+;; Do (define-key global-map "\C-h" 'ehelp-command) if you want to win
+
--- /dev/null
+;; helper - utility help package for modes which want to provide help
+;; without relinquishing control, e.g. `electric' modes.
+
+;; Copyright (C) 1985 Free Software Foundation, Inc.
+;; Principal author K. Shane Hartman
+
+;; 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+
+(provide 'helper) ; hey, here's a helping hand.
+
+;; Bind this to a string for <blank> in "... Other keys <blank>".
+;; Helper-help uses this to construct help string when scrolling.
+;; Defaults to "return"
+(defvar Helper-return-blurb nil)
+
+;; Keymap implementation doesn't work too well for non-standard loops.
+;; But define it anyway for those who can use it. Non-standard loops
+;; will probably have to use Helper-help. You can't autoload the
+;; keymap either.
+
+
+(defvar Helper-help-map nil)
+(if Helper-help-map
+ nil
+ (setq Helper-help-map (make-keymap))
+ ;(fillarray Helper-help-map 'undefined)
+ (define-key Helper-help-map "m" 'Helper-describe-mode)
+ (define-key Helper-help-map "b" 'Helper-describe-bindings)
+ (define-key Helper-help-map "c" 'Helper-describe-key-briefly)
+ (define-key Helper-help-map "k" 'Helper-describe-key)
+ ;(define-key Helper-help-map "f" 'Helper-describe-function)
+ ;(define-key Helper-help-map "v" 'Helper-describe-variable)
+ (define-key Helper-help-map "?" 'Helper-help-options)
+ (define-key Helper-help-map (char-to-string help-char) 'Helper-help-options)
+ (fset 'Helper-help-map Helper-help-map))
+
+(defun Helper-help-scroller ()
+ (let ((blurb (or (and (boundp 'Helper-return-blurb)
+ Helper-return-blurb)
+ "return")))
+ (save-window-excursion
+ (goto-char (window-start (selected-window)))
+ (if (get-buffer-window "*Help*")
+ (pop-to-buffer "*Help*")
+ (switch-to-buffer "*Help*"))
+ (goto-char (point-min))
+ (let ((continue t) state)
+ (while continue
+ (setq state (+ (* 2 (if (pos-visible-in-window-p (point-max)) 1 0))
+ (if (pos-visible-in-window-p (point-min)) 1 0)))
+ (message
+ (nth state
+ '("Space forward, Delete back. Other keys %s"
+ "Space scrolls forward. Other keys %s"
+ "Delete scrolls back. Other keys %s"
+ "Type anything to %s"))
+ blurb)
+ (setq continue (read-char))
+ (cond ((and (memq continue '(?\ ?\C-v)) (< state 2))
+ (scroll-up))
+ ((= continue ?\C-l)
+ (recenter))
+ ((and (= continue ?\177) (zerop (% state 2)))
+ (scroll-down))
+ (t (setq continue nil))))))))
+
+(defun Helper-help-options ()
+ "Describe help options."
+ (interactive)
+ (message "c (key briefly), m (mode), k (key), b (bindings)")
+ ;(message "c (key briefly), m (mode), k (key), v (variable), f (function)")
+ (sit-for 4))
+
+(defun Helper-describe-key-briefly (key)
+ "Briefly describe binding of KEYS."
+ (interactive "kDescribe key briefly: ")
+ (describe-key-briefly key)
+ (sit-for 4))
+
+(defun Helper-describe-key (key)
+ "Describe binding of KEYS."
+ (interactive "kDescribe key: ")
+ (save-window-excursion (describe-key key))
+ (Helper-help-scroller))
+
+(defun Helper-describe-function ()
+ "Describe a function. Name read interactively."
+ (interactive)
+ (save-window-excursion (call-interactively 'describe-function))
+ (Helper-help-scroller))
+
+(defun Helper-describe-variable ()
+ "Describe a variable. Name read interactively."
+ (interactive)
+ (save-window-excursion (call-interactively 'describe-variable))
+ (Helper-help-scroller))
+
+(defun Helper-describe-mode ()
+ "Describe the current mode."
+ (interactive)
+ (let ((name mode-name)
+ (documentation (documentation major-mode)))
+ (save-excursion
+ (set-buffer (get-buffer-create "*Help*"))
+ (erase-buffer)
+ (insert name " Mode\n" documentation)))
+ (Helper-help-scroller))
+
+(defun Helper-describe-bindings ()
+ "Describe local key bindings of current mode."
+ (interactive)
+ (message "Making binding list...")
+ (save-window-excursion (describe-bindings))
+ (Helper-help-scroller))
+
+(defun Helper-help ()
+ "Provide help for current mode."
+ (interactive)
+ (let ((continue t) c)
+ (while continue
+ (message "Help (Type ? for further options)")
+ (setq c (char-to-string (downcase (read-char))))
+ (setq c (lookup-key Helper-help-map c))
+ (cond ((eq c 'Helper-help-options)
+ (Helper-help-options))
+ ((commandp c)
+ (call-interactively c)
+ (setq continue nil))
+ (t
+ (ding)
+ (setq continue nil))))))
+
--- /dev/null
+;; Convert buffer of Mocklisp code to real lisp.
+;; Copyright (C) 1985 Free Software Foundation, Inc.
+
+;; 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+(defun convert-mocklisp-buffer ()
+ "Convert buffer of Mocklisp code to real Lisp that GNU Emacs can run."
+ (interactive)
+ (emacs-lisp-mode)
+ (set-syntax-table (copy-sequence (syntax-table)))
+ (modify-syntax-entry ?\| "w")
+ (message "Converting mocklisp (ugh!)...")
+ (goto-char (point-min))
+ (fix-mlisp-syntax)
+
+ ;; Emulation of mocklisp is accurate only within a mocklisp-function
+ ;; so turn any non-function into a defun and then call it.
+ (goto-char (point-min))
+ (condition-case ignore
+ (while t
+ (let ((opt (point))
+ (form (read (current-buffer))))
+ (and (listp form)
+ (not (eq (car form) 'defun))
+ (progn (insert "))\n\n(ml-foo)\n\n")
+ (save-excursion
+ (goto-char opt)
+ (skip-chars-forward "\n")
+ (insert "(defun (ml-foo \n "))))))
+ (end-of-file nil))
+
+ (goto-char (point-min))
+ (insert ";;; GNU Emacs code converted from Mocklisp\n")
+ (insert "(require 'mlsupport)\n\n")
+ (fix-mlisp-symbols)
+
+ (goto-char (point-min))
+ (message "Converting mocklisp...done"))
+
+(defun fix-mlisp-syntax ()
+ (while (re-search-forward "['\"]" nil t)
+ (if (= (preceding-char) ?\")
+ (progn (forward-char -1)
+ (forward-sexp 1))
+ (delete-char -1)
+ (insert "?")
+ (if (or (= (following-char) ?\\) (= (following-char) ?^))
+ (forward-char 1)
+ (if (looking-at "[^a-zA-Z]")
+ (insert ?\\)))
+ (forward-char 1)
+ (delete-char 1))))
+
+(defun fix-mlisp-symbols ()
+ (while (progn
+ (skip-chars-forward " \t\n()")
+ (not (eobp)))
+ (cond ((or (= (following-char) ?\?)
+ (= (following-char) ?\"))
+ (forward-sexp 1))
+ ((= (following-char) ?\;)
+ (forward-line 1))
+ (t
+ (let ((start (point)) prop)
+ (forward-sexp 1)
+ (setq prop (get (intern-soft (buffer-substring start (point)))
+ 'mocklisp))
+ (cond ((null prop))
+ ((stringp prop)
+ (delete-region start (point))
+ (insert prop))
+ (t
+ (save-excursion
+ (goto-char start)
+ (funcall prop)))))))))
+
+(defun ml-expansion (ml-name lisp-string)
+ (put ml-name 'mocklisp lisp-string))
+
+(ml-expansion 'defun "ml-defun")
+(ml-expansion 'if "ml-if")
+(ml-expansion 'setq '(lambda ()
+ (if (looking-at "setq[ \t\n]+buffer-modified-p")
+ (replace-match "set-buffer-modified-p"))))
+
+(ml-expansion 'while '(lambda ()
+ (let ((end (progn (forward-sexp 2) (point-marker)))
+ (start (progn (forward-sexp -1) (point))))
+ (let ((cond (buffer-substring start end)))
+ (cond ((equal cond "1")
+ (delete-region (point) end)
+ (insert "t"))
+ (t
+ (insert "(not (zerop ")
+ (goto-char end)
+ (insert "))")))
+ (set-marker end nil)
+ (goto-char start)))))
+
+(ml-expansion 'arg "ml-arg")
+(ml-expansion 'nargs "ml-nargs")
+(ml-expansion 'interactive "ml-interactive")
+(ml-expansion 'message "ml-message")
+(ml-expansion 'print "ml-print")
+(ml-expansion 'set "ml-set")
+(ml-expansion 'set-default "ml-set-default")
+(ml-expansion 'provide-prefix-argument "ml-provide-prefix-argument")
+(ml-expansion 'prefix-argument-loop "ml-prefix-argument-loop")
+(ml-expansion 'prefix-argument "ml-prefix-arg")
+(ml-expansion 'use-local-map "ml-use-local-map")
+(ml-expansion 'use-global-map "ml-use-global-map")
+(ml-expansion 'modify-syntax-entry "ml-modify-syntax-entry")
+(ml-expansion 'error-message "error")
+
+(ml-expansion 'dot "point-marker")
+(ml-expansion 'mark "mark-marker")
+(ml-expansion 'beginning-of-file "beginning-of-buffer")
+(ml-expansion 'end-of-file "end-of-buffer")
+(ml-expansion 'exchange-dot-and-mark "exchange-point-and-mark")
+(ml-expansion 'set-mark "set-mark-command")
+(ml-expansion 'argument-prefix "universal-arg")
+
+(ml-expansion 'previous-page "ml-previous-page")
+(ml-expansion 'next-page "ml-next-page")
+(ml-expansion 'next-window "ml-next-window")
+(ml-expansion 'previous-window "ml-previous-window")
+
+(ml-expansion 'newline "ml-newline")
+(ml-expansion 'next-line "ml-next-line")
+(ml-expansion 'previous-line "ml-previous-line")
+(ml-expansion 'self-insert "self-insert-command")
+(ml-expansion 'meta-digit "digit-argument")
+(ml-expansion 'meta-minus "negative-argument")
+
+(ml-expansion 'newline-and-indent "ml-newline-and-indent")
+(ml-expansion 'yank-from-killbuffer "yank")
+(ml-expansion 'yank-buffer "insert-buffer")
+(ml-expansion 'copy-region "copy-region-as-kill")
+(ml-expansion 'delete-white-space "delete-horizontal-space")
+(ml-expansion 'widen-region "widen")
+
+(ml-expansion 'forward-word '(lambda ()
+ (if (looking-at "forward-word[ \t\n]*)")
+ (replace-match "forward-word 1)"))))
+(ml-expansion 'backward-word '(lambda ()
+ (if (looking-at "backward-word[ \t\n]*)")
+ (replace-match "backward-word 1)"))))
+
+(ml-expansion 'forward-paren "forward-list")
+(ml-expansion 'backward-paren "backward-list")
+(ml-expansion 'search-reverse "ml-search-backward")
+(ml-expansion 're-search-reverse "ml-re-search-backward")
+(ml-expansion 'search-forward "ml-search-forward")
+(ml-expansion 're-search-forward "ml-re-search-forward")
+(ml-expansion 'quote "regexp-quote")
+(ml-expansion 're-query-replace "query-replace-regexp")
+(ml-expansion 're-replace-string "replace-regexp")
+
+; forward-paren-bl, backward-paren-bl
+
+(ml-expansion 'get-tty-character "read-char")
+(ml-expansion 'get-tty-input "read-input")
+(ml-expansion 'get-tty-string "read-string")
+(ml-expansion 'get-tty-buffer "read-buffer")
+(ml-expansion 'get-tty-command "read-command")
+(ml-expansion 'get-tty-variable "read-variable")
+(ml-expansion 'get-tty-no-blanks-input "read-no-blanks-input")
+(ml-expansion 'get-tty-key "read-key")
+
+(ml-expansion 'c= "char-equal")
+(ml-expansion 'goto-character "goto-char")
+(ml-expansion 'substr "ml-substr")
+(ml-expansion 'variable-apropos "apropos")
+(ml-expansion 'execute-mlisp-buffer "eval-current-buffer")
+(ml-expansion 'execute-mlisp-file "load")
+(ml-expansion 'visit-file "find-file")
+(ml-expansion 'read-file "find-file")
+(ml-expansion 'write-modified-files "save-some-buffers")
+(ml-expansion 'backup-before-writing "make-backup-files")
+(ml-expansion 'write-file-exit "save-buffers-kill-emacs")
+(ml-expansion 'write-named-file "write-file")
+(ml-expansion 'change-file-name "set-visited-file-name")
+(ml-expansion 'change-buffer-name "rename-buffer")
+(ml-expansion 'buffer-exists "get-buffer")
+(ml-expansion 'delete-buffer "kill-buffer")
+(ml-expansion 'unlink-file "delete-file")
+(ml-expansion 'unlink-checkpoint-files "delete-auto-save-files")
+(ml-expansion 'file-exists "file-exists-p")
+(ml-expansion 'write-current-file "save-buffer")
+(ml-expansion 'change-directory "cd")
+(ml-expansion 'temp-use-buffer "set-buffer")
+(ml-expansion 'fast-filter-region "filter-region")
+
+(ml-expansion 'pending-input "input-pending-p")
+(ml-expansion 'execute-keyboard-macro "call-last-kbd-macro")
+(ml-expansion 'start-remembering "start-kbd-macro")
+(ml-expansion 'end-remembering "end-kbd-macro")
+(ml-expansion 'define-keyboard-macro "name-last-kbd-macro")
+(ml-expansion 'define-string-macro "ml-define-string-macro")
+
+(ml-expansion 'current-column "ml-current-column")
+(ml-expansion 'current-indent "ml-current-indent")
+(ml-expansion 'insert-character "insert")
+
+(ml-expansion 'users-login-name "user-login-name")
+(ml-expansion 'users-full-name "user-full-name")
+(ml-expansion 'current-time "current-time-string")
+(ml-expansion 'current-numeric-time "current-numeric-time-you-lose")
+(ml-expansion 'current-buffer-name "buffer-name")
+(ml-expansion 'current-file-name "buffer-file-name")
+
+(ml-expansion 'local-binding-of "local-key-binding")
+(ml-expansion 'global-binding-of "global-key-binding")
+
+;defproc (ProcedureType, "procedure-type");
+
+(ml-expansion 'remove-key-binding "global-unset-key")
+(ml-expansion 'remove-binding "global-unset-key")
+(ml-expansion 'remove-local-binding "local-unset-key")
+(ml-expansion 'remove-all-local-bindings "use-local-map nil")
+(ml-expansion 'autoload "ml-autoload")
+
+(ml-expansion 'checkpoint-frequency "auto-save-interval")
+
+(ml-expansion 'mode-string "mode-name")
+(ml-expansion 'right-margin "fill-column")
+(ml-expansion 'tab-size "tab-width")
+(ml-expansion 'default-right-margin "default-fill-column")
+(ml-expansion 'default-tab-size "default-tab-width")
+(ml-expansion 'buffer-is-modified "(buffer-modified-p)")
+
+(ml-expansion 'file-modified-time "you-lose-on-file-modified-time")
+(ml-expansion 'needs-checkpointing "you-lose-on-needs-checkpointing")
+
+(ml-expansion 'lines-on-screen "set-screen-height")
+(ml-expansion 'columns-on-screen "set-screen-width")
+
+(ml-expansion 'dumped-emacs "t")
+
+(ml-expansion 'buffer-size "ml-buffer-size")
+(ml-expansion 'dot-is-visible "pos-visible-in-window-p")
+
+(ml-expansion 'track-eol-on-^N-^P "track-eol")
+(ml-expansion 'ctlchar-with-^ "ctl-arrow")
+(ml-expansion 'help-on-command-completion-error "completion-auto-help")
+(ml-expansion 'dump-stack-trace "backtrace")
+(ml-expansion 'pause-emacs "suspend-emacs")
+(ml-expansion 'compile-it "compile")
+
+(ml-expansion '!= "/=")
+(ml-expansion '& "logand")
+(ml-expansion '| "logior")
+(ml-expansion '^ "logxor")
+(ml-expansion '! "ml-not")
+(ml-expansion '<< "lsh")
+
+;Variable pause-writes-files
+
--- /dev/null
+;; Basic editing commands for Emacs
+;; Copyright (C) 1985, 1986, 1987 Free Software Foundation, Inc.
+
+;; 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;; Provide a meaningful error message if we are running on
+;; bare (non-float) emacs.
+;; Can't test for 'floatp since that may be defined by float-imitation
+;; packages like float.el in this very directory.
+
+(if (fboundp 'atan)
+ nil
+ (error "Floating point was disabled at compile time"))
+
+;; provide an easy hook to tell if we are running with floats or not.
+(provide 'lisp-float-type)
+
+;; define pi and e via math-lib calls. (much less prone to killer typos.)
+(defconst pi (* 4 (atan 1)) "The value of Pi (3.1415926...)")
+(defconst e (exp 1) "The value of e (2.7182818...)")
+
+;; Careful when editing this file ... typos here will be hard to spot.
+;; (defconst pi 3.14159265358979323846264338327
+;; "The value of Pi (3.14159265358979323846264338327...)")
+
+(defconst degrees-to-radians (/ pi 180.0)
+ "Degrees to radian conversion constant")
+(defconst radians-to-degrees (/ 180.0 pi)
+ "Radian to degree conversion constant")
+
+;; these expand to a single multiply by a float
+;; when byte compiled
+
+(defmacro degrees-to-radians (x)
+ "Convert ARG from degrees to radians."
+ (list '* (/ pi 180.0) x))
+(defmacro radians-to-degrees (x)
+ "Convert ARG from radians to degrees."
+ (list '* (/ 180.0 pi) x))
--- /dev/null
+;; Rebindings to imitate Gosmacs.
+;; Copyright (C) 1986 Free Software Foundation, Inc.
+
+;; 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+
+(defvar non-gosmacs-binding-alist nil)
+
+(defun set-gosmacs-bindings ()
+ "Rebind some keys globally to make GNU Emacs resemble Gosling Emacs.
+Use \\[set-gnu-bindings] to restore previous global bindings."
+ (interactive)
+ (setq non-gosmacs-binding-alist
+ (rebind-and-record
+ '(("\C-x\C-e" compile)
+ ("\C-x\C-f" save-buffers-kill-emacs)
+ ("\C-x\C-i" insert-file)
+ ("\C-x\C-m" save-some-buffers)
+ ("\C-x\C-n" next-error)
+ ("\C-x\C-o" switch-to-buffer)
+ ("\C-x\C-r" insert-file)
+ ("\C-x\C-u" undo)
+ ("\C-x\C-v" find-file-other-window)
+ ("\C-x\C-z" shrink-window)
+ ("\C-x!" shell-command)
+ ("\C-xd" delete-window)
+ ("\C-xn" gosmacs-next-window)
+ ("\C-xp" gosmacs-previous-window)
+ ("\C-xz" enlarge-window)
+ ("\C-z" scroll-one-line-up)
+ ("\e\C-c" save-buffers-kill-emacs)
+ ("\e!" line-to-top-of-window)
+ ("\e(" backward-paragraph)
+ ("\e)" forward-paragraph)
+ ("\e?" apropos)
+ ("\eh" delete-previous-word)
+ ("\ej" indent-sexp)
+ ("\eq" query-replace)
+ ("\er" replace-string)
+ ("\ez" scroll-one-line-down)
+ ("\C-_" suspend-emacs)))))
+
+(defun rebind-and-record (bindings)
+ "Establish many new global bindings and record the bindings replaced.
+Arg is an alist whose elements are (KEY DEFINITION).
+Value is a similar alist whose elements describe the same KEYs
+but each with the old definition that was replaced,"
+ (let (old)
+ (while bindings
+ (let* ((this (car bindings))
+ (key (car this))
+ (newdef (nth 1 this)))
+ (setq old (cons (list key (lookup-key global-map key)) old))
+ (global-set-key key newdef))
+ (setq bindings (cdr bindings)))
+ (nreverse old)))
+
+(defun set-gnu-bindings ()
+ "Restore the global bindings that were changed by \\[set-gosmacs-bindings]."
+ (interactive)
+ (rebind-and-record non-gosmacs-binding-alist))
+
+(defun gosmacs-previous-window ()
+ "Select the window above or to the left of the window now selected.
+From the window at the upper left corner, select the one at the lower right."
+ (interactive)
+ (select-window (previous-window)))
+
+(defun gosmacs-next-window ()
+ "Select the window below or to the right of the window now selected.
+From the window at the lower right corner, select the one at the upper left."
+ (interactive)
+ (select-window (next-window)))
+
+(defun scroll-one-line-up (&optional arg)
+ "Scroll the selected window up (forward in the text) one line (or N lines)."
+ (interactive "p")
+ (scroll-up (or arg 1)))
+
+(defun scroll-one-line-down (&optional arg)
+ "Scroll the selected window down (backward in the text) one line (or N)."
+ (interactive "p")
+ (scroll-down (or arg 1)))
+
+(defun line-to-top-of-window ()
+ "Scroll the selected window up so that the current line is at the top."
+ (interactive)
+ (recenter 0))
--- /dev/null
+;; -*-Emacs-Lisp-*-
+;; hexl-mode -- Edit a file in a hex dump format.
+;; Copyright (C) 1989 Free Software Foundation, Inc.
+
+;; 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;
+;; By: Keith Gabryelski (ag@wheaties.ai.mit.edu)
+;;
+;; This may be useful in your .emacs:
+;;
+;; (autoload 'hexl-find-file "hexl"
+;; "Edit file FILENAME in hexl-mode." t)
+;;
+;; (define-key global-map "\C-c\C-h" 'hexl-find-file)
+;;
+;; NOTE: Remember to change HEXL-PROGRAM or HEXL-OPTIONS if needed.
+;;
+;; Currently hexl only supports big endian hex output with 16 bit
+;; grouping.
+;;
+;; -iso in `hexl-options' will allow iso characters to display in the
+;; ASCII region of the screen (if your emacs supports this) instead of
+;; changing them to dots.
+
+;;
+;; vars here
+;;
+
+(defvar hexl-program "hexl"
+ "The program that will hexlify and de-hexlify its stdin. hexl-program
+will always be concated with hexl-options and "-de" when dehexlfying a
+buffer.")
+
+(defvar hexl-iso ""
+ "If your emacs can handle ISO characters, this should be set to
+\"-iso\" otherwise it should be \"\".")
+
+(defvar hexl-options (format "-hex %s" hexl-iso)
+ "Options to hexl-program that suit your needs.")
+
+(defvar hexlify-command (format "%s %s" hexl-program hexl-options)
+ "The command to use to hexlify a buffer. It is the concatination of
+`hexl-program' and `hexl-options'.")
+
+(defvar dehexlify-command (format "%s -de %s" hexl-program hexl-options)
+ "The command to use to unhexlify a buffer. It is the concatination of
+`hexl-program', the option \"-de\", and `hexl-options'.")
+
+(defvar hexl-max-address 0
+ "Maximum offset into hexl buffer.")
+
+(defvar hexl-mode-map nil)
+
+;; routines
+
+(defun hexl-mode (&optional arg)
+ "\\<hexl-mode-map>
+A major mode for editting binary files in hex dump format.
+
+This function automatically converts a buffer into the hexl format
+using the function `hexlify-buffer'.
+
+Each line in the buffer has an `address' (displayed in hexadecimal)
+representing the offset into the file that the characters on this line
+are at and 16 characters from the file (displayed as hexadecimal
+values grouped every 16 bits) and as their ASCII values.
+
+If any of the characters (displayed as ASCII characters) are
+unprintable (control or meta characters) they will be replaced as
+periods.
+
+If hexl-mode is invoked with an argument the buffer is assumed to be
+in hexl-format.
+
+A sample format:
+
+ HEX ADDR: 0001 0203 0405 0607 0809 0a0b 0c0d 0e0f ASCII-TEXT
+ -------- ---- ---- ---- ---- ---- ---- ---- ---- ----------------
+ 00000000: 5468 6973 2069 7320 6865 786c 2d6d 6f64 This is hexl-mod
+ 00000010: 652e 2020 4561 6368 206c 696e 6520 7265 e. Each line re
+ 00000020: 7072 6573 656e 7473 2031 3620 6279 7465 presents 16 byte
+ 00000030: 7320 6173 2068 6578 6164 6563 696d 616c s as hexadecimal
+ 00000040: 2041 5343 4949 0a61 6e64 2070 7269 6e74 ASCII.and print
+ 00000050: 6162 6c65 2041 5343 4949 2063 6861 7261 able ASCII chara
+ 00000060: 6374 6572 732e 2020 416e 7920 636f 6e74 cters. Any cont
+ 00000070: 726f 6c20 6f72 206e 6f6e 2d41 5343 4949 rol or non-ASCII
+ 00000080: 2063 6861 7261 6374 6572 730a 6172 6520 characters.are
+ 00000090: 6469 7370 6c61 7965 6420 6173 2070 6572 displayed as per
+ 000000a0: 696f 6473 2069 6e20 7468 6520 7072 696e iods in the prin
+ 000000b0: 7461 626c 6520 6368 6172 6163 7465 7220 table character
+ 000000c0: 7265 6769 6f6e 2e0a region..
+
+Movement is as simple as movement in a normal emacs text buffer. Most
+cursor movement bindings are the same (ie. Use \\[hexl-backward-char], \\[hexl-forward-char], \\[hexl-next-line], and \\[hexl-previous-line]
+to move the cursor left, right, down, and up).
+
+Advanced cursor movement commands (ala \\[hexl-beginning-of-line], \\[hexl-end-of-line], \\[hexl-beginning-of-buffer], and \\[hexl-end-of-buffer]) are
+also supported.
+
+There are several ways to change text in hexl mode:
+
+ASCII characters (character between space (0x20) and tilde (0x7E)) are
+bound to self-insert so you can simply type the character and it will
+insert itself (actually overstrike) into the buffer.
+
+\\[hexl-quoted-insert] followed by another keystroke allows you to insert the key even if
+it isn't bound to self-insert. An octal number can be supplied in place
+of another key to insert the octal number's ASCII representation.
+
+\\[hexl-insert-hex-char] will insert a given hexadecimal value (if it is between 0 and 0xFF)
+into the buffer at the current point.
+
+\\[hexl-insert-octal-char] will insert a given octal value (if it is between 0 and 0377)
+into the buffer at the current point.
+
+\\[hexl-insert-decimal-char] will insert a given decimal value (if it is between 0 and 255)
+into the buffer at the current point.
+
+\\[hexl-save-buffer] will save the buffer in is binary format.
+
+\\[hexl-mode-exit] will exit hexl-mode.
+
+Note: \\[write-file] will write the file out in HEXL FORMAT.
+
+You can use \\[hexl-find-file] to visit a file in hexl-mode.
+
+\\[describe-bindings] for advanced commands."
+ (interactive "p")
+ (if (eq major-mode 'hexl-mode)
+ (error "You are already in hexl mode.")
+ (kill-all-local-variables)
+ (make-local-variable 'hexl-mode-old-local-map)
+ (setq hexl-mode-old-local-map (current-local-map))
+ (use-local-map hexl-mode-map)
+
+ (make-local-variable 'hexl-mode-old-mode-name)
+ (setq hexl-mode-old-mode-name mode-name)
+ (setq mode-name "Hexl")
+
+ (make-local-variable 'hexl-mode-old-major-mode)
+ (setq hexl-mode-old-major-mode major-mode)
+ (setq major-mode 'hexl-mode)
+
+ (let ((modified (buffer-modified-p))
+ (read-only buffer-read-only)
+ (original-point (1- (point))))
+ (if (not (or (eq arg 1) (not arg)))
+;; if no argument then we guess at hexl-max-address
+ (setq hexl-max-address (+ (* (/ (1- (buffer-size)) 68) 16) 15))
+ (setq buffer-read-only nil)
+ (setq hexl-max-address (1- (buffer-size)))
+ (hexlify-buffer)
+ (set-buffer-modified-p modified)
+ (setq buffer-read-only read-only)
+ (hexl-goto-address original-point)))))
+
+(defun hexl-save-buffer ()
+ "Save a hexl format buffer as binary in visited file if modified."
+ (interactive)
+ (set-buffer-modified-p (if (buffer-modified-p)
+ (save-excursion
+ (let ((buf (generate-new-buffer " hexl"))
+ (name (buffer-name))
+ (file-name (buffer-file-name))
+ (start (point-min))
+ (end (point-max))
+ modified)
+ (set-buffer buf)
+ (insert-buffer-substring name start end)
+ (set-buffer name)
+ (dehexlify-buffer)
+ (save-buffer)
+ (setq modified (buffer-modified-p))
+ (delete-region (point-min) (point-max))
+ (insert-buffer-substring buf start end)
+ (kill-buffer buf)
+ modified))
+ (message "(No changes need to be saved)")
+ nil)))
+
+(defun hexl-find-file (filename)
+ "Edit file FILENAME in hexl-mode.
+
+Switch to a buffer visiting file FILENAME, creating one in none exists."
+ (interactive "fFilename: ")
+ (find-file filename)
+ (if (not (eq major-mode 'hexl-mode))
+ (hexl-mode)))
+
+(defun hexl-mode-exit (&optional arg)
+ "Exit hexl-mode returning to previous mode.
+With arg, don't unhexlify buffer."
+ (interactive "p")
+ (if (or (eq arg 1) (not arg))
+ (let ((modified (buffer-modified-p))
+ (read-only buffer-read-only)
+ (original-point (1+ (hexl-current-address))))
+ (setq buffer-read-only nil)
+ (dehexlify-buffer)
+ (set-buffer-modified-p modified)
+ (setq buffer-read-only read-only)
+ (goto-char original-point)))
+ (setq mode-name hexl-mode-old-mode-name)
+ (use-local-map hexl-mode-old-local-map)
+ (setq major-mode hexl-mode-old-major-mode)
+;; Kludge to update mode-line
+ (switch-to-buffer (current-buffer))
+)
+
+(defun hexl-current-address ()
+ "Return current hexl-address."
+ (interactive)
+ (let ((current-column (- (% (point) 68) 11))
+ (hexl-address 0))
+ (setq hexl-address (+ (* (/ (point) 68) 16)
+ (/ (- current-column (/ current-column 5)) 2)))
+ hexl-address))
+
+(defun hexl-address-to-marker (address)
+ "Return marker for ADDRESS."
+ (interactive "nAddress: ")
+ (+ (* (/ address 16) 68) 11 (/ (* (% address 16) 5) 2)))
+
+(defun hexl-goto-address (address)
+ "Goto hexl-mode (decimal) address ADDRESS.
+
+Signal error if ADDRESS out of range."
+ (interactive "nAddress: ")
+ (if (or (< address 0) (> address hexl-max-address))
+ (error "Out of hexl region."))
+ (goto-char (hexl-address-to-marker address)))
+
+(defun hexl-goto-hex-address (hex-address)
+ "Goto hexl-mode address (hex string) HEX-ADDRESS.
+
+Signal error if HEX-ADDRESS is out of range."
+ (interactive "sHex Address: ")
+ (hexl-goto-address (hexl-hex-string-to-integer hex-address)))
+
+(defun hexl-hex-string-to-integer (hex-string)
+ "Return decimal integer for HEX-STRING."
+ (interactive "sHex number: ")
+ (let ((hex-num 0))
+ (while (not (equal hex-string ""))
+ (setq hex-num (+ (* hex-num 16)
+ (hexl-hex-char-to-integer (string-to-char hex-string))))
+ (setq hex-string (substring hex-string 1)))
+ hex-num))
+
+(defun hexl-octal-string-to-integer (octal-string)
+ "Return decimal integer for OCTAL-STRING."
+ (interactive "sOctal number: ")
+ (let ((oct-num 0))
+ (while (not (equal octal-string ""))
+ (setq oct-num (+ (* oct-num 8)
+ (hexl-oct-char-to-integer
+ (string-to-char octal-string))))
+ (setq octal-string (substring octal-string 1)))
+ oct-num))
+
+;; move point functions
+
+(defun hexl-backward-char (arg)
+ "Move to left ARG bytes (right if ARG negative) in hexl-mode."
+ (interactive "p")
+ (hexl-goto-address (- (hexl-current-address) arg)))
+
+(defun hexl-forward-char (arg)
+ "Move right ARG bytes (left if ARG negative) in hexl-mode."
+ (interactive "p")
+ (hexl-goto-address (+ (hexl-current-address) arg)))
+
+(defun hexl-backward-short (arg)
+ "Move to left ARG shorts (right if ARG negative) in hexl-mode."
+ (interactive "p")
+ (hexl-goto-address (let ((address (hexl-current-address)))
+ (if (< arg 0)
+ (progn
+ (setq arg (- arg))
+ (while (> arg 0)
+ (if (not (equal address (logior address 3)))
+ (if (> address hexl-max-address)
+ (progn
+ (message "End of buffer.")
+ (setq address hexl-max-address))
+ (setq address (logior address 3)))
+ (if (> address hexl-max-address)
+ (progn
+ (message "End of buffer.")
+ (setq address hexl-max-address))
+ (setq address (+ address 4))))
+ (setq arg (1- arg)))
+ (if (> address hexl-max-address)
+ (progn
+ (message "End of buffer.")
+ (setq address hexl-max-address))
+ (setq address (logior address 3))))
+ (while (> arg 0)
+ (if (not (equal address (logand address -4)))
+ (setq address (logand address -4))
+ (if (not (equal address 0))
+ (setq address (- address 4))
+ (message "Beginning of buffer.")))
+ (setq arg (1- arg))))
+ address)))
+
+(defun hexl-forward-short (arg)
+ "Move right ARG shorts (left if ARG negative) in hexl-mode."
+ (interactive "p")
+ (hexl-backward-short (- arg)))
+
+(defun hexl-backward-word (arg)
+ "Move to left ARG words (right if ARG negative) in hexl-mode."
+ (interactive "p")
+ (hexl-goto-address (let ((address (hexl-current-address)))
+ (if (< arg 0)
+ (progn
+ (setq arg (- arg))
+ (while (> arg 0)
+ (if (not (equal address (logior address 7)))
+ (if (> address hexl-max-address)
+ (progn
+ (message "End of buffer.")
+ (setq address hexl-max-address))
+ (setq address (logior address 7)))
+ (if (> address hexl-max-address)
+ (progn
+ (message "End of buffer.")
+ (setq address hexl-max-address))
+ (setq address (+ address 8))))
+ (setq arg (1- arg)))
+ (if (> address hexl-max-address)
+ (progn
+ (message "End of buffer.")
+ (setq address hexl-max-address))
+ (setq address (logior address 7))))
+ (while (> arg 0)
+ (if (not (equal address (logand address -8)))
+ (setq address (logand address -8))
+ (if (not (equal address 0))
+ (setq address (- address 8))
+ (message "Beginning of buffer.")))
+ (setq arg (1- arg))))
+ address)))
+
+(defun hexl-forward-word (arg)
+ "Move right ARG words (left if ARG negative) in hexl-mode."
+ (interactive "p")
+ (hexl-backward-word (- arg)))
+
+(defun hexl-previous-line (arg)
+ "Move vertically up ARG lines [16 bytes] (down if ARG negative) in
+hexl-mode.
+
+If there is byte at the target address move to the last byte in that
+line."
+ (interactive "p")
+ (hexl-next-line (- arg)))
+
+(defun hexl-next-line (arg)
+ "Move vertically down ARG lines [16 bytes] (up if ARG negative) in
+hexl-mode.
+
+If there is no byte at the target address move to the last byte in that
+line."
+ (interactive "p")
+ (hexl-goto-address (let ((address (+ (hexl-current-address) (* arg 16)) t))
+ (if (and (< arg 0) (< address 0))
+ (progn (message "Out of hexl region.")
+ (setq address
+ (% (hexl-current-address) 16)))
+ (if (and (> address hexl-max-address)
+ (< (% hexl-max-address 16) (% address 16)))
+ (setq address hexl-max-address)
+ (if (> address hexl-max-address)
+ (progn (message "Out of hexl region.")
+ (setq
+ address
+ (+ (logand hexl-max-address -16)
+ (% (hexl-current-address) 16)))))))
+ address)))
+
+(defun hexl-beginning-of-buffer (arg)
+ "Move to the beginning of the hexl buffer; leave hexl-mark at previous
+posistion.
+
+With arg N, put point N bytes of the way from the true beginning."
+ (interactive "p")
+ (push-mark (point))
+ (hexl-goto-address (+ 0 (1- arg))))
+
+(defun hexl-end-of-buffer (arg)
+ "Goto hexl-max-address minus ARG."
+ (interactive "p")
+ (push-mark (point))
+ (hexl-goto-address (- hexl-max-address (1- arg))))
+
+(defun hexl-beginning-of-line ()
+ "Goto beginning of line in hexl mode."
+ (interactive)
+ (goto-char (+ (* (/ (point) 68) 68) 11)))
+
+(defun hexl-end-of-line ()
+ "Goto end of line in hexl mode."
+ (interactive)
+ (hexl-goto-address (let ((address (logior (hexl-current-address) 15)))
+ (if (> address hexl-max-address)
+ (setq address hexl-max-address))
+ address)))
+
+(defun hexl-scroll-down (arg)
+ "Scroll hexl buffer window upward ARG lines; or near full window if no ARG."
+ (interactive "P")
+ (if (null arg)
+ (setq arg (1- (window-height)))
+ (setq arg (prefix-numeric-value arg)))
+ (hexl-scroll-up (- arg)))
+
+(defun hexl-scroll-up (arg)
+ "Scroll hexl buffer window upward ARG lines; or near full window if no ARG."
+ (interactive "P")
+ (if (null arg)
+ (setq arg (1- (window-height)))
+ (setq arg (prefix-numeric-value arg)))
+ (let ((movement (* arg 16))
+ (address (hexl-current-address)))
+ (if (or (> (+ address movement) hexl-max-address)
+ (< (+ address movement) 0))
+ (message "Out of hexl region.")
+ (hexl-goto-address (+ address movement))
+ (recenter 0))))
+
+(defun hexl-beginning-of-1k-page ()
+ "Goto to beginning of 1k boundry."
+ (interactive)
+ (hexl-goto-address (logand (hexl-current-address) -1024)))
+
+(defun hexl-end-of-1k-page ()
+ "Goto to end of 1k boundry."
+ (interactive)
+ (hexl-goto-address (let ((address (logior (hexl-current-address) 1023)))
+ (if (> address hexl-max-address)
+ (setq address hexl-max-address))
+ address)))
+
+(defun hexl-beginning-of-512b-page ()
+ "Goto to beginning of 512 byte boundry."
+ (interactive)
+ (hexl-goto-address (logand (hexl-current-address) -512)))
+
+(defun hexl-end-of-512b-page ()
+ "Goto to end of 512 byte boundry."
+ (interactive)
+ (hexl-goto-address (let ((address (logior (hexl-current-address) 511)))
+ (if (> address hexl-max-address)
+ (setq address hexl-max-address))
+ address)))
+
+(defun hexl-quoted-insert (arg)
+ "Read next input character and insert it.
+Useful for inserting control characters.
+You may also type up to 3 octal digits, to insert a character with that code"
+ (interactive "p")
+ (hexl-insert-char (read-quoted-char) arg))
+
+;00000000: 0011 2233 4455 6677 8899 aabb ccdd eeff 0123456789ABCDEF
+
+(defun hexlify-buffer ()
+ "Convert a binary buffer to hexl format"
+ (interactive)
+ (shell-command-on-region (point-min) (point-max) hexlify-command t))
+
+(defun dehexlify-buffer ()
+ "Convert a hexl format buffer to binary."
+ (interactive)
+ (shell-command-on-region (point-min) (point-max) dehexlify-command t))
+
+(defun hexl-char-after-point ()
+ "Return char for ASCII hex digits at point."
+ (setq lh (char-after (point)))
+ (setq rh (char-after (1+ (point))))
+ (hexl-htoi lh rh))
+
+(defun hexl-htoi (lh rh)
+ "Hex (char) LH (char) RH to integer."
+ (+ (* (hexl-hex-char-to-integer lh) 16)
+ (hexl-hex-char-to-integer rh)))
+
+(defun hexl-hex-char-to-integer (character)
+ "Take a char and return its value as if it was a hex digit."
+ (if (and (>= character ?0) (<= character ?9))
+ (- character ?0)
+ (let ((ch (logior character 32)))
+ (if (and (>= ch ?a) (<= ch ?f))
+ (- ch (- ?a 10))
+ (error (format "Invalid hex digit `%c'." ch))))))
+
+(defun hexl-oct-char-to-integer (character)
+ "Take a char and return its value as if it was a octal digit."
+ (if (and (>= character ?0) (<= character ?7))
+ (- character ?0)
+ (error (format "Invalid octal digit `%c'." character))))
+
+(defun hexl-printable-character (ch)
+ "Return a displayable string for character CH."
+ (format "%c" (if hexl-iso
+ (if (or (< ch 32) (and (>= ch 127) (< ch 160)))
+ 46
+ ch)
+ (if (or (< ch 32) (>= ch 127))
+ 46
+ ch))))
+
+(defun hexl-self-insert-command (arg)
+ "Insert this character."
+ (interactive "p")
+ (hexl-insert-char last-command-char arg))
+
+(defun hexl-insert-char (ch num)
+ "Insert a character in a hexl buffer."
+ (let ((address (hexl-current-address)))
+ (while (> num 0)
+ (delete-char 2)
+ (insert (format "%02x" ch))
+ (goto-char
+ (+ (* (/ address 16) 68) 52 (% address 16)))
+ (delete-char 1)
+ (insert (hexl-printable-character ch))
+ (if (eq address hexl-max-address)
+ (hexl-goto-address address)
+ (hexl-goto-address (1+ address)))
+ (setq num (1- num)))))
+
+;; hex conversion
+
+(defun hexl-insert-hex-char (arg)
+ "Insert a ASCII char ARG times at point for a given hexadecimal number."
+ (interactive "p")
+ (let ((num (hexl-hex-string-to-integer (read-string "Hex number: "))))
+ (if (or (> num 255) (< num 0))
+ (error "Hex number out of range.")
+ (hexl-insert-char num arg))))
+
+(defun hexl-insert-decimal-char (arg)
+ "Insert a ASCII char ARG times at point for a given decimal number."
+ (interactive "p")
+ (let ((num (string-to-int (read-string "Decimal Number: "))))
+ (if (or (> num 255) (< num 0))
+ (error "Decimal number out of range.")
+ (hexl-insert-char num arg))))
+
+(defun hexl-insert-octal-char (arg)
+ "Insert a ASCII char ARG times at point for a given octal number."
+ (interactive "p")
+ (let ((num (hexl-octal-string-to-integer (read-string "Octal Number: "))))
+ (if (or (> num 255) (< num 0))
+ (error "Decimal number out of range.")
+ (hexl-insert-char num arg))))
+
+;; startup stuff.
+
+(if hexl-mode-map
+ nil
+ (setq hexl-mode-map (make-sparse-keymap))
+
+ (define-key hexl-mode-map "\C-a" 'hexl-beginning-of-line)
+ (define-key hexl-mode-map "\C-b" 'hexl-backward-char)
+ (define-key hexl-mode-map "\C-d" 'undefined)
+ (define-key hexl-mode-map "\C-e" 'hexl-end-of-line)
+ (define-key hexl-mode-map "\C-f" 'hexl-forward-char)
+
+ (if (not (eq (key-binding "\C-h") 'help-command))
+ (define-key hexl-mode-map "\C-h" 'undefined))
+
+ (define-key hexl-mode-map "\C-i" 'hexl-self-insert-command)
+ (define-key hexl-mode-map "\C-j" 'hexl-self-insert-command)
+ (define-key hexl-mode-map "\C-k" 'undefined)
+ (define-key hexl-mode-map "\C-m" 'hexl-self-insert-command)
+ (define-key hexl-mode-map "\C-n" 'hexl-next-line)
+ (define-key hexl-mode-map "\C-o" 'undefined)
+ (define-key hexl-mode-map "\C-p" 'hexl-previous-line)
+ (define-key hexl-mode-map "\C-q" 'hexl-quoted-insert)
+ (define-key hexl-mode-map "\C-t" 'undefined)
+ (define-key hexl-mode-map "\C-v" 'hexl-scroll-up)
+ (define-key hexl-mode-map "\C-w" 'undefined)
+ (define-key hexl-mode-map "\C-y" 'undefined)
+
+ (let ((ch 32))
+ (while (< ch 127)
+ (define-key hexl-mode-map (format "%c" ch) 'hexl-self-insert-command)
+ (setq ch (1+ ch))))
+
+ (define-key hexl-mode-map "\e\C-a" 'hexl-beginning-of-512b-page)
+ (define-key hexl-mode-map "\e\C-b" 'hexl-backward-short)
+ (define-key hexl-mode-map "\e\C-c" 'undefined)
+ (define-key hexl-mode-map "\e\C-d" 'hexl-insert-decimal-char)
+ (define-key hexl-mode-map "\e\C-e" 'hexl-end-of-512b-page)
+ (define-key hexl-mode-map "\e\C-f" 'hexl-forward-short)
+ (define-key hexl-mode-map "\e\C-g" 'undefined)
+ (define-key hexl-mode-map "\e\C-h" 'undefined)
+ (define-key hexl-mode-map "\e\C-i" 'undefined)
+ (define-key hexl-mode-map "\e\C-j" 'undefined)
+ (define-key hexl-mode-map "\e\C-k" 'undefined)
+ (define-key hexl-mode-map "\e\C-l" 'undefined)
+ (define-key hexl-mode-map "\e\C-m" 'undefined)
+ (define-key hexl-mode-map "\e\C-n" 'undefined)
+ (define-key hexl-mode-map "\e\C-o" 'hexl-insert-octal-char)
+ (define-key hexl-mode-map "\e\C-p" 'undefined)
+ (define-key hexl-mode-map "\e\C-q" 'undefined)
+ (define-key hexl-mode-map "\e\C-r" 'undefined)
+ (define-key hexl-mode-map "\e\C-s" 'undefined)
+ (define-key hexl-mode-map "\e\C-t" 'undefined)
+ (define-key hexl-mode-map "\e\C-u" 'undefined)
+
+ (define-key hexl-mode-map "\e\C-w" 'undefined)
+ (define-key hexl-mode-map "\e\C-x" 'hexl-insert-hex-char)
+ (define-key hexl-mode-map "\e\C-y" 'undefined)
+
+
+ (define-key hexl-mode-map "\ea" 'hexl-beginning-of-1k-page)
+ (define-key hexl-mode-map "\eb" 'hexl-backward-word)
+ (define-key hexl-mode-map "\ec" 'undefined)
+ (define-key hexl-mode-map "\ed" 'undefined)
+ (define-key hexl-mode-map "\ee" 'hexl-end-of-1k-page)
+ (define-key hexl-mode-map "\ef" 'hexl-forward-word)
+ (define-key hexl-mode-map "\eg" 'hexl-goto-hex-address)
+ (define-key hexl-mode-map "\eh" 'undefined)
+ (define-key hexl-mode-map "\ei" 'undefined)
+ (define-key hexl-mode-map "\ej" 'hexl-goto-address)
+ (define-key hexl-mode-map "\ek" 'undefined)
+ (define-key hexl-mode-map "\el" 'undefined)
+ (define-key hexl-mode-map "\em" 'undefined)
+ (define-key hexl-mode-map "\en" 'undefined)
+ (define-key hexl-mode-map "\eo" 'undefined)
+ (define-key hexl-mode-map "\ep" 'undefined)
+ (define-key hexl-mode-map "\eq" 'undefined)
+ (define-key hexl-mode-map "\er" 'undefined)
+ (define-key hexl-mode-map "\es" 'undefined)
+ (define-key hexl-mode-map "\et" 'undefined)
+ (define-key hexl-mode-map "\eu" 'undefined)
+ (define-key hexl-mode-map "\ev" 'hexl-scroll-down)
+ (define-key hexl-mode-map "\ey" 'undefined)
+ (define-key hexl-mode-map "\ez" 'undefined)
+ (define-key hexl-mode-map "\e<" 'hexl-beginning-of-buffer)
+ (define-key hexl-mode-map "\e>" 'hexl-end-of-buffer)
+
+ (define-key hexl-mode-map "\C-c\C-c" 'hexl-mode-exit)
+
+ (define-key hexl-mode-map "\C-x\C-p" 'undefined)
+ (define-key hexl-mode-map "\C-x\C-s" 'hexl-save-buffer)
+ (define-key hexl-mode-map "\C-x\C-t" 'undefined))
+
+;; The End.
--- /dev/null
+;; Emacs side of ledit interface
+;; Copyright (C) 1985 Free Software Foundation, Inc.
+
+;; 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+
+;;; To do:
+;;; o lisp -> emacs side of things (grind-definition and find-definition)
+
+(defvar ledit-mode-map nil)
+
+(defconst ledit-zap-file (concat "/tmp/" (user-login-name) ".l1")
+ "File name for data sent to Lisp by Ledit.")
+(defconst ledit-read-file (concat "/tmp/" (user-login-name) ".l2")
+ "File name for data sent to Ledit by Lisp.")
+(defconst ledit-compile-file
+ (concat "/tmp/" (user-login-name) ".l4")
+ "File name for data sent to Lisp compiler by Ledit.")
+(defconst ledit-buffer "*LEDIT*"
+ "Name of buffer in which Ledit accumulates data to send to Lisp.")
+;These are now in loaddefs.el
+;(defconst ledit-save-files t
+; "*Non-nil means Ledit should save files before transferring to Lisp.")
+;(defconst ledit-go-to-lisp-string "%?lisp"
+; "*Shell commands to execute to resume Lisp job.")
+;(defconst ledit-go-to-liszt-string "%?liszt"
+; "*Shell commands to execute to resume Lisp compiler job.")
+
+(defun ledit-save-defun ()
+ "Save the current defun in the ledit buffer"
+ (interactive)
+ (save-excursion
+ (end-of-defun)
+ (let ((end (point)))
+ (beginning-of-defun)
+ (append-to-buffer ledit-buffer (point) end))
+ (message "Current defun saved for Lisp")))
+
+(defun ledit-save-region (beg end)
+ "Save the current region in the ledit buffer"
+ (interactive "r")
+ (append-to-buffer ledit-buffer beg end)
+ (message "Region saved for Lisp"))
+
+(defun ledit-zap-defun-to-lisp ()
+ "Carry the current defun to lisp"
+ (interactive)
+ (ledit-save-defun)
+ (ledit-go-to-lisp))
+
+(defun ledit-zap-defun-to-liszt ()
+ "Carry the current defun to liszt"
+ (interactive)
+ (ledit-save-defun)
+ (ledit-go-to-liszt))
+
+(defun ledit-zap-region-to-lisp (beg end)
+ "Carry the current region to lisp"
+ (interactive "r")
+ (ledit-save-region beg end)
+ (ledit-go-to-lisp))
+
+(defun ledit-go-to-lisp ()
+ "Suspend Emacs and restart a waiting Lisp job."
+ (interactive)
+ (if ledit-save-files
+ (save-some-buffers))
+ (if (get-buffer ledit-buffer)
+ (save-excursion
+ (set-buffer ledit-buffer)
+ (goto-char (point-min))
+ (write-region (point-min) (point-max) ledit-zap-file)
+ (erase-buffer)))
+ (suspend-emacs ledit-go-to-lisp-string)
+ (load ledit-read-file t t))
+
+(defun ledit-go-to-liszt ()
+ "Suspend Emacs and restart a waiting Liszt job."
+ (interactive)
+ (if ledit-save-files
+ (save-some-buffers))
+ (if (get-buffer ledit-buffer)
+ (save-excursion
+ (set-buffer ledit-buffer)
+ (goto-char (point-min))
+ (insert "(declare (macros t))\n")
+ (write-region (point-min) (point-max) ledit-compile-file)
+ (erase-buffer)))
+ (suspend-emacs ledit-go-to-liszt-string)
+ (load ledit-read-file t t))
+
+(defun ledit-setup ()
+ "Set up key bindings for the Lisp / Emacs interface"
+ (if (not ledit-mode-map)
+ (progn (setq ledit-mode-map (make-sparse-keymap))
+ (lisp-mode-commands ledit-mode-map)))
+ (define-key ledit-mode-map "\e\^d" 'ledit-save-defun)
+ (define-key ledit-mode-map "\e\^r" 'ledit-save-region)
+ (define-key ledit-mode-map "\^xz" 'ledit-go-to-lisp)
+ (define-key ledit-mode-map "\e\^c" 'ledit-go-to-liszt))
+
+(ledit-setup)
+
+(defun ledit-mode ()
+ "Major mode for editing text and stuffing it to a Lisp job.
+Like Lisp mode, plus these special commands:
+ M-C-d -- record defun at or after point
+ for later transmission to Lisp job.
+ M-C-r -- record region for later transmission to Lisp job.
+ C-x z -- transfer to Lisp job and transmit saved text.
+ M-C-c -- transfer to Liszt (Lisp compiler) job
+ and transmit saved text.
+\\{ledit-mode-map}
+To make Lisp mode automatically change to Ledit mode,
+do (setq lisp-mode-hook 'ledit-from-lisp-mode)"
+ (interactive)
+ (lisp-mode)
+ (ledit-from-lisp-mode))
+
+(defun ledit-from-lisp-mode ()
+ (use-local-map ledit-mode-map)
+ (setq mode-name "Ledit")
+ (setq major-mode 'ledit-mode)
+ (run-hooks 'ledit-mode-hook))
--- /dev/null
+;; Non-primitive commands for keyboard macros.
+;; Copyright (C) 1985, 1986, 1987 Free Software Foundation, Inc.
+
+;; 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+
+(defun name-last-kbd-macro (symbol)
+ "Assign a name to the last keyboard macro defined.
+One arg, a symbol, which is the name to define.
+The symbol's function definition becomes the keyboard macro string.
+Such a \"function\" cannot be called from Lisp, but it is a valid command
+definition for the editor command loop."
+ (interactive "SName for last kbd macro: ")
+ (or last-kbd-macro
+ (error "No keyboard macro defined"))
+ (and (fboundp symbol)
+ (not (stringp (symbol-function symbol)))
+ (error "Function %s is already defined and not a keyboard macro."
+ symbol))
+ (fset symbol last-kbd-macro))
+
+(defun insert-kbd-macro (macroname &optional keys)
+ "Insert in buffer the definition of kbd macro NAME, as Lisp code.
+Second argument KEYS non-nil means also record the keys it is on.
+ (This is the prefix argument, when calling interactively.)
+
+This Lisp code will, when executed, define the kbd macro with the
+same definition it has now. If you say to record the keys,
+the Lisp code will also rebind those keys to the macro.
+Only global key bindings are recorded since executing this Lisp code
+always makes global bindings.
+
+To save a kbd macro, visit a file of Lisp code such as your ~/.emacs,
+use this command, and then save the file."
+ (interactive "CInsert kbd macro (name): \nP")
+ (insert "(fset '")
+ (prin1 macroname (current-buffer))
+ (insert "\n ")
+ (prin1 (symbol-function macroname) (current-buffer))
+ (insert ")\n")
+ (if keys
+ (let ((keys (where-is-internal macroname nil)))
+ (while keys
+ (insert "(global-set-key ")
+ (prin1 (car keys) (current-buffer))
+ (insert " '")
+ (prin1 macroname (current-buffer))
+ (insert ")\n")
+ (setq keys (cdr keys))))))
+
+(defun kbd-macro-query (flag)
+ "Query user during kbd macro execution.
+With prefix argument, enters recursive edit,
+ reading keyboard commands even within a kbd macro.
+ You can give different commands each time the macro executes.
+Without prefix argument, reads a character. Your options are:
+ Space -- execute the rest of the macro.
+ DEL -- skip the rest of the macro; start next repetition.
+ C-d -- skip rest of the macro and don't repeat it any more.
+ C-r -- enter a recursive edit, then on exit ask again for a character
+ C-l -- redisplay screen and ask again."
+ (interactive "P")
+ (or executing-macro
+ defining-kbd-macro
+ (error "Not defining or executing kbd macro"))
+ (if flag
+ (let (executing-macro defining-kbd-macro)
+ (recursive-edit))
+ (if (not executing-macro)
+ nil
+ (let ((loop t))
+ (while loop
+ (let ((char (let ((executing-macro nil)
+ (defining-kbd-macro nil))
+ (message "Proceed with macro? (Space, DEL, C-d, C-r or C-l) ")
+ (read-char))))
+ (cond ((= char ? )
+ (setq loop nil))
+ ((= char ?\177)
+ (setq loop nil)
+ (setq executing-macro ""))
+ ((= char ?\C-d)
+ (setq loop nil)
+ (setq executing-macro t))
+ ((= char ?\C-l)
+ (recenter nil))
+ ((= char ?\C-r)
+ (let (executing-macro defining-kbd-macro)
+ (recursive-edit))))))))))
--- /dev/null
+;; Command to report Emacs bugs to appropriate mailing list.
+;; Not fully installed because it can work only on Internet hosts.
+;; Copyright (C) 1985 Free Software Foundation, Inc.
+;; Principal author K. Shane Hartman
+
+;; 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+
+;; >> This should be an address which is accessible to your machine,
+;; >> otherwise you can't use this file. It will only work on the
+;; >> internet with this address.
+
+(defvar bug-gnu-emacs "bug-gnu-emacs@prep.ai.mit.edu"
+ "Address of site maintaining mailing list for Gnu emacs bugs.")
+
+(defun report-emacs-bug (topic)
+ "Report a bug in Gnu emacs.
+Prompts for bug subject. Leaves you in a mail buffer."
+ (interactive "sBug Subject: ")
+ (mail nil bug-gnu-emacs topic)
+ (goto-char (point-max))
+ (insert "\nIn " (emacs-version) "\n\n")
+ (message (substitute-command-keys "Type \\[mail-send] to send bug report.")))
+
--- /dev/null
+;; Utility functions used both by rmail and rnews
+;; Copyright (C) 1985 Free Software Foundation, Inc.
+
+;; 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+
+(provide 'mail-utils)
+
+;; should be in loaddefs
+(defvar mail-use-rfc822 nil
+ "*If non-nil, use a full, hairy RFC822 parser on mail addresses.
+Otherwise, (the default) use a smaller, somewhat faster and
+often-correct parser.")
+
+(defun mail-string-delete (string start end)
+ "Returns a string containing all of STRING except the part
+from START (inclusive) to END (exclusive)."
+ (if (null end) (substring string 0 start)
+ (concat (substring string 0 start)
+ (substring string end nil))))
+
+(defun mail-strip-quoted-names (address)
+ "Delete comments and quoted strings in an address list ADDRESS.
+Also delete leading/trailing whitespace and replace FOO <BAR> with just BAR.
+Return a modified address list."
+ (if mail-use-rfc822
+ (progn (require 'rfc822)
+ (mapconcat 'identity (rfc822-addresses address) ", "))
+ (let (pos)
+ (string-match "\\`[ \t\n]*" address)
+ ;; strip surrounding whitespace
+ (setq address (substring address
+ (match-end 0)
+ (string-match "[ \t\n]*\\'" address
+ (match-end 0))))
+
+ ;; Detect nested comments.
+ (if (string-match "[ \t]*(\\([^)\"\\]\\|\\\\.\\|\\\\\n\\)*(" address)
+ ;; Strip nested comments.
+ (save-excursion
+ (set-buffer (get-buffer-create " *temp*"))
+ (erase-buffer)
+ (insert address)
+ (set-syntax-table lisp-mode-syntax-table)
+ (goto-char 1)
+ (while (search-forward "(" nil t)
+ (forward-char -1)
+ (skip-chars-backward " \t")
+ (delete-region (point)
+ (save-excursion (forward-sexp 1) (point))))
+ (setq address (buffer-string))
+ (erase-buffer))
+ ;; Strip non-nested comments an easier way.
+ (while (setq pos (string-match
+ ;; This doesn't hack rfc822 nested comments
+ ;; `(xyzzy (foo) whinge)' properly. Big deal.
+ "[ \t]*(\\([^)\"\\]\\|\\\\.\\|\\\\\n\\)*)"
+ address))
+ (setq address
+ (mail-string-delete address
+ pos (match-end 0)))))
+
+ ;; strip `quoted' names (This is supposed to hack `"Foo Bar" <bar@host>')
+ (setq pos 0)
+ (while (setq pos (string-match
+ "[ \t]*\"\\([^\"\\]\\|\\\\.\\|\\\\\n\\)*\"[ \t\n]*"
+ address pos))
+ ;; If the next thing is "@", we have "foo bar"@host. Leave it.
+ (if (and (> (length address) (match-end 0))
+ (= (aref address (match-end 0)) ?@))
+ (setq pos (match-end 0))
+ (setq address
+ (mail-string-delete address
+ pos (match-end 0)))))
+ ;; Retain only part of address in <> delims, if there is such a thing.
+ (while (setq pos (string-match "\\(,\\|\\`\\)[^,]*<\\([^>,]*>\\)"
+ address))
+ (let ((junk-beg (match-end 1))
+ (junk-end (match-beginning 2))
+ (close (match-end 0)))
+ (setq address (mail-string-delete address (1- close) close))
+ (setq address (mail-string-delete address junk-beg junk-end))))
+ address)))
+
+(or (and (boundp 'rmail-default-dont-reply-to-names)
+ (not (null rmail-default-dont-reply-to-names)))
+ (setq rmail-default-dont-reply-to-names "info-"))
+
+; rmail-dont-reply-to-names is defined in loaddefs
+(defun rmail-dont-reply-to (userids)
+ "Returns string of mail addresses USERIDS sans any recipients
+that start with matches for rmail-dont-reply-to-names.
+Usenet paths ending in an element that matches are removed also."
+ (if (null rmail-dont-reply-to-names)
+ (setq rmail-dont-reply-to-names
+ (concat (if rmail-default-dont-reply-to-names
+ (concat rmail-default-dont-reply-to-names "\\|")
+ "")
+ (concat (regexp-quote (user-original-login-name))
+ "\\>"))))
+ (let ((match (concat "\\(^\\|,\\)[ \t\n]*\\([^,\n]*!\\|\\)\\("
+ rmail-dont-reply-to-names
+ "\\)"))
+ (case-fold-search t)
+ pos epos)
+ (while (setq pos (string-match match userids))
+ (if (> pos 0) (setq pos (1+ pos)))
+ (setq epos
+ (if (string-match "[ \t\n,]+" userids (match-end 0))
+ (match-end 0)
+ (length userids)))
+ (setq userids
+ (mail-string-delete
+ userids pos epos)))
+ ;; get rid of any trailing commas
+ (if (setq pos (string-match "[ ,\t\n]*\\'" userids))
+ (setq userids (substring userids 0 pos)))
+ ;; remove leading spaces. they bother me.
+ (if (string-match "\\s *" userids)
+ (substring userids (match-end 0))
+ userids)))
+\f
+(defun mail-fetch-field (field-name &optional last all)
+ "Return the value of the header field FIELD.
+The buffer is expected to be narrowed to just the headers of the message.
+If 2nd arg LAST is non-nil, use the last such field if there are several.
+If 3rd arg ALL is non-nil, concatenate all such fields, with commas between."
+ (save-excursion
+ (goto-char (point-min))
+ (let ((case-fold-search t)
+ (name (concat "^" (regexp-quote field-name) "[ \t]*:[ \t]*")))
+ (goto-char (point-min))
+ (if all
+ (let ((value ""))
+ (while (re-search-forward name nil t)
+ (let ((opoint (point)))
+ (while (progn (forward-line 1)
+ (looking-at "[ \t]")))
+ (setq value (concat value
+ (if (string= value "") "" ", ")
+ (buffer-substring opoint (1- (point)))))))
+ (and (not (string= value "")) value))
+ (if (re-search-forward name nil t)
+ (progn
+ (if last (while (re-search-forward name nil t)))
+ (let ((opoint (point)))
+ (while (progn (forward-line 1)
+ (looking-at "[ \t]")))
+ (buffer-substring opoint (1- (point))))))))))
+\f
+;; Parse a list of tokens separated by commas.
+;; It runs from point to the end of the visible part of the buffer.
+;; Whitespace before or after tokens is ignored,
+;; but whitespace within tokens is kept.
+(defun mail-parse-comma-list ()
+ (let (accumulated
+ beg)
+ (skip-chars-forward " ")
+ (while (not (eobp))
+ (setq beg (point))
+ (skip-chars-forward "^,")
+ (skip-chars-backward " ")
+ (setq accumulated
+ (cons (buffer-substring beg (point))
+ accumulated))
+ (skip-chars-forward "^,")
+ (skip-chars-forward ", "))
+ accumulated))
+
+(defun mail-comma-list-regexp (labels)
+ (let (pos)
+ (setq pos (or (string-match "[^ \t]" labels) 0))
+ ;; Remove leading and trailing whitespace.
+ (setq labels (substring labels pos (string-match "[ \t]*$" labels pos)))
+ ;; Change each comma to \|, and flush surrounding whitespace.
+ (while (setq pos (string-match "[ \t]*,[ \t]*" labels))
+ (setq labels
+ (concat (substring labels 0 pos)
+ "\\|"
+ (substring labels (match-end 0))))))
+ labels)
--- /dev/null
+;; "RMAIL edit mode" Edit the current message.
+;; Copyright (C) 1985 Free Software Foundation, Inc.
+
+;; 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+
+(require 'rmail)
+
+(defvar rmail-edit-map nil)
+(if rmail-edit-map
+ nil
+ (setq rmail-edit-map (nconc (make-sparse-keymap) text-mode-map))
+ (define-key rmail-edit-map "\C-c\C-c" 'rmail-cease-edit)
+ (define-key rmail-edit-map "\C-c\C-]" 'rmail-abort-edit))
+
+;; Rmail Edit mode is suitable only for specially formatted data.
+(put 'rmail-edit-mode 'mode-class 'special)
+
+(defun rmail-edit-mode ()
+ "Major mode for editing the contents of an RMAIL message.
+The editing commands are the same as in Text mode, together with two commands
+to return to regular RMAIL:
+ * rmail-abort-edit cancels the changes
+ you have made and returns to RMAIL
+ * rmail-cease-edit makes them permanent.
+\\{rmail-edit-map}"
+ (use-local-map rmail-edit-map)
+ (setq major-mode 'rmail-edit-mode)
+ (setq mode-name "RMAIL Edit")
+ (if (boundp 'mode-line-modified)
+ (setq mode-line-modified (default-value 'mode-line-modified))
+ (setq mode-line-format (default-value 'mode-line-format)))
+ (run-hooks 'text-mode-hook 'rmail-edit-mode-hook))
+
+(defun rmail-edit-current-message ()
+ "Edit the contents of this message."
+ (interactive)
+ (rmail-edit-mode)
+ (make-local-variable 'rmail-old-text)
+ (setq rmail-old-text (buffer-substring (point-min) (point-max)))
+ (setq buffer-read-only nil)
+ (set-buffer-modified-p (buffer-modified-p))
+ ;; Make mode line update.
+ (if (and (eq (key-binding "\C-c\C-c") 'rmail-cease-edit)
+ (eq (key-binding "\C-c\C-]") 'rmail-abort-edit))
+ (message "Editing: Type C-c C-c to return to Rmail, C-c C-] to abort")
+ (message (substitute-command-keys
+ "Editing: Type \\[rmail-cease-edit] to return to Rmail, \\[rmail-abort-edit] to abort"))))
+
+(defun rmail-cease-edit ()
+ "Finish editing message; switch back to Rmail proper."
+ (interactive)
+ ;; Make sure buffer ends with a newline.
+ (save-excursion
+ (goto-char (point-max))
+ (if (/= (preceding-char) ?\n)
+ (insert "\n"))
+ ;; Adjust the marker that points to the end of this message.
+ (set-marker (aref rmail-message-vector (1+ rmail-current-message))
+ (point)))
+ (let ((old rmail-old-text))
+ ;; Update the mode line.
+ (set-buffer-modified-p (buffer-modified-p))
+ (rmail-mode-1)
+ (if (and (= (length old) (- (point-max) (point-min)))
+ (string= old (buffer-substring (point-min) (point-max))))
+ ()
+ (setq old nil)
+ (rmail-set-attribute "edited" t)
+ (if (boundp 'rmail-summary-vector)
+ (progn
+ (aset rmail-summary-vector (1- rmail-current-message) nil)
+ (save-excursion
+ (rmail-widen-to-current-msgbeg
+ (function (lambda ()
+ (forward-line 2)
+ (if (looking-at "Summary-line: ")
+ (let ((buffer-read-only nil))
+ (delete-region (point)
+ (progn (forward-line 1)
+ (point))))))))
+ (rmail-show-message))))))
+ (setq buffer-read-only t))
+
+(defun rmail-abort-edit ()
+ "Abort edit of current message; restore original contents."
+ (interactive)
+ (delete-region (point-min) (point-max))
+ (insert rmail-old-text)
+ (rmail-cease-edit))
+
--- /dev/null
+;; "RMAIL" mail reader for Emacs.
+;; Copyright (C) 1985, 1988 Free Software Foundation, Inc.
+
+;; 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+
+;; Global to all RMAIL buffers. It exists primarily for the sake of
+;; completion. It is better to use strings with the label functions
+;; and let them worry about making the label.
+
+(defvar rmail-label-obarray (make-vector 47 0))
+
+;; Named list of symbols representing valid message attributes in RMAIL.
+
+(defconst rmail-attributes
+ (cons 'rmail-keywords
+ (mapcar '(lambda (s) (intern s rmail-label-obarray))
+ '("deleted" "answered" "filed" "forwarded" "unseen" "edited"))))
+
+(defconst rmail-deleted-label (intern "deleted" rmail-label-obarray))
+
+;; Named list of symbols representing valid message keywords in RMAIL.
+
+(defvar rmail-keywords nil)
+\f
+(defun rmail-add-label (string)
+ "Add LABEL to labels associated with current RMAIL message.
+Completion is performed over known labels when reading."
+ (interactive (list (rmail-read-label "Add label")))
+ (rmail-set-label string t))
+
+(defun rmail-kill-label (string)
+ "Remove LABEL from labels associated with current RMAIL message.
+Completion is performed over known labels when reading."
+ (interactive (list (rmail-read-label "Remove label")))
+ (rmail-set-label string nil))
+
+(defun rmail-read-label (prompt)
+ (if (not rmail-keywords) (rmail-parse-file-keywords))
+ (let ((result
+ (completing-read (concat prompt
+ (if rmail-last-label
+ (concat " (default "
+ (symbol-name rmail-last-label)
+ "): ")
+ ": "))
+ rmail-label-obarray
+ nil
+ nil)))
+ (if (string= result "")
+ rmail-last-label
+ (setq rmail-last-label (rmail-make-label result t)))))
+
+(defun rmail-set-label (l state &optional n)
+ (rmail-maybe-set-message-counters)
+ (if (not n) (setq n rmail-current-message))
+ (aset rmail-summary-vector (1- n) nil)
+ (let* ((attribute (rmail-attribute-p l))
+ (keyword (and (not attribute)
+ (or (rmail-keyword-p l)
+ (rmail-install-keyword l))))
+ (label (or attribute keyword)))
+ (if label
+ (let ((omax (- (buffer-size) (point-max)))
+ (omin (- (buffer-size) (point-min)))
+ (buffer-read-only nil)
+ (case-fold-search t))
+ (unwind-protect
+ (save-excursion
+ (widen)
+ (goto-char (rmail-msgbeg n))
+ (forward-line 1)
+ (if (not (looking-at "[01],"))
+ nil
+ (let ((start (1+ (point)))
+ (bound))
+ (narrow-to-region (point) (progn (end-of-line) (point)))
+ (setq bound (point-max))
+ (search-backward ",," nil t)
+ (if attribute
+ (setq bound (1+ (point)))
+ (setq start (1+ (point))))
+ (goto-char start)
+; (while (re-search-forward "[ \t]*,[ \t]*" nil t)
+; (replace-match ","))
+; (goto-char start)
+ (if (re-search-forward
+ (concat ", " (rmail-quote-label-name label) ",")
+ bound
+ 'move)
+ (if (not state) (replace-match ","))
+ (if state (insert " " (symbol-name label) ",")))
+ (if (eq label rmail-deleted-label)
+ (rmail-set-message-deleted-p n state)))))
+ (narrow-to-region (- (buffer-size) omin) (- (buffer-size) omax))
+ (if (= n rmail-current-message) (rmail-display-labels)))))))
+\f
+;; Commented functions aren't used by RMAIL but might be nice for user
+;; packages that do stuff with RMAIL. Note that rmail-message-labels-p
+;; is in rmailsum now.
+
+;(defun rmail-message-attribute-p (attribute &optional n)
+; "Returns t if ATTRIBUTE on NTH or current message."
+; (rmail-message-labels-p (rmail-make-label attribute t) n))
+
+;(defun rmail-message-keyword-p (keyword &optional n)
+; "Returns t if KEYWORD on NTH or current message."
+; (rmail-message-labels-p (rmail-make-label keyword t) n t))
+
+;(defun rmail-message-label-p (label &optional n)
+; "Returns symbol if LABEL (attribute or keyword) on NTH or current message."
+; (rmail-message-labels-p (rmail-make-label label t) n 'all))
+
+;; Not used by RMAIL but might be nice for user package.
+
+;(defun rmail-parse-message-labels (&optional n)
+; "Returns labels associated with NTH or current RMAIL message.
+;Results is a list of two lists. The first is the message attributes
+;and the second is the message keywords. Labels are represented as symbols."
+; (let ((omin (- (buffer-size) (point-min)))
+; (omax (- (buffer-size) (point-max)))
+; (result))
+; (unwind-protect
+; (save-excursion
+; (let ((beg (rmail-msgbeg (or n rmail-current-message))))
+; (widen)
+; (goto-char beg)
+; (forward-line 1)
+; (if (looking-at "[01],")
+; (save-restriction
+; (narrow-to-region (point) (save-excursion (end-of-line) (point)))
+; (rmail-nuke-whitespace)
+; (goto-char (1+ (point-min)))
+; (list (mail-parse-comma-list) (mail-parse-comma-list))))))
+; (narrow-to-region (- (buffer-size) omin)
+; (- (buffer-size) omax))
+; nil)))
+
+(defun rmail-attribute-p (s)
+ (let ((symbol (rmail-make-label s)))
+ (if (memq symbol (cdr rmail-attributes)) symbol)))
+
+(defun rmail-keyword-p (s)
+ (let ((symbol (rmail-make-label s)))
+ (if (memq symbol (cdr (rmail-keywords))) symbol)))
+
+(defun rmail-make-label (s &optional forcep)
+ (cond ((symbolp s) s)
+ (forcep (intern (downcase s) rmail-label-obarray))
+ (t (intern-soft (downcase s) rmail-label-obarray))))
+
+(defun rmail-force-make-label (s)
+ (intern (downcase s) rmail-label-obarray))
+
+(defun rmail-quote-label-name (label)
+ (regexp-quote (symbol-name (rmail-make-label label t))))
+\f
+;; Motion on messages with keywords.
+
+(defun rmail-previous-labeled-message (n label)
+ "Show previous message with LABEL. Defaults to last labels used.
+With prefix argument N moves backward N messages with these labels."
+ (interactive "p\nsMove to previous msg with labels: ")
+ (rmail-next-labeled-message (- n) label))
+
+(defun rmail-next-labeled-message (n labels)
+ "Show next message with LABEL. Defaults to last labels used.
+With prefix argument N moves forward N messages with these labels."
+ (interactive "p\nsMove to next msg with labels: ")
+ (if (string= labels "")
+ (setq labels rmail-last-multi-labels))
+ (or labels
+ (error "No labels to find have been specified previously"))
+ (setq rmail-last-multi-labels labels)
+ (rmail-maybe-set-message-counters)
+ (let ((lastwin rmail-current-message)
+ (current rmail-current-message)
+ (regexp (concat ", ?\\("
+ (mail-comma-list-regexp labels)
+ "\\),")))
+ (save-restriction
+ (widen)
+ (while (and (> n 0) (< current rmail-total-messages))
+ (setq current (1+ current))
+ (if (rmail-message-labels-p current regexp)
+ (setq lastwin current n (1- n))))
+ (while (and (< n 0) (> current 1))
+ (setq current (1- current))
+ (if (rmail-message-labels-p current regexp)
+ (setq lastwin current n (1+ n)))))
+ (rmail-show-message lastwin)
+ (if (< n 0)
+ (message "No previous message with labels %s" labels))
+ (if (> n 0)
+ (message "No following message with labels %s" labels))))
+\f
+;;; Manipulate the file's Labels option.
+
+;; Return a list of symbols for all
+;; the keywords (labels) recorded in this file's Labels option.
+(defun rmail-keywords ()
+ (or rmail-keywords (rmail-parse-file-keywords)))
+
+;; Set rmail-keywords to a list of symbols for all
+;; the keywords (labels) recorded in this file's Labels option.
+(defun rmail-parse-file-keywords ()
+ (save-restriction
+ (save-excursion
+ (widen)
+ (goto-char 1)
+ (setq rmail-keywords
+ (if (search-forward "\nLabels:" (rmail-msgbeg 1) t)
+ (progn
+ (narrow-to-region (point) (progn (end-of-line) (point)))
+ (goto-char (point-min))
+ (cons 'rmail-keywords
+ (mapcar 'rmail-force-make-label
+ (mail-parse-comma-list)))))))))
+
+;; Add WORD to the list in the file's Labels option.
+;; Any keyword used for the first time needs this done.
+(defun rmail-install-keyword (word)
+ (let ((keyword (rmail-make-label word t))
+ (keywords (rmail-keywords)))
+ (if (not (or (rmail-attribute-p keyword)
+ (rmail-keyword-p keyword)))
+ (let ((omin (- (buffer-size) (point-min)))
+ (omax (- (buffer-size) (point-max))))
+ (unwind-protect
+ (save-excursion
+ (widen)
+ (goto-char 1)
+ (let ((case-fold-search t)
+ (buffer-read-only nil))
+ (or (search-forward "\nLabels:" nil t)
+ (progn
+ (end-of-line)
+ (insert "\nLabels:")))
+ (delete-region (point) (progn (end-of-line) (point)))
+ (setcdr keywords (cons keyword (cdr keywords)))
+ (while (setq keywords (cdr keywords))
+ (insert (symbol-name (car keywords)) ","))
+ (delete-char -1)))
+ (narrow-to-region (- (buffer-size) omin)
+ (- (buffer-size) omax)))))
+ keyword))
--- /dev/null
+;; Generate key binding summary for Emacs
+;; Copyright (C) 1985 Free Software Foundation, Inc.
+
+;; 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+
+(defun make-command-summary ()
+ "Make a summary of current key bindings in the buffer *Summary*.
+Previous contents of that buffer are killed first."
+ (interactive)
+ (message "Making command summary...")
+ ;; This puts a description of bindings in a buffer called *Help*.
+ (save-window-excursion
+ (describe-bindings))
+ (with-output-to-temp-buffer "*Summary*"
+ (save-excursion
+ (let ((cur-mode mode-name))
+ (set-buffer standard-output)
+ (erase-buffer)
+ (insert-buffer-substring "*Help*")
+ (goto-char (point-min))
+ (delete-region (point) (progn (forward-line 1) (point)))
+ (while (search-forward " " nil t)
+ (replace-match " "))
+ (goto-char (point-min))
+ (while (search-forward "-@ " nil t)
+ (replace-match "-SP"))
+ (goto-char (point-min))
+ (while (search-forward " .. ~ " nil t)
+ (replace-match "SP .. ~"))
+ (goto-char (point-min))
+ (while (search-forward "C-?" nil t)
+ (replace-match "DEL"))
+ (goto-char (point-min))
+ (while (search-forward "C-i" nil t)
+ (replace-match "TAB"))
+ (goto-char (point-min))
+ (if (re-search-forward "^Local Bindings:" nil t)
+ (progn
+ (forward-char -1)
+ (insert " for " cur-mode " Mode")
+ (while (search-forward "??\n" nil t)
+ (delete-region (point)
+ (progn
+ (forward-line -1)
+ (point))))))
+ (goto-char (point-min))
+ (insert "Emacs command summary, " (substring (current-time-string) 0 10)
+ ".\n")
+ ;; Delete "key binding" and underlining of dashes.
+ (delete-region (point) (progn (forward-line 2) (point)))
+ (forward-line 1) ;Skip blank line
+ (while (not (eobp))
+ (let ((beg (point)))
+ (or (re-search-forward "^$" nil t)
+ (goto-char (point-max)))
+ (double-column beg (point))
+ (forward-line 1)))
+ (goto-char (point-min)))))
+ (message "Making command summary...done"))
+
+(defun double-column (start end)
+ (interactive "r")
+ (let (half cnt
+ line lines nlines
+ (from-end (- (point-max) end)))
+ (setq nlines (count-lines start end))
+ (if (<= nlines 1)
+ nil
+ (setq half (/ (1+ nlines) 2))
+ (goto-char start)
+ (save-excursion
+ (forward-line half)
+ (while (< half nlines)
+ (setq half (1+ half))
+ (setq line (buffer-substring (point) (save-excursion (end-of-line) (point))))
+ (setq lines (cons line lines))
+ (delete-region (point) (progn (forward-line 1) (point)))))
+ (setq lines (nreverse lines))
+ (while lines
+ (end-of-line)
+ (indent-to 41)
+ (insert (car lines))
+ (forward-line 1)
+ (setq lines (cdr lines))))
+ (goto-char (- (point-max) from-end))))
--- /dev/null
+;; Handling of disabled commands ("novice mode") for Emacs.
+;; Copyright (C) 1985, 1986, 1987 Free Software Foundation, Inc.
+
+;; 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+
+;; This function is called (by autoloading)
+;; to handle any disabled command.
+;; The command is found in this-command
+;; and the keys are returned by (this-command-keys).
+
+(defun disabled-command-hook (&rest ignore)
+ (let (char)
+ (save-window-excursion
+ (with-output-to-temp-buffer "*Help*"
+ (if (= (aref (this-command-keys) 0) ?\M-x)
+ (princ "You have invoked the disabled command ")
+ (princ "You have typed ")
+ (princ (key-description (this-command-keys)))
+ (princ ", invoking disabled command "))
+ (princ this-command)
+ (princ ":\n")
+ ;; Print any special message saying why the command is disabled.
+ (if (stringp (get this-command 'disabled))
+ (princ (get this-command 'disabled)))
+ (princ (or (condition-case ()
+ (documentation this-command)
+ (error nil))
+ "<< not documented >>"))
+ ;; Keep only the first paragraph of the documentation.
+ (save-excursion
+ (set-buffer "*Help*")
+ (goto-char (point-min))
+ (if (search-forward "\n\n" nil t)
+ (delete-region (1- (point)) (point-max))
+ (goto-char (point-max))))
+ (princ "\n\n")
+ (princ "You can now type
+Space to try the command just this once,
+ but leave it disabled,
+Y to try it and enable it (no questions if you use it again),
+N to do nothing (command remains disabled)."))
+ (message "Type y, n or Space: ")
+ (let ((cursor-in-echo-area t))
+ (while (not (memq (setq char (downcase (read-char)))
+ '(? ?y ?n)))
+ (ding)
+ (message "Please type y, n or Space: "))))
+ (if (= char ?y)
+ (if (y-or-n-p "Enable command for future editing sessions also? ")
+ (enable-command this-command)
+ (put this-command 'disabled nil)))
+ (if (/= char ?n)
+ (call-interactively this-command))))
+
+(defun enable-command (command)
+ "Allow COMMAND to be executed without special confirmation from now on.
+The user's .emacs file is altered so that this will apply
+to future sessions."
+ (interactive "CEnable command: ")
+ (put command 'disabled nil)
+ (save-excursion
+ (set-buffer (find-file-noselect (substitute-in-file-name "~/.emacs")))
+ (goto-char (point-min))
+ (if (search-forward (concat "(put '" (symbol-name command) " ") nil t)
+ (delete-region
+ (progn (beginning-of-line) (point))
+ (progn (forward-line 1) (point)))
+ ;; Must have been disabled by default.
+ (goto-char (point-max))
+ (insert "\n(put '" (symbol-name command) " 'disabled nil)\n"))
+ (setq foo (buffer-modified-p))
+ (save-buffer)))
+
+(defun disable-command (command)
+ "Require special confirmation to execute COMMAND from now on.
+The user's .emacs file is altered so that this will apply
+to future sessions."
+ (interactive "CDisable command: ")
+ (put command 'disabled t)
+ (save-excursion
+ (set-buffer (find-file-noselect (substitute-in-file-name "~/.emacs")))
+ (goto-char (point-min))
+ (if (search-forward (concat "(put '" (symbol-name command) " ") nil t)
+ (delete-region
+ (progn (beginning-of-line) (point))
+ (progn (forward-line 1) (point))))
+ (goto-char (point-max))
+ (insert "(put '" (symbol-name command) " 'disabled t)\n")
+ (save-buffer)))
+
--- /dev/null
+;; Scramble text amusingly for Emacs.
+;; Copyright (C) 1985 Free Software Foundation, Inc.
+
+;; 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+
+(defun dissociated-press (&optional arg)
+ "Dissociate the text of the current buffer.
+Output goes in buffer named *Dissociation*,
+which is redisplayed each time text is added to it.
+Every so often the user must say whether to continue.
+If ARG is positive, require ARG chars of continuity.
+If ARG is negative, require -ARG words of continuity.
+Default is 2."
+ (interactive "P")
+ (setq arg (if arg (prefix-numeric-value arg) 2))
+ (let* ((inbuf (current-buffer))
+ (outbuf (get-buffer-create "*Dissociation*"))
+ (move-function (if (> arg 0) 'forward-char 'forward-word))
+ (move-amount (if (> arg 0) arg (- arg)))
+ (search-function (if (> arg 0) 'search-forward 'word-search-forward))
+ (last-query-point 0))
+ (switch-to-buffer outbuf)
+ (erase-buffer)
+ (while
+ (save-excursion
+ (goto-char last-query-point)
+ (vertical-motion (- (window-height) 4))
+ (or (= (point) (point-max))
+ (and (progn (goto-char (point-max))
+ (y-or-n-p "Continue dissociation? "))
+ (progn
+ (message "")
+ (recenter 1)
+ (setq last-query-point (point-max))
+ t))))
+ (let (start end)
+ (save-excursion
+ (set-buffer inbuf)
+ (setq start (point))
+ (if (eq move-function 'forward-char)
+ (progn
+ (setq end (+ start (+ move-amount (random 16))))
+ (if (> end (point-max))
+ (setq end (+ 1 move-amount (random 16))))
+ (goto-char end))
+ (funcall move-function
+ (+ move-amount (random 16))))
+ (setq end (point)))
+ (let ((opoint (point)))
+ (insert-buffer-substring inbuf start end)
+ (save-excursion
+ (goto-char opoint)
+ (end-of-line)
+ (and (> (current-column) fill-column)
+ (do-auto-fill)))))
+ (save-excursion
+ (set-buffer inbuf)
+ (if (eobp)
+ (goto-char (point-min))
+ (let ((overlap
+ (buffer-substring (prog1 (point)
+ (funcall move-function
+ (- move-amount)))
+ (point))))
+ (let (ranval)
+ (while (< (setq ranval (random)) 0))
+ (goto-char (1+ (% ranval (1- (point-max))))))
+ (or (funcall search-function overlap nil t)
+ (let ((opoint (point)))
+ (goto-char 1)
+ (funcall search-function overlap opoint t))))))
+ (sit-for 0))))
--- /dev/null
+;; Gomoku game between you and Emacs
+;; Copyright (C) 1988 Free Software Foundation, Inc.
+
+;; 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Gomoku game between you and GNU Emacs. Last modified on 13 Sep 1988
+;;;
+;;; Written by Ph. Schnoebelen (phs@lifia.imag.fr), 1987, 1988
+;;; with precious advices from J.-F. Rit.
+;;; This has been tested with GNU Emacs 18.50.
+
+(provide 'gomoku)
+
+
+;; RULES:
+;;
+;; Gomoku is a game played between two players on a rectangular board. Each
+;; player, in turn, marks a free square of its choice. The winner is the first
+;; one to mark five contiguous squares in any direction (horizontally,
+;; vertically or diagonally).
+;;
+;; I have been told that, in "The TRUE Gomoku", some restrictions are made
+;; about the squares where one may play, or else there is a known forced win
+;; for the first player. This program has no such restriction, but it does not
+;; know about the forced win, nor do I. Furthermore, you probably do not know
+;; it yourself :-).
+
+
+;; HOW TO INSTALL:
+;;
+;; There is nothing specific w.r.t. installation: just put this file in the
+;; lisp directory and add an autoload for command gomoku in site-init.el. If
+;; you don't want to rebuild Emacs, then every single user interested in
+;; Gomoku will have to put the autoload command in its .emacs file. Another
+;; possibility is to define in your .emacs some command using (require
+;; 'gomoku).
+;;
+;; The most important thing is to BYTE-COMPILE gomoku.el because it is
+;; important that the code be as fast as possible.
+;;
+;; There are two main places where you may want to customize the program: key
+;; bindings and board display. These features are commented in the code. Go
+;; and see.
+
+
+;; HOW TO USE:
+;;
+;; Once this file has been installed, the command "M-x gomoku" will display a
+;; board, the size of which depends on the size of the current window. The
+;; size of the board is easily modified by giving numeric arguments to the
+;; gomoku command and/or by customizing the displaying parameters.
+;;
+;; Emacs plays when it is its turn. When it is your turn, just put the cursor
+;; on the square where you want to play and hit RET, or X, or whatever key you
+;; bind to the command gomoku-human-plays. When it is your turn, Emacs is
+;; idle: you may switch buffers, read your mail, ... Just come back to the
+;; *Gomoku* buffer and resume play.
+
+
+;; ALGORITHM:
+;;
+;; The algorithm is briefly described in section "THE SCORE TABLE". Some
+;; parameters may be modified if you want to change the style exhibited by the
+;; program.
+\f
+;;;
+;;; GOMOKU MODE AND KEYMAP.
+;;;
+(defvar gomoku-mode-hook nil
+ "If non-nil, its value is called on entry to Gomoku mode.")
+
+(defvar gomoku-mode-map nil
+ "Local keymap to use in Gomoku mode.")
+
+(if gomoku-mode-map nil
+ (setq gomoku-mode-map (make-sparse-keymap))
+
+ ;; Key bindings for cursor motion. Arrow keys are just "function"
+ ;; keys, see below.
+ (define-key gomoku-mode-map "y" 'gomoku-move-nw) ; Y
+ (define-key gomoku-mode-map "u" 'gomoku-move-ne) ; U
+ (define-key gomoku-mode-map "b" 'gomoku-move-sw) ; B
+ (define-key gomoku-mode-map "n" 'gomoku-move-se) ; N
+ (define-key gomoku-mode-map "h" 'gomoku-move-left) ; H
+ (define-key gomoku-mode-map "l" 'gomoku-move-right) ; L
+ (define-key gomoku-mode-map "j" 'gomoku-move-down) ; J
+ (define-key gomoku-mode-map "k" 'gomoku-move-up) ; K
+ (define-key gomoku-mode-map "\C-n" 'gomoku-move-down) ; C-N
+ (define-key gomoku-mode-map "\C-p" 'gomoku-move-up) ; C-P
+ (define-key gomoku-mode-map "\C-f" 'gomoku-move-right) ; C-F
+ (define-key gomoku-mode-map "\C-b" 'gomoku-move-left) ; C-B
+
+ ;; Key bindings for entering Human moves.
+ ;; If you have a mouse, you may also bind some mouse click ...
+ (define-key gomoku-mode-map "X" 'gomoku-human-plays) ; X
+ (define-key gomoku-mode-map "x" 'gomoku-human-plays) ; x
+ (define-key gomoku-mode-map "\C-m" 'gomoku-human-plays) ; RET
+ (define-key gomoku-mode-map "\C-cp" 'gomoku-human-plays) ; C-C P
+ (define-key gomoku-mode-map "\C-cb" 'gomoku-human-takes-back) ; C-C B
+ (define-key gomoku-mode-map "\C-cr" 'gomoku-human-resigns) ; C-C R
+ (define-key gomoku-mode-map "\C-ce" 'gomoku-emacs-plays) ; C-C E
+
+ ;; Key bindings for "function" keys. If your terminal has such
+ ;; keys, make sure they are declared through the function-keymap
+ ;; keymap (see file keypad.el).
+ ;; One problem with keypad.el is that the function-key-sequence
+ ;; function is really slow, so slow that you may want to comment out
+ ;; the following lines ...
+ (if (featurep 'keypad)
+ (let (keys)
+ (if (setq keys (function-key-sequence ?u)) ; Up Arrow
+ (define-key gomoku-mode-map keys 'gomoku-move-up))
+ (if (setq keys (function-key-sequence ?d)) ; Down Arrow
+ (define-key gomoku-mode-map keys 'gomoku-move-down))
+ (if (setq keys (function-key-sequence ?l)) ; Left Arrow
+ (define-key gomoku-mode-map keys 'gomoku-move-left))
+ (if (setq keys (function-key-sequence ?r)) ; Right Arrow
+ (define-key gomoku-mode-map keys 'gomoku-move-right))
+;; (if (setq keys (function-key-sequence ?e)) ; Enter
+;; (define-key gomoku-mode-map keys 'gomoku-human-plays))
+;; (if (setq keys (function-key-sequence ?I)) ; Insert
+;; (define-key gomoku-mode-map keys 'gomoku-human-plays))
+ )))
+
+
+
+(defun gomoku-mode ()
+ "Major mode for playing Gomoku against Emacs.
+You and Emacs play in turn by marking a free square. You mark it with X
+and Emacs marks it with O. The winner is the first to get five contiguous
+marks horizontally, vertically or in diagonal.
+You play by moving the cursor over the square you choose and hitting RET,
+x, .. or whatever has been set locally.
+
+Other useful commands:
+
+C-c r Indicate that you resign,
+C-c t Take back your last move,
+C-c e Ask for Emacs to play (thus passing).
+
+Commands:
+\\{gomoku-mode-map}
+Entry to this mode calls the value of gomoku-mode-hook
+if that value is non-nil."
+ (interactive)
+ (setq major-mode 'gomoku-mode
+ mode-name "Gomoku")
+ (gomoku-display-statistics)
+ (use-local-map gomoku-mode-map)
+ (run-hooks 'gomoku-mode-hook))
+\f
+;;;
+;;; THE BOARD.
+;;;
+
+;; The board is a rectangular grid. We code empty squares with 0, X's with 1
+;; and O's with 6. The rectangle is recorded in a one dimensional vector
+;; containing padding squares (coded with -1). These squares allow us to
+;; detect when we are trying to move out of the board. We denote a square by
+;; its (X,Y) coords, or by the INDEX corresponding to them in the vector. The
+;; leftmost topmost square has coords (1,1) and index gomoku-board-width + 2.
+;; Similarly, vectors between squares may be given by two DX, DY coords or by
+;; one DEPL (the difference between indexes).
+
+(defvar gomoku-board-width nil
+ "Number of columns on the Gomoku board.")
+
+(defvar gomoku-board-height nil
+ "Number of lines on the Gomoku board.")
+
+(defvar gomoku-board nil
+ "Vector recording the actual state of the Gomoku board.")
+
+(defvar gomoku-vector-length nil
+ "Length of gomoku-board vector.")
+
+(defvar gomoku-draw-limit nil
+ ;; This is usually set to 70% of the number of squares.
+ "After how many moves will Emacs offer a draw ?")
+
+
+(defun gomoku-xy-to-index (x y)
+ "Translate X, Y cartesian coords into the corresponding board index."
+ (+ (* y gomoku-board-width) x y))
+
+(defun gomoku-index-to-x (index)
+ "Return corresponding x-coord of board INDEX."
+ (% index (1+ gomoku-board-width)))
+
+(defun gomoku-index-to-y (index)
+ "Return corresponding y-coord of board INDEX."
+ (/ index (1+ gomoku-board-width)))
+
+(defun gomoku-init-board ()
+ "Create the gomoku-board vector and fill it with initial values."
+ (setq gomoku-board (make-vector gomoku-vector-length 0))
+ ;; Every square is 0 (i.e. empty) except padding squares:
+ (let ((i 0) (ii (1- gomoku-vector-length)))
+ (while (<= i gomoku-board-width) ; The squares in [0..width] and in
+ (aset gomoku-board i -1) ; [length - width - 1..length - 1]
+ (aset gomoku-board ii -1) ; are padding squares.
+ (setq i (1+ i)
+ ii (1- ii))))
+ (let ((i 0))
+ (while (< i gomoku-vector-length)
+ (aset gomoku-board i -1) ; and also all k*(width+1)
+ (setq i (+ i gomoku-board-width 1)))))
+\f
+;;;
+;;; THE SCORE TABLE.
+;;;
+
+;; Every (free) square has a score associated to it, recorded in the
+;; GOMOKU-SCORE-TABLE vector. The program always plays in the square having
+;; the highest score.
+
+(defvar gomoku-score-table nil
+ "Vector recording the actual score of the free squares.")
+
+
+;; The key point point about the algorithm is that, rather than considering
+;; the board as just a set of squares, we prefer to see it as a "space" of
+;; internested 5-tuples of contiguous squares (called qtuples).
+;;
+;; The aim of the program is to fill one qtuple with its O's while preventing
+;; you from filling another one with your X's. To that effect, it computes a
+;; score for every qtuple, with better qtuples having better scores. Of
+;; course, the score of a qtuple (taken in isolation) is just determined by
+;; its contents as a set, i.e. not considering the order of its elements. The
+;; highest score is given to the "OOOO" qtuples because playing in such a
+;; qtuple is winning the game. Just after this comes the "XXXX" qtuple because
+;; not playing in it is just loosing the game, and so on. Note that a
+;; "polluted" qtuple, i.e. one containing at least one X and at least one O,
+;; has score zero because there is no more any point in playing in it, from
+;; both an attacking and a defending point of view.
+;;
+;; Given the score of every qtuple, the score of a given free square on the
+;; board is just the sum of the scores of all the qtuples to which it belongs,
+;; because playing in that square is playing in all its containing qtuples at
+;; once. And it is that function which takes into account the internesting of
+;; the qtuples.
+;;
+;; This algorithm is rather simple but anyway it gives a not so dumb level of
+;; play. It easily extends to "n-dimensional Gomoku", where a win should not
+;; be obtained with as few as 5 contiguous marks: 6 or 7 (depending on n !)
+;; should be preferred.
+
+
+;; Here are the scores of the nine "non-polluted" configurations. Tuning
+;; these values will change (hopefully improve) the strength of the program
+;; and may change its style (rather aggressive here).
+
+(defconst nil-score 7 "Score of an empty qtuple.")
+(defconst Xscore 15 "Score of a qtuple containing one X.")
+(defconst XXscore 400 "Score of a qtuple containing two X's.")
+(defconst XXXscore 1800 "Score of a qtuple containing three X's.")
+(defconst XXXXscore 100000 "Score of a qtuple containing four X's.")
+(defconst Oscore 35 "Score of a qtuple containing one O.")
+(defconst OOscore 800 "Score of a qtuple containing two O's.")
+(defconst OOOscore 15000 "Score of a qtuple containing three O's.")
+(defconst OOOOscore 800000 "Score of a qtuple containing four O's.")
+
+;; These values are not just random: if, given the following situation:
+;;
+;; . . . . . . . O .
+;; . X X a . . . X .
+;; . . . X . . . X .
+;; . . . X . . . X .
+;; . . . . . . . b .
+;;
+;; you want Emacs to play in "a" and not in "b", then the parameters must
+;; satisfy the inequality:
+;;
+;; 6 * XXscore > XXXscore + XXscore
+;;
+;; because "a" mainly belongs to six "XX" qtuples (the others are less
+;; important) while "b" belongs to one "XXX" and one "XX" qtuples. Other
+;; conditions are required to obtain sensible moves, but the previous example
+;; should illustrate the point. If you manage to improve on these values,
+;; please send me a note. Thanks.
+
+
+;; As we choosed values 0, 1 and 6 to denote empty, X and O squares, the
+;; contents of a qtuple is uniquely determined by the sum of its elements and
+;; we just have to set up a translation table.
+
+(defconst gomoku-score-trans-table
+ (vector nil-score Xscore XXscore XXXscore XXXXscore 0
+ Oscore 0 0 0 0 0
+ OOscore 0 0 0 0 0
+ OOOscore 0 0 0 0 0
+ OOOOscore 0 0 0 0 0
+ 0)
+ "Vector associating qtuple contents to their score.")
+
+
+;; If you do not modify drastically the previous constants, the only way for a
+;; square to have a score higher than OOOOscore is to belong to a "OOOO"
+;; qtuple, thus to be a winning move. Similarly, the only way for a square to
+;; have a score between XXXXscore and OOOOscore is to belong to a "XXXX"
+;; qtuple. We may use these considerations to detect when a given move is
+;; winning or loosing.
+
+(defconst gomoku-winning-threshold OOOOscore
+ "Threshold score beyond which an emacs move is winning.")
+
+(defconst gomoku-loosing-threshold XXXXscore
+ "Threshold score beyond which a human move is winning.")
+
+
+(defun gomoku-strongest-square ()
+ "Compute index of free square with highest score, or nil if none."
+ ;; We just have to loop other all squares. However there are two problems:
+ ;; 1/ The SCORE-TABLE only gives correct scores to free squares. To speed
+ ;; up future searches, we set the score of padding or occupied squares
+ ;; to -1 whenever we meet them.
+ ;; 2/ We want to choose randomly between equally good moves.
+ (let ((score-max 0)
+ (count 0) ; Number of equally good moves
+ (square (gomoku-xy-to-index 1 1)) ; First square
+ (end (gomoku-xy-to-index gomoku-board-width gomoku-board-height))
+ best-square score)
+ (while (<= square end)
+ (cond
+ ;; If score is lower (i.e. most of the time), skip to next:
+ ((< (aref gomoku-score-table square) score-max))
+ ;; If score is better, beware of non free squares:
+ ((> (setq score (aref gomoku-score-table square)) score-max)
+ (if (zerop (aref gomoku-board square)) ; is it free ?
+ (setq count 1 ; yes: take it !
+ best-square square
+ score-max score)
+ (aset gomoku-score-table square -1))) ; no: kill it !
+ ;; If score is equally good, choose randomly. But first check freeness:
+ ((not (zerop (aref gomoku-board square)))
+ (aset gomoku-score-table square -1))
+ ((= count (random-number (setq count (1+ count))))
+ (setq best-square square
+ score-max score)))
+ (setq square (1+ square))) ; try next square
+ best-square))
+
+(defun random-number (n)
+ "Return a random integer between 0 and N-1 inclusive."
+ (setq n (% (random) n))
+ (if (< n 0) (- n) n))
+\f
+;;;
+;;; INITIALIZING THE SCORE TABLE.
+;;;
+
+;; At initialization the board is empty so that every qtuple amounts for
+;; nil-score. Therefore, the score of any square is nil-score times the number
+;; of qtuples that pass through it. This number is 3 in a corner and 20 if you
+;; are sufficiently far from the sides. As computing the number is time
+;; consuming, we initialize every square with 20*nil-score and then only
+;; consider squares at less than 5 squares from one side. We speed this up by
+;; taking symmetry into account.
+;; Also, as it is likely that successive games will be played on a board with
+;; same size, it is a good idea to save the initial SCORE-TABLE configuration.
+
+(defvar gomoku-saved-score-table nil
+ "Recorded initial value of previous score table.")
+
+(defvar gomoku-saved-board-width nil
+ "Recorded value of previous board width.")
+
+(defvar gomoku-saved-board-height nil
+ "Recorded value of previous board height.")
+
+
+(defun gomoku-init-score-table ()
+ "Create the score table vector and fill it with initial values."
+ (if (and gomoku-saved-score-table ; Has it been stored last time ?
+ (= gomoku-board-width gomoku-saved-board-width)
+ (= gomoku-board-height gomoku-saved-board-height))
+ (setq gomoku-score-table (copy-sequence gomoku-saved-score-table))
+ ;; No, compute it:
+ (setq gomoku-score-table
+ (make-vector gomoku-vector-length (* 20 nil-score)))
+ (let (i j maxi maxj maxi2 maxj2)
+ (setq maxi (/ (1+ gomoku-board-width) 2)
+ maxj (/ (1+ gomoku-board-height) 2)
+ maxi2 (min 4 maxi)
+ maxj2 (min 4 maxj))
+ ;; We took symmetry into account and could use it more if the board
+ ;; would have been square and not rectangular !
+ ;; In our case we deal with all (i,j) in the set [1..maxi2]*[1..maxj] U
+ ;; [maxi2+1..maxi]*[1..maxj2]. Maxi2 and maxj2 are used because the
+ ;; board may well be less than 8 by 8 !
+ (setq i 1)
+ (while (<= i maxi2)
+ (setq j 1)
+ (while (<= j maxj)
+ (gomoku-init-square-score i j)
+ (setq j (1+ j)))
+ (setq i (1+ i)))
+ (while (<= i maxi)
+ (setq j 1)
+ (while (<= j maxj2)
+ (gomoku-init-square-score i j)
+ (setq j (1+ j)))
+ (setq i (1+ i))))
+ (setq gomoku-saved-score-table (copy-sequence gomoku-score-table)
+ gomoku-saved-board-width gomoku-board-width
+ gomoku-saved-board-height gomoku-board-height)))
+
+(defun gomoku-nb-qtuples (i j)
+ "Return the number of qtuples containing square I,J."
+ ;; This fonction is complicated because we have to deal
+ ;; with ugly cases like 3 by 6 boards, but it works.
+ ;; If you have a simpler (and correct) solution, send it to me. Thanks !
+ (let ((left (min 4 (1- i)))
+ (right (min 4 (- gomoku-board-width i)))
+ (up (min 4 (1- j)))
+ (down (min 4 (- gomoku-board-height j))))
+ (+ -12
+ (min (max (+ left right) 3) 8)
+ (min (max (+ up down) 3) 8)
+ (min (max (+ (min left up) (min right down)) 3) 8)
+ (min (max (+ (min right up) (min left down)) 3) 8))))
+
+(defun gomoku-init-square-score (i j)
+ "Give initial score to square I,J and to its mirror images."
+ (let ((ii (1+ (- gomoku-board-width i)))
+ (jj (1+ (- gomoku-board-height j)))
+ (sc (* (gomoku-nb-qtuples i j) (aref gomoku-score-trans-table 0))))
+ (aset gomoku-score-table (gomoku-xy-to-index i j) sc)
+ (aset gomoku-score-table (gomoku-xy-to-index ii j) sc)
+ (aset gomoku-score-table (gomoku-xy-to-index i jj) sc)
+ (aset gomoku-score-table (gomoku-xy-to-index ii jj) sc)))
+\f
+;;;
+;;; MAINTAINING THE SCORE TABLE.
+;;;
+
+;; We do not provide functions for computing the SCORE-TABLE given the
+;; contents of the BOARD. This would involve heavy nested loops, with time
+;; proportional to the size of the board. It is better to update the
+;; SCORE-TABLE after each move. Updating needs not modify more than 36
+;; squares: it is done in constant time.
+
+(defun gomoku-update-score-table (square dval)
+ "Update score table after SQUARE received a DVAL increment."
+ ;; The board has already been updated when this function is called.
+ ;; Updating scores is done by looking for qtuples boundaries in all four
+ ;; directions and then calling update-score-in-direction.
+ ;; Finally all squares received the right increment, and then are up to
+ ;; date, except possibly for SQUARE itself if we are taking a move back for
+ ;; its score had been set to -1 at the time.
+ (let* ((x (gomoku-index-to-x square))
+ (y (gomoku-index-to-y square))
+ (imin (max -4 (- 1 x)))
+ (jmin (max -4 (- 1 y)))
+ (imax (min 0 (- gomoku-board-width x 4)))
+ (jmax (min 0 (- gomoku-board-height y 4))))
+ (gomoku-update-score-in-direction imin imax
+ square 1 0 dval)
+ (gomoku-update-score-in-direction jmin jmax
+ square 0 1 dval)
+ (gomoku-update-score-in-direction (max imin jmin) (min imax jmax)
+ square 1 1 dval)
+ (gomoku-update-score-in-direction (max (- 1 y) -4
+ (- x gomoku-board-width))
+ (min 0 (- x 5)
+ (- gomoku-board-height y 4))
+ square -1 1 dval)))
+
+(defun gomoku-update-score-in-direction (left right square dx dy dval)
+ "Update scores for all squares in the qtuples starting between the LEFTth
+square and the RIGHTth after SQUARE, along the DX, DY direction, considering
+that DVAL has been added on SQUARE."
+ ;; We always have LEFT <= 0, RIGHT <= 0 and DEPL > 0 but we may very well
+ ;; have LEFT > RIGHT, indicating that no qtuple contains SQUARE along that
+ ;; DX,DY direction.
+ (cond
+ ((> left right)) ; Quit
+ (t ; Else ..
+ (let (depl square0 square1 square2 count delta)
+ (setq depl (gomoku-xy-to-index dx dy)
+ square0 (+ square (* left depl))
+ square1 (+ square (* right depl))
+ square2 (+ square0 (* 4 depl)))
+ ;; Compute the contents of the first qtuple:
+ (setq square square0
+ count 0)
+ (while (<= square square2)
+ (setq count (+ count (aref gomoku-board square))
+ square (+ square depl)))
+ (while (<= square0 square1)
+ ;; Update the squares of the qtuple beginning in SQUARE0 and ending
+ ;; in SQUARE2.
+ (setq delta (- (aref gomoku-score-trans-table count)
+ (aref gomoku-score-trans-table (- count dval))))
+ (cond ((not (zerop delta)) ; or else nothing to update
+ (setq square square0)
+ (while (<= square square2)
+ (if (zerop (aref gomoku-board square)) ; only for free squares
+ (aset gomoku-score-table square
+ (+ (aref gomoku-score-table square) delta)))
+ (setq square (+ square depl)))))
+ ;; Then shift the qtuple one square along DEPL, this only requires
+ ;; modifying SQUARE0 and SQUARE2.
+ (setq square2 (+ square2 depl)
+ count (+ count (- (aref gomoku-board square0))
+ (aref gomoku-board square2))
+ square0 (+ square0 depl)))))))
+\f
+;;;
+;;; GAME CONTROL.
+;;;
+
+;; Several variables are used to monitor a game, including a GAME-HISTORY (the
+;; list of all (SQUARE . PREVSCORE) played) that allows to take moves back
+;; (anti-updating the score table) and to compute the table from scratch in
+;; case of an interruption.
+
+(defvar gomoku-game-in-progress nil
+ "Non-nil if a game is in progress.")
+
+(defvar gomoku-game-history nil
+ "A record of all moves that have been played during current game.")
+
+(defvar gomoku-number-of-moves nil
+ "Number of moves already played in current game.")
+
+(defvar gomoku-number-of-human-moves nil
+ "Number of moves already played by human in current game.")
+
+(defvar gomoku-emacs-played-first nil
+ "Non-nil if Emacs played first.")
+
+(defvar gomoku-human-took-back nil
+ "Non-nil if Human took back a move during the game.")
+
+(defvar gomoku-human-refused-draw nil
+ "Non-nil if Human refused Emacs offer of a draw.")
+
+(defvar gomoku-emacs-is-computing nil
+ ;; This is used to detect interruptions. Hopefully, it should not be needed.
+ "Non-nil if Emacs is in the middle of a computation.")
+
+
+(defun gomoku-start-game (n m)
+ "Initialize a new game on an N by M board."
+ (setq gomoku-emacs-is-computing t) ; Raise flag
+ (setq gomoku-game-in-progress t)
+ (setq gomoku-board-width n
+ gomoku-board-height m
+ gomoku-vector-length (1+ (* (+ m 2) (1+ n)))
+ gomoku-draw-limit (/ (* 7 n m) 10))
+ (setq gomoku-game-history nil
+ gomoku-number-of-moves 0
+ gomoku-number-of-human-moves 0
+ gomoku-emacs-played-first nil
+ gomoku-human-took-back nil
+ gomoku-human-refused-draw nil)
+ (gomoku-init-display n m) ; Display first: the rest takes time
+ (gomoku-init-score-table) ; INIT-BOARD requires that the score
+ (gomoku-init-board) ; table be already created.
+ (setq gomoku-emacs-is-computing nil))
+
+(defun gomoku-play-move (square val &optional dont-update-score)
+ "Go to SQUARE, play VAL and update everything."
+ (setq gomoku-emacs-is-computing t) ; Raise flag
+ (cond ((= 1 val) ; a Human move
+ (setq gomoku-number-of-human-moves (1+ gomoku-number-of-human-moves)))
+ ((zerop gomoku-number-of-moves) ; an Emacs move. Is it first ?
+ (setq gomoku-emacs-played-first t)))
+ (setq gomoku-game-history
+ (cons (cons square (aref gomoku-score-table square))
+ gomoku-game-history)
+ gomoku-number-of-moves (1+ gomoku-number-of-moves))
+ (gomoku-plot-square square val)
+ (aset gomoku-board square val) ; *BEFORE* UPDATE-SCORE !
+ (if dont-update-score nil
+ (gomoku-update-score-table square val) ; previous val was 0: dval = val
+ (aset gomoku-score-table square -1))
+ (setq gomoku-emacs-is-computing nil))
+
+(defun gomoku-take-back ()
+ "Take back last move and update everything."
+ (setq gomoku-emacs-is-computing t)
+ (let* ((last-move (car gomoku-game-history))
+ (square (car last-move))
+ (oldval (aref gomoku-board square)))
+ (if (= 1 oldval)
+ (setq gomoku-number-of-human-moves (1- gomoku-number-of-human-moves)))
+ (setq gomoku-game-history (cdr gomoku-game-history)
+ gomoku-number-of-moves (1- gomoku-number-of-moves))
+ (gomoku-plot-square square 0)
+ (aset gomoku-board square 0) ; *BEFORE* UPDATE-SCORE !
+ (gomoku-update-score-table square (- oldval))
+ (aset gomoku-score-table square (cdr last-move)))
+ (setq gomoku-emacs-is-computing nil))
+\f
+;;;
+;;; SESSION CONTROL.
+;;;
+
+(defvar gomoku-number-of-wins 0
+ "Number of games already won in this session.")
+
+(defvar gomoku-number-of-losses 0
+ "Number of games already lost in this session.")
+
+(defvar gomoku-number-of-draws 0
+ "Number of games already drawn in this session.")
+
+
+(defun gomoku-terminate-game (result)
+ "Terminate the current game with RESULT."
+ (let (message)
+ (cond
+ ((eq result 'emacs-won)
+ (setq gomoku-number-of-wins (1+ gomoku-number-of-wins))
+ (setq message
+ (cond ((< gomoku-number-of-moves 20)
+ "This was a REALLY QUICK win.")
+ (gomoku-human-refused-draw
+ "I won... Too bad you refused my offer of a draw !")
+ (gomoku-human-took-back
+ "I won... Taking moves back will not help you !")
+ ((not gomoku-emacs-played-first)
+ "I won... Playing first did not help you much !")
+ ((and (zerop gomoku-number-of-losses)
+ (zerop gomoku-number-of-draws)
+ (> gomoku-number-of-wins 1))
+ "I'm becoming tired of winning...")
+ (t
+ "I won."))))
+ ((eq result 'human-won)
+ (setq gomoku-number-of-losses (1+ gomoku-number-of-losses))
+ (setq message
+ (cond
+ (gomoku-human-took-back
+ "OK, you won this one. I, for one, never take my moves back...")
+ (gomoku-emacs-played-first
+ "OK, you won this one... so what ?")
+ (t
+ "OK, you won this one. Now, let me play first just once."))))
+ ((eq result 'human-resigned)
+ (setq gomoku-number-of-wins (1+ gomoku-number-of-wins))
+ (setq message "So you resign... That's just one more win for me."))
+ ((eq result 'nobody-won)
+ (setq gomoku-number-of-draws (1+ gomoku-number-of-draws))
+ (setq message
+ (cond
+ (gomoku-human-took-back
+ "This is a draw. I, for one, never take my moves back...")
+ (gomoku-emacs-played-first
+ "This is a draw... Just chance, I guess.")
+ (t
+ "This is a draw. Now, let me play first just once."))))
+ ((eq result 'draw-agreed)
+ (setq gomoku-number-of-draws (1+ gomoku-number-of-draws))
+ (setq message
+ (cond
+ (gomoku-human-took-back
+ "Draw agreed. I, for one, never take my moves back...")
+ (gomoku-emacs-played-first
+ "Draw agreed. You were lucky.")
+ (t
+ "Draw agreed. Now, let me play first just once."))))
+ ((eq result 'crash-game)
+ (setq message
+ "Sorry, I have been interrupted and cannot resume that game...")))
+
+ (gomoku-display-statistics)
+ (if message (message message))
+ (ding)
+ (setq gomoku-game-in-progress nil)))
+
+(defun gomoku-crash-game ()
+ "What to do when Emacs detects it has been interrupted."
+ (setq gomoku-emacs-is-computing nil)
+ (gomoku-terminate-game 'crash-game)
+ (sit-for 4) ; Let's see the message
+ (gomoku-prompt-for-other-game))
+\f
+;;;
+;;; INTERACTIVE COMMANDS.
+;;;
+
+(defun gomoku (&optional n m)
+ "Start a Gomoku game between you and Emacs.
+If a game is in progress, this command allow you to resume it.
+If optional arguments N and M are given, an N by M board is used.
+
+You and Emacs play in turn by marking a free square. You mark it with X
+and Emacs marks it with O. The winner is the first to get five contiguous
+marks horizontally, vertically or in diagonal.
+You play by moving the cursor over the square you choose and hitting RET,
+x, .. or whatever has been set locally.
+Use C-h m for more info."
+ (interactive)
+ (gomoku-switch-to-window)
+ (cond
+ (gomoku-emacs-is-computing
+ (gomoku-crash-game))
+ ((not gomoku-game-in-progress)
+ (let ((max-width (gomoku-max-width))
+ (max-height (gomoku-max-height)))
+ (or n (setq n max-width))
+ (or m (setq m max-height))
+ (cond ((< n 1)
+ (error "I need at least 1 column"))
+ ((< m 1)
+ (error "I need at least 1 row"))
+ ((> n max-width)
+ (error "I cannot display %d columns in that window" n)))
+ (if (and (> m max-height)
+ (not (equal m gomoku-saved-board-height))
+ ;; Use EQUAL because SAVED-BOARD-HEIGHT may be nil
+ (not (y-or-n-p (format "Do you really want %d rows " m))))
+ (setq m max-height)))
+ (message "One moment, please...")
+ (gomoku-start-game n m)
+ (if (y-or-n-p "Do you allow me to play first ")
+ (gomoku-emacs-plays)
+ (gomoku-prompt-for-move)))
+ ((y-or-n-p "Shall we continue our game ")
+ (gomoku-prompt-for-move))
+ (t
+ (gomoku-human-resigns))))
+
+(defun gomoku-emacs-plays ()
+ "Compute Emacs next move and play it."
+ (interactive)
+ (gomoku-switch-to-window)
+ (cond
+ (gomoku-emacs-is-computing
+ (gomoku-crash-game))
+ ((not gomoku-game-in-progress)
+ (gomoku-prompt-for-other-game))
+ (t
+ (message "Let me think...")
+ (let (square score)
+ (setq square (gomoku-strongest-square))
+ (cond ((null square)
+ (gomoku-terminate-game 'nobody-won))
+ (t
+ (setq score (aref gomoku-score-table square))
+ (gomoku-play-move square 6)
+ (cond ((>= score gomoku-winning-threshold)
+ (gomoku-find-filled-qtuple square 6)
+ (gomoku-cross-winning-qtuple)
+ (gomoku-terminate-game 'emacs-won))
+ ((zerop score)
+ (gomoku-terminate-game 'nobody-won))
+ ((and (> gomoku-number-of-moves gomoku-draw-limit)
+ (not gomoku-human-refused-draw)
+ (gomoku-offer-a-draw))
+ (gomoku-terminate-game 'draw-agreed))
+ (t
+ (gomoku-prompt-for-move)))))))))
+
+(defun gomoku-human-plays ()
+ "Signal to the Gomoku program that you have played.
+You must have put the cursor on the square where you want to play.
+If the game is finished, this command requests for another game."
+ (interactive)
+ (gomoku-switch-to-window)
+ (cond
+ (gomoku-emacs-is-computing
+ (gomoku-crash-game))
+ ((not gomoku-game-in-progress)
+ (gomoku-prompt-for-other-game))
+ (t
+ (let (square score)
+ (setq square (gomoku-point-square))
+ (cond ((null square)
+ (error "Your point is not on a square. Retry !"))
+ ((not (zerop (aref gomoku-board square)))
+ (error "Your point is not on a free square. Retry !"))
+ (t
+ (setq score (aref gomoku-score-table square))
+ (gomoku-play-move square 1)
+ (cond ((and (>= score gomoku-loosing-threshold)
+ ;; Just testing SCORE > THRESHOLD is not enough for
+ ;; detecting wins, it just gives an indication that
+ ;; we confirm with GOMOKU-FIND-FILLED-QTUPLE.
+ (gomoku-find-filled-qtuple square 1))
+ (gomoku-cross-winning-qtuple)
+ (gomoku-terminate-game 'human-won))
+ (t
+ (gomoku-emacs-plays)))))))))
+
+(defun gomoku-human-takes-back ()
+ "Signal to the Gomoku program that you wish to take back your last move."
+ (interactive)
+ (gomoku-switch-to-window)
+ (cond
+ (gomoku-emacs-is-computing
+ (gomoku-crash-game))
+ ((not gomoku-game-in-progress)
+ (message "Too late for taking back...")
+ (sit-for 4)
+ (gomoku-prompt-for-other-game))
+ ((zerop gomoku-number-of-human-moves)
+ (message "You have not played yet... Your move ?"))
+ (t
+ (message "One moment, please...")
+ ;; It is possible for the user to let Emacs play several consecutive
+ ;; moves, so that the best way to know when to stop taking back moves is
+ ;; to count the number of human moves:
+ (setq gomoku-human-took-back t)
+ (let ((number gomoku-number-of-human-moves))
+ (while (= number gomoku-number-of-human-moves)
+ (gomoku-take-back)))
+ (gomoku-prompt-for-move))))
+
+(defun gomoku-human-resigns ()
+ "Signal to the Gomoku program that you may want to resign."
+ (interactive)
+ (gomoku-switch-to-window)
+ (cond
+ (gomoku-emacs-is-computing
+ (gomoku-crash-game))
+ ((not gomoku-game-in-progress)
+ (message "There is no game in progress"))
+ ((y-or-n-p "You mean, you resign ")
+ (gomoku-terminate-game 'human-resigned))
+ ((y-or-n-p "You mean, we continue ")
+ (gomoku-prompt-for-move))
+ (t
+ (gomoku-terminate-game 'human-resigned)))) ; OK. Accept it
+\f
+;;;
+;;; PROMPTING THE HUMAN PLAYER.
+;;;
+
+(defun gomoku-prompt-for-move ()
+ "Display a message asking for Human's move."
+ (message (if (zerop gomoku-number-of-human-moves)
+ "Your move ? (move to a free square and hit X, RET ...)"
+ "Your move ?"))
+ ;; This may seem silly, but if one omits the following line (or a similar
+ ;; one), the cursor may very well go to some place where POINT is not.
+ (save-excursion (set-buffer (other-buffer))))
+
+(defun gomoku-prompt-for-other-game ()
+ "Ask for another game, and start it."
+ (if (y-or-n-p "Another game ")
+ (gomoku gomoku-board-width gomoku-board-height)
+ (message "Chicken !")))
+
+(defun gomoku-offer-a-draw ()
+ "Offer a draw and return T if Human accepted it."
+ (or (y-or-n-p "I offer you a draw. Do you accept it ")
+ (prog1 (setq gomoku-human-refused-draw t)
+ nil)))
+\f
+;;;
+;;; DISPLAYING THE BOARD.
+;;;
+
+;; You may change these values if you have a small screen or if the squares
+;; look rectangular, but spacings SHOULD be at least 2 (MUST BE at least 1).
+
+(defconst gomoku-square-width 4
+ "*Horizontal spacing between squares on the Gomoku board.")
+
+(defconst gomoku-square-height 2
+ "*Vertical spacing between squares on the Gomoku board.")
+
+(defconst gomoku-x-offset 3
+ "*Number of columns between the Gomoku board and the side of the window.")
+
+(defconst gomoku-y-offset 1
+ "*Number of lines between the Gomoku board and the top of the window.")
+
+
+(defun gomoku-max-width ()
+ "Largest possible board width for the current window."
+ (1+ (/ (- (window-width (selected-window))
+ gomoku-x-offset gomoku-x-offset 1)
+ gomoku-square-width)))
+
+(defun gomoku-max-height ()
+ "Largest possible board height for the current window."
+ (1+ (/ (- (window-height (selected-window))
+ gomoku-y-offset gomoku-y-offset 2)
+ ;; 2 instead of 1 because WINDOW-HEIGHT includes the mode line !
+ gomoku-square-height)))
+
+(defun gomoku-point-x ()
+ "Return the board column where point is, or nil if it is not a board column."
+ (let ((col (- (current-column) gomoku-x-offset)))
+ (if (and (>= col 0)
+ (zerop (% col gomoku-square-width))
+ (<= (setq col (1+ (/ col gomoku-square-width)))
+ gomoku-board-width))
+ col)))
+
+(defun gomoku-point-y ()
+ "Return the board row where point is, or nil if it is not a board row."
+ (let ((row (- (count-lines 1 (point)) gomoku-y-offset 1)))
+ (if (and (>= row 0)
+ (zerop (% row gomoku-square-height))
+ (<= (setq row (1+ (/ row gomoku-square-height)))
+ gomoku-board-height))
+ row)))
+
+(defun gomoku-point-square ()
+ "Return the index of the square point is on, or nil if not on the board."
+ (let (x y)
+ (and (setq x (gomoku-point-x))
+ (setq y (gomoku-point-y))
+ (gomoku-xy-to-index x y))))
+
+(defun gomoku-goto-square (index)
+ "Move point to square number INDEX."
+ (gomoku-goto-xy (gomoku-index-to-x index) (gomoku-index-to-y index)))
+
+(defun gomoku-goto-xy (x y)
+ "Move point to square at X, Y coords."
+ (goto-line (+ 1 gomoku-y-offset (* gomoku-square-height (1- y))))
+ (move-to-column (+ gomoku-x-offset (* gomoku-square-width (1- x)))))
+
+(defun gomoku-plot-square (square value)
+ "Draw 'X', 'O' or '.' on SQUARE (depending on VALUE), leave point there."
+ (gomoku-goto-square square)
+ (gomoku-put-char (cond ((= value 1) ?X)
+ ((= value 6) ?O)
+ (t ?.)))
+ (sit-for 0)) ; Display NOW
+
+(defun gomoku-put-char (char)
+ "Draw CHAR on the Gomoku screen."
+ (if buffer-read-only (toggle-read-only))
+ (insert char)
+ (delete-char 1)
+ (backward-char 1)
+ (toggle-read-only))
+
+(defun gomoku-init-display (n m)
+ "Display an N by M Gomoku board."
+ (buffer-flush-undo (current-buffer))
+ (if buffer-read-only (toggle-read-only))
+ (erase-buffer)
+ (let (string1 string2 string3 string4)
+ ;; We do not use gomoku-plot-square which would be too slow for
+ ;; initializing the display. Rather we build STRING1 for lines where
+ ;; board squares are to be found, and STRING2 for empty lines. STRING1 is
+ ;; like STRING2 except for dots every DX squares. Empty lines are filled
+ ;; with spaces so that cursor moving up and down remains on the same
+ ;; column.
+ (setq string1 (concat (make-string (1- gomoku-square-width) ? ) ".")
+ string1 (apply 'concat
+ (make-list (1- n) string1))
+ string1 (concat (make-string gomoku-x-offset ? ) "." string1 "\n")
+ string2 (make-string (+ 1 gomoku-x-offset
+ (* (1- n) gomoku-square-width))
+ ? )
+ string2 (concat string2 "\n")
+ string3 (apply 'concat
+ (make-list (1- gomoku-square-height) string2))
+ string3 (concat string3 string1)
+ string3 (apply 'concat
+ (make-list (1- m) string3))
+ string4 (apply 'concat
+ (make-list gomoku-y-offset string2)))
+ (insert string4 string1 string3))
+ (toggle-read-only)
+ (gomoku-goto-xy (/ (1+ n) 2) (/ (1+ m) 2)) ; center of the board
+ (sit-for 0)) ; Display NOW
+
+(defun gomoku-display-statistics ()
+ "Obnoxiously display some statistics about previous games in mode line."
+ ;; We store this string in the mode-line-process local variable.
+ ;; This is certainly not the cleanest way out ...
+ (setq mode-line-process
+ (cond
+ ((not (zerop gomoku-number-of-draws))
+ (format ": Won %d, lost %d, drew %d"
+ gomoku-number-of-wins
+ gomoku-number-of-losses
+ gomoku-number-of-draws))
+ ((not (zerop gomoku-number-of-losses))
+ (format ": Won %d, lost %d"
+ gomoku-number-of-wins
+ gomoku-number-of-losses))
+ ((zerop gomoku-number-of-wins)
+ "")
+ ((= 1 gomoku-number-of-wins)
+ ": Already won one")
+ (t
+ (format ": Won %d in a row"
+ gomoku-number-of-wins))))
+ ;; Then a (standard) kludgy line will force update of mode line.
+ (set-buffer-modified-p (buffer-modified-p)))
+
+(defun gomoku-switch-to-window ()
+ "Find or create the Gomoku buffer, and display it."
+ (interactive)
+ (let ((buff (get-buffer "*Gomoku*")))
+ (if buff ; Buffer exists:
+ (switch-to-buffer buff) ; no problem.
+ (if gomoku-game-in-progress
+ (gomoku-crash-game)) ; buffer has been killed or something
+ (switch-to-buffer "*Gomoku*") ; Anyway, start anew.
+ (gomoku-mode))))
+\f
+;;;
+;;; CROSSING WINNING QTUPLES.
+;;;
+
+;; When someone succeeds in filling a qtuple, we draw a line over the five
+;; corresponding squares. One problem is that the program does not know which
+;; squares ! It only knows the square where the last move has been played and
+;; who won. The solution is to scan the board along all four directions.
+
+(defvar gomoku-winning-qtuple-beg nil
+ "First square of the winning qtuple.")
+
+(defvar gomoku-winning-qtuple-end nil
+ "Last square of the winning qtuple.")
+
+(defvar gomoku-winning-qtuple-dx nil
+ "Direction of the winning qtuple (along the X axis).")
+
+(defvar gomoku-winning-qtuple-dy nil
+ "Direction of the winning qtuple (along the Y axis).")
+
+
+(defun gomoku-find-filled-qtuple (square value)
+ "Return T if SQUARE belongs to a qtuple filled with VALUEs."
+ (or (gomoku-check-filled-qtuple square value 1 0)
+ (gomoku-check-filled-qtuple square value 0 1)
+ (gomoku-check-filled-qtuple square value 1 1)
+ (gomoku-check-filled-qtuple square value -1 1)))
+
+(defun gomoku-check-filled-qtuple (square value dx dy)
+ "Return T if SQUARE belongs to a qtuple filled with VALUEs along DX, DY."
+ ;; And record it in the WINNING-QTUPLE-... variables.
+ (let ((a 0) (b 0)
+ (left square) (right square)
+ (depl (gomoku-xy-to-index dx dy))
+ a+4)
+ (while (and (> a -4) ; stretch tuple left
+ (= value (aref gomoku-board (setq left (- left depl)))))
+ (setq a (1- a)))
+ (setq a+4 (+ a 4))
+ (while (and (< b a+4) ; stretch tuple right
+ (= value (aref gomoku-board (setq right (+ right depl)))))
+ (setq b (1+ b)))
+ (cond ((= b a+4) ; tuple length = 5 ?
+ (setq gomoku-winning-qtuple-beg (+ square (* a depl))
+ gomoku-winning-qtuple-end (+ square (* b depl))
+ gomoku-winning-qtuple-dx dx
+ gomoku-winning-qtuple-dy dy)
+ t))))
+
+(defun gomoku-cross-winning-qtuple ()
+ "Cross winning qtuple, as found by gomoku-find-filled-qtuple."
+ (gomoku-cross-qtuple gomoku-winning-qtuple-beg
+ gomoku-winning-qtuple-end
+ gomoku-winning-qtuple-dx
+ gomoku-winning-qtuple-dy))
+
+(defun gomoku-cross-qtuple (square1 square2 dx dy)
+ "Cross every square between SQUARE1 and SQUARE2 in the DX, DY direction."
+ (save-excursion ; Not moving point from last square
+ (let ((depl (gomoku-xy-to-index dx dy)))
+ ;; WARNING: this function assumes DEPL > 0 and SQUARE2 > SQUARE1
+ (while (not (= square1 square2))
+ (gomoku-goto-square square1)
+ (setq square1 (+ square1 depl))
+ (cond
+ ((and (= dx 1) (= dy 0)) ; Horizontal
+ (let ((n 1))
+ (while (< n gomoku-square-width)
+ (setq n (1+ n))
+ (forward-char 1)
+ (gomoku-put-char ?-))))
+ ((and (= dx 0) (= dy 1)) ; Vertical
+ (let ((n 1))
+ (while (< n gomoku-square-height)
+ (setq n (1+ n))
+ (next-line 1)
+ (gomoku-put-char ?|))))
+ ((and (= dx -1) (= dy 1)) ; 1st Diagonal
+ (backward-char (/ gomoku-square-width 2))
+ (next-line (/ gomoku-square-height 2))
+ (gomoku-put-char ?/))
+ ((and (= dx 1) (= dy 1)) ; 2nd Diagonal
+ (forward-char (/ gomoku-square-width 2))
+ (next-line (/ gomoku-square-height 2))
+ (gomoku-put-char ?\\))))))
+ (sit-for 0)) ; Display NOW
+\f
+;;;
+;;; CURSOR MOTION.
+;;;
+(defun gomoku-move-left ()
+ "Move point backward one column on the Gomoku board."
+ (interactive)
+ (let ((x (gomoku-point-x)))
+ (backward-char (cond ((null x) 1)
+ ((> x 1) gomoku-square-width)
+ (t 0)))))
+
+(defun gomoku-move-right ()
+ "Move point forward one column on the Gomoku board."
+ (interactive)
+ (let ((x (gomoku-point-x)))
+ (forward-char (cond ((null x) 1)
+ ((< x gomoku-board-width) gomoku-square-width)
+ (t 0)))))
+
+(defun gomoku-move-down ()
+ "Move point down one row on the Gomoku board."
+ (interactive)
+ (let ((y (gomoku-point-y)))
+ (next-line (cond ((null y) 1)
+ ((< y gomoku-board-height) gomoku-square-height)
+ (t 0)))))
+
+(defun gomoku-move-up ()
+ "Move point up one row on the Gomoku board."
+ (interactive)
+ (let ((y (gomoku-point-y)))
+ (previous-line (cond ((null y) 1)
+ ((> y 1) gomoku-square-height)
+ (t 0)))))
+
+(defun gomoku-move-ne ()
+ "Move point North East on the Gomoku board."
+ (interactive)
+ (gomoku-move-up)
+ (gomoku-move-right))
+
+(defun gomoku-move-se ()
+ "Move point South East on the Gomoku board."
+ (interactive)
+ (gomoku-move-down)
+ (gomoku-move-right))
+
+(defun gomoku-move-nw ()
+ "Move point North West on the Gomoku board."
+ (interactive)
+ (gomoku-move-up)
+ (gomoku-move-left))
+
+(defun gomoku-move-sw ()
+ "Move point South West on the Gomoku board."
+ (interactive)
+ (gomoku-move-down)
+ (gomoku-move-left))
+
+
--- /dev/null
+;; Spook phrase utility
+;; Copyright (C) 1988 Free Software Foundation, Inc.
+
+;; 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+
+; Steve Strassmann (straz@media-lab.media.mit.edu) didn't write
+; this, and even if he did, he really didn't mean for you to use it
+; in an anarchistic way.
+; May 1987
+
+; To use this:
+; Make sure you have the variable SPOOK-PHRASES-FILE pointing to
+; a valid phrase file. Phrase files are in the same format as
+; zippy's yow.lines (ITS-style LINS format).
+; Strings are terminated by ascii 0 characters. Leading whitespace ignored.
+; Everything up to the first \000 is a comment.
+;
+; Just before sending mail, do M-x spook.
+; A number of phrases will be inserted into your buffer, to help
+; give your message that extra bit of attractiveness for automated
+; keyword scanners.
+
+; Variables
+(defvar spook-phrases-file (concat exec-directory "spook.lines")
+ "Keep your favorite phrases here.")
+
+(defvar spook-phrase-default-count 15
+ "Default number of phrases to insert")
+
+(defvar spook-vector nil
+ "Important phrases for NSA mail-watchers")
+
+; Randomize the seed in the random number generator.
+(random t)
+
+; Call this with M-x spook.
+(defun spook ()
+ "Adds that special touch of class to your outgoing mail."
+ (interactive)
+ (if (null spook-vector)
+ (setq spook-vector (snarf-spooks)))
+ (shuffle-vector spook-vector)
+ (let ((start (point)))
+ (insert ?\n)
+ (spook1 (min (- (length spook-vector) 1) spook-phrase-default-count))
+ (insert ?\n)
+ (fill-region-as-paragraph start (point) nil)))
+
+(defun spook1 (arg)
+ "Inserts a spook phrase ARG times."
+ (cond ((zerop arg) t)
+ (t (insert (aref spook-vector arg))
+ (insert " ")
+ (spook1 (1- arg)))))
+
+(defun snarf-spooks ()
+ "Reads in the phrase file"
+ (message "Checking authorization...")
+ (save-excursion
+ (let ((buf (generate-new-buffer "*spook*"))
+ (result '()))
+ (set-buffer buf)
+ (insert-file-contents (expand-file-name spook-phrases-file))
+ (search-forward "\0")
+ (while (progn (skip-chars-forward " \t\n\r\f") (not (eobp)))
+ (let ((beg (point)))
+ (search-forward "\0")
+ (setq result (cons (buffer-substring beg (1- (point)))
+ result))))
+ (kill-buffer buf)
+ (message "Checking authorization... Approved.")
+ (setq spook-vector (apply 'vector result)))))
+
+(defun pick-random (n)
+ "Returns a random number from 0 to N-1 inclusive."
+ (% (logand 0777777 (random)) n))
+
+; Thanks to Ian G Batten <BattenIG@CS.BHAM.AC.UK>
+; [of the University of Birmingham Computer Science Department]
+; for the iterative version of this shuffle.
+;
+(defun shuffle-vector (vector)
+ "Randomly permute the elements of VECTOR (all permutations equally likely)"
+ (let ((i 0)
+ j
+ temp
+ (len (length vector)))
+ (while (< i len)
+ (setq j (+ i (pick-random (- len i))))
+ (setq temp (aref vector i))
+ (aset vector i (aref vector j))
+ (aset vector j temp)
+ (setq i (1+ i))))
+ vector)
--- /dev/null
+;; Note: use
+;; (autoload 'icon-mode "icon" nil t)
+;; (setq auto-mode-alist (cons '("\\.icn$" . icon-mode) auto-mode-alist))
+;; if not permanently installed in your emacs
+
+;; Icon code editing commands for Emacs
+;; Derived from c-mode.el 15-Feb-89 Chris Smith convex!csmith
+;; Copyright (C) 1989 Free Software Foundation, Inc.
+
+;; 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+
+(defvar icon-mode-abbrev-table nil
+ "Abbrev table in use in Icon-mode buffers.")
+(define-abbrev-table 'icon-mode-abbrev-table ())
+
+(defvar icon-mode-map ()
+ "Keymap used in Icon mode.")
+(if icon-mode-map
+ ()
+ (setq icon-mode-map (make-sparse-keymap))
+ (define-key icon-mode-map "{" 'electric-icon-brace)
+ (define-key icon-mode-map "}" 'electric-icon-brace)
+ (define-key icon-mode-map "\e\C-h" 'mark-icon-function)
+ (define-key icon-mode-map "\e\C-a" 'beginning-of-icon-defun)
+ (define-key icon-mode-map "\e\C-e" 'end-of-icon-defun)
+ (define-key icon-mode-map "\e\C-q" 'indent-icon-exp)
+ (define-key icon-mode-map "\177" 'backward-delete-char-untabify)
+ (define-key icon-mode-map "\t" 'icon-indent-command))
+
+(defvar icon-mode-syntax-table nil
+ "Syntax table in use in Icon-mode buffers.")
+
+(if icon-mode-syntax-table
+ ()
+ (setq icon-mode-syntax-table (make-syntax-table))
+ (modify-syntax-entry ?\\ "\\" icon-mode-syntax-table)
+ (modify-syntax-entry ?# "<" icon-mode-syntax-table)
+ (modify-syntax-entry ?\n ">" icon-mode-syntax-table)
+ (modify-syntax-entry ?$ "." icon-mode-syntax-table)
+ (modify-syntax-entry ?/ "." icon-mode-syntax-table)
+ (modify-syntax-entry ?* "." icon-mode-syntax-table)
+ (modify-syntax-entry ?+ "." icon-mode-syntax-table)
+ (modify-syntax-entry ?- "." icon-mode-syntax-table)
+ (modify-syntax-entry ?= "." icon-mode-syntax-table)
+ (modify-syntax-entry ?% "." icon-mode-syntax-table)
+ (modify-syntax-entry ?< "." icon-mode-syntax-table)
+ (modify-syntax-entry ?> "." icon-mode-syntax-table)
+ (modify-syntax-entry ?& "." icon-mode-syntax-table)
+ (modify-syntax-entry ?| "." icon-mode-syntax-table)
+ (modify-syntax-entry ?\' "\"" icon-mode-syntax-table))
+
+(defconst icon-indent-level 4
+ "*Indentation of Icon statements with respect to containing block.")
+(defconst icon-brace-imaginary-offset 0
+ "*Imagined indentation of a Icon open brace that actually follows a statement.")
+(defconst icon-brace-offset 0
+ "*Extra indentation for braces, compared with other text in same context.")
+(defconst icon-continued-statement-offset 4
+ "*Extra indent for lines not starting new statements.")
+(defconst icon-continued-brace-offset 0
+ "*Extra indent for substatements that start with open-braces.
+This is in addition to icon-continued-statement-offset.")
+
+(defconst icon-auto-newline nil
+ "*Non-nil means automatically newline before and after braces
+inserted in Icon code.")
+
+(defconst icon-tab-always-indent t
+ "*Non-nil means TAB in Icon mode should always reindent the current line,
+regardless of where in the line point is when the TAB command is used.")
+\f
+(defun icon-mode ()
+ "Major mode for editing Icon code.
+Expression and list commands understand all Icon brackets.
+Tab indents for Icon code.
+Paragraphs are separated by blank lines only.
+Delete converts tabs to spaces as it moves back.
+\\{icon-mode-map}
+Variables controlling indentation style:
+ icon-tab-always-indent
+ Non-nil means TAB in Icon mode should always reindent the current line,
+ regardless of where in the line point is when the TAB command is used.
+ icon-auto-newline
+ Non-nil means automatically newline before and after braces
+ inserted in Icon code.
+ icon-indent-level
+ Indentation of Icon statements within surrounding block.
+ The surrounding block's indentation is the indentation
+ of the line on which the open-brace appears.
+ icon-continued-statement-offset
+ Extra indentation given to a substatement, such as the
+ then-clause of an if or body of a while.
+ icon-continued-brace-offset
+ Extra indentation given to a brace that starts a substatement.
+ This is in addition to icon-continued-statement-offset.
+ icon-brace-offset
+ Extra indentation for line if it starts with an open brace.
+ icon-brace-imaginary-offset
+ An open brace following other text is treated as if it were
+ this far to the right of the start of its line.
+
+Turning on Icon mode calls the value of the variable icon-mode-hook with no args,
+if that value is non-nil."
+ (interactive)
+ (kill-all-local-variables)
+ (use-local-map icon-mode-map)
+ (setq major-mode 'icon-mode)
+ (setq mode-name "Icon")
+ (setq local-abbrev-table icon-mode-abbrev-table)
+ (set-syntax-table icon-mode-syntax-table)
+ (make-local-variable 'paragraph-start)
+ (setq paragraph-start (concat "^$\\|" page-delimiter))
+ (make-local-variable 'paragraph-separate)
+ (setq paragraph-separate paragraph-start)
+ (make-local-variable 'indent-line-function)
+ (setq indent-line-function 'icon-indent-line)
+ (make-local-variable 'require-final-newline)
+ (setq require-final-newline t)
+ (make-local-variable 'comment-start)
+ (setq comment-start "# ")
+ (make-local-variable 'comment-end)
+ (setq comment-end "")
+ (make-local-variable 'comment-column)
+ (setq comment-column 32)
+ (make-local-variable 'comment-start-skip)
+ (setq comment-start-skip "# *")
+ (make-local-variable 'comment-indent-hook)
+ (setq comment-indent-hook 'icon-comment-indent)
+ (run-hooks 'icon-mode-hook))
+\f
+;; This is used by indent-for-comment
+;; to decide how much to indent a comment in Icon code
+;; based on its context.
+(defun icon-comment-indent ()
+ (if (looking-at "^#")
+ 0
+ (save-excursion
+ (skip-chars-backward " \t")
+ (max (if (bolp) 0 (1+ (current-column)))
+ comment-column))))
+
+(defun electric-icon-brace (arg)
+ "Insert character and correct line's indentation."
+ (interactive "P")
+ (let (insertpos)
+ (if (and (not arg)
+ (eolp)
+ (or (save-excursion
+ (skip-chars-backward " \t")
+ (bolp))
+ (if icon-auto-newline
+ (progn (icon-indent-line) (newline) t)
+ nil)))
+ (progn
+ (insert last-command-char)
+ (icon-indent-line)
+ (if icon-auto-newline
+ (progn
+ (newline)
+ ;; (newline) may have done auto-fill
+ (setq insertpos (- (point) 2))
+ (icon-indent-line)))
+ (save-excursion
+ (if insertpos (goto-char (1+ insertpos)))
+ (delete-char -1))))
+ (if insertpos
+ (save-excursion
+ (goto-char insertpos)
+ (self-insert-command (prefix-numeric-value arg)))
+ (self-insert-command (prefix-numeric-value arg)))))
+\f
+(defun icon-indent-command (&optional whole-exp)
+ (interactive "P")
+ "Indent current line as Icon code, or in some cases insert a tab character.
+If icon-tab-always-indent is non-nil (the default), always indent current line.
+Otherwise, indent the current line only if point is at the left margin
+or in the line's indentation; otherwise insert a tab.
+
+A numeric argument, regardless of its value,
+means indent rigidly all the lines of the expression starting after point
+so that this line becomes properly indented.
+The relative indentation among the lines of the expression are preserved."
+ (if whole-exp
+ ;; If arg, always indent this line as Icon
+ ;; and shift remaining lines of expression the same amount.
+ (let ((shift-amt (icon-indent-line))
+ beg end)
+ (save-excursion
+ (if icon-tab-always-indent
+ (beginning-of-line))
+ (setq beg (point))
+ (forward-sexp 1)
+ (setq end (point))
+ (goto-char beg)
+ (forward-line 1)
+ (setq beg (point)))
+ (if (> end beg)
+ (indent-code-rigidly beg end shift-amt "#")))
+ (if (and (not icon-tab-always-indent)
+ (save-excursion
+ (skip-chars-backward " \t")
+ (not (bolp))))
+ (insert-tab)
+ (icon-indent-line))))
+
+(defun icon-indent-line ()
+ "Indent current line as Icon code.
+Return the amount the indentation changed by."
+ (let ((indent (calculate-icon-indent nil))
+ beg shift-amt
+ (case-fold-search nil)
+ (pos (- (point-max) (point))))
+ (beginning-of-line)
+ (setq beg (point))
+ (cond ((eq indent nil)
+ (setq indent (current-indentation)))
+ ((eq indent t)
+ (setq indent (calculate-icon-indent-within-comment)))
+ ((looking-at "[ \t]*#")
+ (setq indent 0))
+ (t
+ (skip-chars-forward " \t")
+ (if (listp indent) (setq indent (car indent)))
+ (cond ((and (looking-at "else\\b")
+ (not (looking-at "else\\s_")))
+ (setq indent (save-excursion
+ (icon-backward-to-start-of-if)
+ (current-indentation))))
+ ((or (= (following-char) ?})
+ (looking-at "end\\b"))
+ (setq indent (- indent icon-indent-level)))
+ ((= (following-char) ?{)
+ (setq indent (+ indent icon-brace-offset))))))
+ (skip-chars-forward " \t")
+ (setq shift-amt (- indent (current-column)))
+ (if (zerop shift-amt)
+ (if (> (- (point-max) pos) (point))
+ (goto-char (- (point-max) pos)))
+ (delete-region beg (point))
+ (indent-to indent)
+ ;; If initial point was within line's indentation,
+ ;; position after the indentation. Else stay at same point in text.
+ (if (> (- (point-max) pos) (point))
+ (goto-char (- (point-max) pos))))
+ shift-amt))
+
+(defun calculate-icon-indent (&optional parse-start)
+ "Return appropriate indentation for current line as Icon code.
+In usual case returns an integer: the column to indent to.
+Returns nil if line starts inside a string, t if in a comment."
+ (save-excursion
+ (beginning-of-line)
+ (let ((indent-point (point))
+ (case-fold-search nil)
+ state
+ containing-sexp
+ toplevel)
+ (if parse-start
+ (goto-char parse-start)
+ (setq toplevel (beginning-of-icon-defun)))
+ (while (< (point) indent-point)
+ (setq parse-start (point))
+ (setq state (parse-partial-sexp (point) indent-point 0))
+ (setq containing-sexp (car (cdr state))))
+ (cond ((or (nth 3 state) (nth 4 state))
+ ;; return nil or t if should not change this line
+ (nth 4 state))
+ ((and containing-sexp
+ (/= (char-after containing-sexp) ?{))
+ ;; line is expression, not statement:
+ ;; indent to just after the surrounding open.
+ (goto-char (1+ containing-sexp))
+ (current-column))
+ (t
+ (if toplevel
+ ;; Outside any procedures.
+ (progn (icon-backward-to-noncomment (point-min))
+ (if (icon-is-continuation-line)
+ icon-continued-statement-offset 0))
+ ;; Statement level.
+ (if (null containing-sexp)
+ (progn (beginning-of-icon-defun)
+ (setq containing-sexp (point))))
+ (goto-char indent-point)
+ ;; Is it a continuation or a new statement?
+ ;; Find previous non-comment character.
+ (icon-backward-to-noncomment containing-sexp)
+ ;; Now we get the answer.
+ (if (icon-is-continuation-line)
+ ;; This line is continuation of preceding line's statement;
+ ;; indent icon-continued-statement-offset more than the
+ ;; first line of the statement.
+ (progn
+ (icon-backward-to-start-of-continued-exp containing-sexp)
+ (+ icon-continued-statement-offset (current-column)
+ (if (save-excursion (goto-char indent-point)
+ (skip-chars-forward " \t")
+ (eq (following-char) ?{))
+ icon-continued-brace-offset 0)))
+ ;; This line starts a new statement.
+ ;; Position following last unclosed open.
+ (goto-char containing-sexp)
+ ;; Is line first statement after an open-brace?
+ (or
+ ;; If no, find that first statement and indent like it.
+ (save-excursion
+ (if (looking-at "procedure\\s ")
+ (forward-sexp 3)
+ (forward-char 1))
+ (while (progn (skip-chars-forward " \t\n")
+ (looking-at "#"))
+ ;; Skip over comments following openbrace.
+ (forward-line 1))
+ ;; The first following code counts
+ ;; if it is before the line we want to indent.
+ (and (< (point) indent-point)
+ (current-column)))
+ ;; If no previous statement,
+ ;; indent it relative to line brace is on.
+ ;; For open brace in column zero, don't let statement
+ ;; start there too. If icon-indent-level is zero,
+ ;; use icon-brace-offset + icon-continued-statement-offset
+ ;; instead.
+ ;; For open-braces not the first thing in a line,
+ ;; add in icon-brace-imaginary-offset.
+ (+ (if (and (bolp) (zerop icon-indent-level))
+ (+ icon-brace-offset
+ icon-continued-statement-offset)
+ icon-indent-level)
+ ;; Move back over whitespace before the openbrace.
+ ;; If openbrace is not first nonwhite thing on the line,
+ ;; add the icon-brace-imaginary-offset.
+ (progn (skip-chars-backward " \t")
+ (if (bolp) 0 icon-brace-imaginary-offset))
+ ;; Get initial indentation of the line we are on.
+ (current-indentation))))))))))
+
+;; List of words to check for as the last thing on a line.
+;; If cdr is t, next line is a continuation of the same statement,
+;; if cdr is nil, next line starts a new (possibly indented) statement.
+
+(defconst icon-resword-alist
+ '(("by" . t) ("case" . t) ("create") ("do") ("dynamic" . t) ("else")
+ ("every" . t) ("if" . t) ("global" . t) ("initial" . t)
+ ("link" . t) ("local" . t) ("of") ("record" . t) ("repeat" . t)
+ ("static" . t) ("then") ("to" . t) ("until" . t) ("while" . t)))
+
+(defun icon-is-continuation-line ()
+ (let* ((ch (preceding-char))
+ (ch-syntax (char-syntax ch)))
+ (if (eq ch-syntax ?w)
+ (assoc (buffer-substring
+ (progn (forward-word -1) (point))
+ (progn (forward-word 1) (point)))
+ icon-resword-alist)
+ (not (memq ch '(0 ?\; ?\} ?\{ ?\) ?\] ?\" ?\' ?\n))))))
+
+(defun icon-backward-to-noncomment (lim)
+ (let (opoint stop)
+ (while (not stop)
+ (skip-chars-backward " \t\n\f" lim)
+ (setq opoint (point))
+ (beginning-of-line)
+ (if (and (nth 5 (parse-partial-sexp (point) opoint))
+ (< lim (point)))
+ (search-backward "#")
+ (setq stop t)))))
+
+(defun icon-backward-to-start-of-continued-exp (lim)
+ (if (memq (preceding-char) '(?\) ?\]))
+ (forward-sexp -1))
+ (beginning-of-line)
+ (skip-chars-forward " \t")
+ (cond
+ ((<= (point) lim) (goto-char (1+ lim)))
+ ((not (icon-is-continued-line)) 0)
+ ((and (eq (char-syntax (following-char)) ?w)
+ (cdr
+ (assoc (buffer-substring (point)
+ (save-excursion (forward-word 1) (point)))
+ icon-resword-alist))) 0)
+ (t (end-of-line 0) (icon-backward-to-start-of-continued-exp lim))))
+
+(defun icon-is-continued-line ()
+ (save-excursion
+ (end-of-line 0)
+ (icon-is-continuation-line)))
+
+(defun icon-backward-to-start-of-if (&optional limit)
+ "Move to the start of the last ``unbalanced'' if."
+ (or limit (setq limit (save-excursion (beginning-of-icon-defun) (point))))
+ (let ((if-level 1)
+ (case-fold-search nil))
+ (while (not (zerop if-level))
+ (backward-sexp 1)
+ (cond ((looking-at "else\\b")
+ (setq if-level (1+ if-level)))
+ ((looking-at "if\\b")
+ (setq if-level (1- if-level)))
+ ((< (point) limit)
+ (setq if-level 0)
+ (goto-char limit))))))
+\f
+(defun mark-icon-function ()
+ "Put mark at end of Icon function, point at beginning."
+ (interactive)
+ (push-mark (point))
+ (end-of-icon-defun)
+ (push-mark (point))
+ (beginning-of-line 0)
+ (beginning-of-icon-defun))
+
+(defun beginning-of-icon-defun ()
+ "Go to the start of the enclosing procedure; return t if at top level."
+ (interactive)
+ (if (re-search-backward "^procedure\\s \\|^end[ \t\n]" (point-min) 'move)
+ (looking-at "e")
+ t))
+
+(defun end-of-icon-defun ()
+ (interactive)
+ (if (not (bobp)) (forward-char -1))
+ (re-search-forward "\\(\\s \\|^\\)end\\(\\s \\|$\\)" (point-max) 'move)
+ (forward-word -1)
+ (forward-line 1))
+\f
+(defun indent-icon-exp ()
+ "Indent each line of the Icon grouping following point."
+ (interactive)
+ (let ((indent-stack (list nil))
+ (contain-stack (list (point)))
+ (case-fold-search nil)
+ restart outer-loop-done inner-loop-done state ostate
+ this-indent last-sexp
+ at-else at-brace at-do
+ (opoint (point))
+ (next-depth 0))
+ (save-excursion
+ (forward-sexp 1))
+ (save-excursion
+ (setq outer-loop-done nil)
+ (while (and (not (eobp)) (not outer-loop-done))
+ (setq last-depth next-depth)
+ ;; Compute how depth changes over this line
+ ;; plus enough other lines to get to one that
+ ;; does not end inside a comment or string.
+ ;; Meanwhile, do appropriate indentation on comment lines.
+ (setq innerloop-done nil)
+ (while (and (not innerloop-done)
+ (not (and (eobp) (setq outer-loop-done t))))
+ (setq ostate state)
+ (setq state (parse-partial-sexp (point) (progn (end-of-line) (point))
+ nil nil state))
+ (setq next-depth (car state))
+ (if (and (car (cdr (cdr state)))
+ (>= (car (cdr (cdr state))) 0))
+ (setq last-sexp (car (cdr (cdr state)))))
+ (if (or (nth 4 ostate))
+ (icon-indent-line))
+ (if (or (nth 3 state))
+ (forward-line 1)
+ (setq innerloop-done t)))
+ (if (<= next-depth 0)
+ (setq outer-loop-done t))
+ (if outer-loop-done
+ nil
+ (if (/= last-depth next-depth)
+ (setq last-sexp nil))
+ (while (> last-depth next-depth)
+ (setq indent-stack (cdr indent-stack)
+ contain-stack (cdr contain-stack)
+ last-depth (1- last-depth)))
+ (while (< last-depth next-depth)
+ (setq indent-stack (cons nil indent-stack)
+ contain-stack (cons nil contain-stack)
+ last-depth (1+ last-depth)))
+ (if (null (car contain-stack))
+ (setcar contain-stack (or (car (cdr state))
+ (save-excursion (forward-sexp -1)
+ (point)))))
+ (forward-line 1)
+ (skip-chars-forward " \t")
+ (if (eolp)
+ nil
+ (if (and (car indent-stack)
+ (>= (car indent-stack) 0))
+ ;; Line is on an existing nesting level.
+ ;; Lines inside parens are handled specially.
+ (if (/= (char-after (car contain-stack)) ?{)
+ (setq this-indent (car indent-stack))
+ ;; Line is at statement level.
+ ;; Is it a new statement? Is it an else?
+ ;; Find last non-comment character before this line
+ (save-excursion
+ (setq at-else (looking-at "else\\W"))
+ (setq at-brace (= (following-char) ?{))
+ (icon-backward-to-noncomment opoint)
+ (if (icon-is-continuation-line)
+ ;; Preceding line did not end in comma or semi;
+ ;; indent this line icon-continued-statement-offset
+ ;; more than previous.
+ (progn
+ (icon-backward-to-start-of-continued-exp (car contain-stack))
+ (setq this-indent
+ (+ icon-continued-statement-offset (current-column)
+ (if at-brace icon-continued-brace-offset 0))))
+ ;; Preceding line ended in comma or semi;
+ ;; use the standard indent for this level.
+ (if at-else
+ (progn (icon-backward-to-start-of-if opoint)
+ (setq this-indent (current-indentation)))
+ (setq this-indent (car indent-stack))))))
+ ;; Just started a new nesting level.
+ ;; Compute the standard indent for this level.
+ (let ((val (calculate-icon-indent
+ (if (car indent-stack)
+ (- (car indent-stack))))))
+ (setcar indent-stack
+ (setq this-indent val))))
+ ;; Adjust line indentation according to its contents
+ (if (or (= (following-char) ?})
+ (looking-at "end\\b"))
+ (setq this-indent (- this-indent icon-indent-level)))
+ (if (= (following-char) ?{)
+ (setq this-indent (+ this-indent icon-brace-offset)))
+ ;; Put chosen indentation into effect.
+ (or (= (current-column) this-indent)
+ (progn
+ (delete-region (point) (progn (beginning-of-line) (point)))
+ (indent-to this-indent)))
+ ;; Indent any comment following the text.
+ (or (looking-at comment-start-skip)
+ (if (re-search-forward comment-start-skip (save-excursion (end-of-line) (point)) t)
+ (progn (indent-for-comment) (beginning-of-line))))))))))
+
--- /dev/null
+;; Rectangle functions for GNU Emacs.
+;; Copyright (C) 1985 Free Software Foundation, Inc.
+
+;; 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+
+(defun operate-on-rectangle (function start end coerce-tabs)
+ "Call FUNCTION for each line of rectangle with corners at START, END.
+If COERCE-TABS is non-nil, convert multi-column characters
+that span the starting or ending columns on any line
+to multiple spaces before calling FUNCTION.
+FUNCTION is called with three arguments:
+ position of start of segment of this line within the rectangle,
+ number of columns that belong to rectangle but are before that position,
+ number of columns that belong to rectangle but are after point.
+Point is at the end of the segment of this line within the rectangle."
+ (let (startcol startlinepos endcol endlinepos)
+ (save-excursion
+ (goto-char start)
+ (setq startcol (current-column))
+ (beginning-of-line)
+ (setq startlinepos (point)))
+ (save-excursion
+ (goto-char end)
+ (setq endcol (current-column))
+ (forward-line 1)
+ (setq endlinepos (point-marker)))
+ (if (< endcol startcol)
+ (let ((tem startcol))
+ (setq startcol endcol endcol tem)))
+ (if (/= endcol startcol)
+ (save-excursion
+ (goto-char startlinepos)
+ (while (< (point) endlinepos)
+ (let (startpos begextra endextra)
+ (move-to-column startcol)
+ (and coerce-tabs
+ (> (current-column) startcol)
+ (rectangle-coerce-tab startcol))
+ (setq begextra (- (current-column) startcol))
+ (setq startpos (point))
+ (move-to-column endcol)
+ (if (> (current-column) endcol)
+ (if coerce-tabs
+ (rectangle-coerce-tab endcol)
+ (forward-char -1)))
+ (setq endextra (- endcol (current-column)))
+ (if (< begextra 0)
+ (setq endextra (+ endextra begextra)
+ begextra 0))
+ (funcall function startpos begextra endextra))
+ (forward-line 1))))
+ (- endcol startcol)))
+
+(defun delete-rectangle-line (startdelpos ignore ignore)
+ (delete-region startdelpos (point)))
+
+(defun delete-extract-rectangle-line (startdelpos begextra endextra)
+ (save-excursion
+ (extract-rectangle-line startdelpos begextra endextra))
+ (delete-region startdelpos (point)))
+
+(defun extract-rectangle-line (startdelpos begextra endextra)
+ (let ((line (buffer-substring startdelpos (point)))
+ (end (point)))
+ (goto-char startdelpos)
+ (while (search-forward "\t" end t)
+ (let ((width (- (current-column)
+ (save-excursion (forward-char -1)
+ (current-column)))))
+ (setq line (concat (substring line 0 (- (point) end 1))
+ (spaces-string width)
+ (substring line (+ (length line) (- (point) end)))))))
+ (if (or (> begextra 0) (> endextra 0))
+ (setq line (concat (spaces-string begextra)
+ line
+ (spaces-string endextra))))
+ (setq lines (cons line lines))))
+
+(defconst spaces-strings
+ '["" " " " " " " " " " " " " " " " "])
+
+(defun spaces-string (n)
+ (if (<= n 8) (aref spaces-strings n)
+ (let ((val ""))
+ (while (> n 8)
+ (setq val (concat " " val)
+ n (- n 8)))
+ (concat val (aref spaces-strings n)))))
+
+(defun delete-rectangle (start end)
+ "Delete (don't save) text in rectangle with point and mark as corners.
+The same range of columns is deleted in each line
+starting with the line where the region begins
+and ending with the line where the region ends."
+ (interactive "r")
+ (operate-on-rectangle 'delete-rectangle-line start end t))
+
+(defun delete-extract-rectangle (start end)
+ "Delete contents of rectangle and return it as a list of strings.
+Arguments START and END are the corners of the rectangle.
+The value is list of strings, one for each line of the rectangle."
+ (let (lines)
+ (operate-on-rectangle 'delete-extract-rectangle-line
+ start end t)
+ (nreverse lines)))
+
+(defun extract-rectangle (start end)
+ "Return contents of rectangle with corners at START and END.
+Value is list of strings, one for each line of the rectangle."
+ (let (lines)
+ (operate-on-rectangle 'extract-rectangle-line start end nil)
+ (nreverse lines)))
+
+(defvar killed-rectangle nil
+ "Rectangle for yank-rectangle to insert.")
+
+(defun kill-rectangle (start end)
+ "Delete rectangle with corners at point and mark; save as last killed one.
+Calling from program, supply two args START and END, buffer positions.
+But in programs you might prefer to use delete-extract-rectangle."
+ (interactive "r")
+ (setq killed-rectangle (delete-extract-rectangle start end)))
+
+(defun yank-rectangle ()
+ "Yank the last killed rectangle with upper left corner at point."
+ (interactive)
+ (insert-rectangle killed-rectangle))
+
+(defun insert-rectangle (rectangle)
+ "Insert text of RECTANGLE with upper left corner at point.
+RECTANGLE's first line is inserted at point,
+its second line is inserted at a point vertically under point, etc.
+RECTANGLE should be a list of strings."
+ (let ((lines rectangle)
+ (insertcolumn (current-column))
+ (first t))
+ (while lines
+ (or first
+ (progn
+ (forward-line 1)
+ (or (bolp) (insert ?\n))
+ (move-to-column insertcolumn)
+ (if (> (current-column) insertcolumn)
+ (rectangle-coerce-tab insertcolumn))
+ (if (< (current-column) insertcolumn)
+ (indent-to insertcolumn))))
+ (setq first nil)
+ (insert (car lines))
+ (setq lines (cdr lines)))))
+
+(defun open-rectangle (start end)
+ "Blank out rectangle with corners at point and mark, shifting text right.
+The text previously in the region is not overwritten by the blanks,
+but insted winds up to the right of the rectangle."
+ (interactive "r")
+ (operate-on-rectangle 'open-rectangle-line start end nil))
+
+(defun open-rectangle-line (startpos begextra endextra)
+ (let ((column (+ (current-column) begextra endextra)))
+ (goto-char startpos)
+ (let ((ocol (current-column)))
+ (skip-chars-forward " \t")
+ (setq column (+ column (- (current-column) ocol))))
+ (delete-region (point)
+ (progn (skip-chars-backward " \t")
+ (point)))
+ (indent-to column)))
+
+(defun clear-rectangle (start end)
+ "Blank out rectangle with corners at point and mark.
+The text previously in the region is overwritten by the blanks.
+When called from a program, requires two args which specify the corners."
+ (interactive "r")
+ (operate-on-rectangle 'clear-rectangle-line start end t))
+
+(defun clear-rectangle-line (startpos begextra endextra)
+ (skip-chars-forward " \t")
+ (let ((column (+ (current-column) endextra)))
+ (delete-region (point)
+ (progn (goto-char startpos)
+ (skip-chars-backward " \t")
+ (point)))
+ (indent-to column)))
+
+(defun rectangle-coerce-tab (column)
+ (let ((aftercol (current-column))
+ (indent-tabs-mode nil))
+ (delete-char -1)
+ (indent-to aftercol)
+ (backward-char (- aftercol column))))
--- /dev/null
+;; Tab conversion commands for Emacs
+;; Copyright (C) 1985 Free Software Foundation, Inc.
+
+;; 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+
+(defun untabify (start end)
+ "Convert all tabs in region to multiple spaces, preserving columns.
+The variable tab-width controls the action."
+ (interactive "r")
+ (save-excursion
+ (save-restriction
+ (narrow-to-region start end)
+ (goto-char start)
+ (while (search-forward "\t" nil t) ; faster than re-search
+ (let ((start (point))
+ (column (current-column))
+ (indent-tabs-mode nil))
+ (skip-chars-backward "\t")
+ (delete-region start (point))
+ (indent-to column))))))
+
+(defun tabify (start end)
+ "Convert multiple spaces in region to tabs when possible.
+A group of spaces is partially replaced by tabs
+when this can be done without changing the column they end at.
+The variable tab-width controls the action."
+ (interactive "r")
+ (save-excursion
+ (save-restriction
+ (narrow-to-region start end)
+ (goto-char start)
+ (while (re-search-forward "[ \t][ \t][ \t]*" nil t)
+ (let ((column (current-column))
+ (indent-tabs-mode t))
+ (delete-region (match-beginning 0) (point))
+ (indent-to column))))))
--- /dev/null
+;; GNU Emacs major mode for editing nroff source
+;; Copyright (C) 1985, 1986 Free Software Foundation, Inc.
+
+;; 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+
+
+(defvar nroff-mode-abbrev-table nil
+ "Abbrev table used while in nroff mode.")
+
+(defvar nroff-mode-map nil
+ "Major mode keymap for nroff-mode buffers")
+(if (not nroff-mode-map)
+ (progn
+ (setq nroff-mode-map (make-sparse-keymap))
+ (define-key nroff-mode-map "\t" 'tab-to-tab-stop)
+ (define-key nroff-mode-map "\es" 'center-line)
+ (define-key nroff-mode-map "\e?" 'count-text-lines)
+ (define-key nroff-mode-map "\n" 'electric-nroff-newline)
+ (define-key nroff-mode-map "\en" 'forward-text-line)
+ (define-key nroff-mode-map "\ep" 'backward-text-line)))
+
+(defun nroff-mode ()
+ "Major mode for editing text intended for nroff to format.
+\\{nroff-mode-map}
+Turning on Nroff mode runs text-mode-hook, then nroff-mode-hook.
+Also, try nroff-electric-mode, for automatically inserting
+closing requests for requests that are used in matched pairs."
+ (interactive)
+ (kill-all-local-variables)
+ (use-local-map nroff-mode-map)
+ (setq mode-name "Nroff")
+ (setq major-mode 'nroff-mode)
+ (set-syntax-table text-mode-syntax-table)
+ (setq local-abbrev-table nroff-mode-abbrev-table)
+ (make-local-variable 'nroff-electric-mode)
+ ;; now define a bunch of variables for use by commands in this mode
+ (make-local-variable 'page-delimiter)
+ (setq page-delimiter "^\\.\\(bp\\|SK\\|OP\\)")
+ (make-local-variable 'paragraph-start)
+ (setq paragraph-start (concat "^[.']\\|" paragraph-start))
+ (make-local-variable 'paragraph-separate)
+ (setq paragraph-separate (concat "^[.']\\|" paragraph-separate))
+ ;; comment syntax added by mit-erl!gildea 18 Apr 86
+ (make-local-variable 'comment-start)
+ (setq comment-start "\\\" ")
+ (make-local-variable 'comment-start-skip)
+ (setq comment-start-skip "\\\\\"[ \t]*")
+ (make-local-variable 'comment-column)
+ (setq comment-column 24)
+ (make-local-variable 'comment-indent-hook)
+ (setq comment-indent-hook 'nroff-comment-indent)
+ (run-hooks 'text-mode-hook 'nroff-mode-hook))
+
+;;; Compute how much to indent a comment in nroff/troff source.
+;;; By mit-erl!gildea April 86
+(defun nroff-comment-indent ()
+ "Compute indent for an nroff/troff comment.
+Puts a full-stop before comments on a line by themselves."
+ (let ((pt (point)))
+ (unwind-protect
+ (progn
+ (skip-chars-backward " \t")
+ (if (bolp)
+ (progn
+ (setq pt (1+ pt))
+ (insert ?.)
+ 1)
+ (if (save-excursion
+ (backward-char 1)
+ (looking-at "^[.']"))
+ 1
+ (max comment-column
+ (* 8 (/ (+ (current-column)
+ 9) 8)))))) ; add 9 to ensure at least two blanks
+ (goto-char pt))))
+
+(defun count-text-lines (start end &optional print)
+ "Count lines in region, except for nroff request lines.
+All lines not starting with a period are counted up.
+Interactively, print result in echo area.
+Noninteractively, return number of non-request lines from START to END."
+ (interactive "r\np")
+ (if print
+ (message "Region has %d text lines" (count-text-lines start end))
+ (save-excursion
+ (save-restriction
+ (narrow-to-region start end)
+ (goto-char (point-min))
+ (- (buffer-size) (forward-text-line (buffer-size)))))))
+
+(defun forward-text-line (&optional cnt)
+ "Go forward one nroff text line, skipping lines of nroff requests.
+An argument is a repeat count; if negative, move backward."
+ (interactive "p")
+ (if (not cnt) (setq cnt 1))
+ (while (and (> cnt 0) (not (eobp)))
+ (forward-line 1)
+ (while (and (not (eobp)) (looking-at "[.']."))
+ (forward-line 1))
+ (setq cnt (- cnt 1)))
+ (while (and (< cnt 0) (not (bobp)))
+ (forward-line -1)
+ (while (and (not (bobp))
+ (looking-at "[.']."))
+ (forward-line -1))
+ (setq cnt (+ cnt 1)))
+ cnt)
+
+(defun backward-text-line (&optional cnt)
+ "Go backward one nroff text line, skipping lines of nroff requests.
+An argument is a repeat count; negative means move forward."
+ (interactive "p")
+ (forward-text-line (- cnt)))
+
+(defconst nroff-brace-table
+ '((".(b" . ".)b")
+ (".(l" . ".)l")
+ (".(q" . ".)q")
+ (".(c" . ".)c")
+ (".(x" . ".)x")
+ (".(z" . ".)z")
+ (".(d" . ".)d")
+ (".(f" . ".)f")
+ (".LG" . ".NL")
+ (".SM" . ".NL")
+ (".LD" . ".DE")
+ (".CD" . ".DE")
+ (".BD" . ".DE")
+ (".DS" . ".DE")
+ (".DF" . ".DE")
+ (".FS" . ".FE")
+ (".KS" . ".KE")
+ (".KF" . ".KE")
+ (".LB" . ".LE")
+ (".AL" . ".LE")
+ (".BL" . ".LE")
+ (".DL" . ".LE")
+ (".ML" . ".LE")
+ (".RL" . ".LE")
+ (".VL" . ".LE")
+ (".RS" . ".RE")
+ (".TS" . ".TE")
+ (".EQ" . ".EN")
+ (".PS" . ".PE")
+ (".BS" . ".BE")
+ (".G1" . ".G2") ; grap
+ (".na" . ".ad b")
+ (".nf" . ".fi")
+ (".de" . "..")))
+
+(defun electric-nroff-newline (arg)
+ "Insert newline for nroff mode; special if electric-nroff mode.
+In electric-nroff-mode, if ending a line containing an nroff opening request,
+automatically inserts the matching closing request after point."
+ (interactive "P")
+ (let ((completion (save-excursion
+ (beginning-of-line)
+ (and (null arg)
+ nroff-electric-mode
+ (<= (point) (- (point-max) 3))
+ (cdr (assoc (buffer-substring (point)
+ (+ 3 (point)))
+ nroff-brace-table)))))
+ (needs-nl (not (looking-at "[ \t]*$"))))
+ (if (null completion)
+ (newline (prefix-numeric-value arg))
+ (save-excursion
+ (insert "\n\n" completion)
+ (if needs-nl (insert "\n")))
+ (forward-char 1))))
+
+(defun electric-nroff-mode (&optional arg)
+ "Toggle nroff-electric-newline minor mode
+Nroff-electric-newline forces emacs to check for an nroff
+request at the beginning of the line, and insert the
+matching closing request if necessary.
+This command toggles that mode (off->on, on->off),
+with an argument, turns it on iff arg is positive, otherwise off."
+ (interactive "P")
+ (or (eq major-mode 'nroff-mode) (error "Must be in nroff mode"))
+ (or (assq 'nroff-electric-mode minor-mode-alist)
+ (setq minor-mode-alist (append minor-mode-alist
+ (list '(nroff-electric-mode
+ " Electric")))))
+ (setq nroff-electric-mode
+ (cond ((null arg) (null nroff-electric-mode))
+ (t (> (prefix-numeric-value arg) 0)))))
+
--- /dev/null
+;; Page motion commands for emacs.
+;; Copyright (C) 1985 Free Software Foundation, Inc.
+
+;; 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+
+(defun forward-page (&optional count)
+ "Move forward to page boundary. With arg, repeat, or go back if negative.
+A page boundary is any line whose beginning matches the regexp page-delimiter."
+ (interactive "p")
+ (or count (setq count 1))
+ (while (and (> count 0) (not (eobp)))
+ (if (re-search-forward page-delimiter nil t)
+ nil
+ (goto-char (point-max)))
+ (setq count (1- count)))
+ (while (and (< count 0) (not (bobp)))
+ (forward-char -1)
+ (if (re-search-backward page-delimiter nil t)
+ (goto-char (match-end 0))
+ (goto-char (point-min)))
+ (setq count (1+ count))))
+
+(defun backward-page (&optional count)
+ "Move backward to page boundary. With arg, repeat, or go fwd if negative.
+A page boundary is any line whose beginning matches the regexp page-delimiter."
+ (interactive "p")
+ (or count (setq count 1))
+ (forward-page (- count)))
+
+(defun mark-page (&optional arg)
+ "Put mark at end of page, point at beginning.
+A numeric arg specifies to move forward or backward by that many pages,
+thus marking a page other than the one point was originally in."
+ (interactive "P")
+ (setq arg (if arg (prefix-numeric-value arg) 0))
+ (if (> arg 0)
+ (forward-page arg)
+ (if (< arg 0)
+ (forward-page (1- arg))))
+ (forward-page)
+ (push-mark nil t)
+ (forward-page -1))
+
+(defun narrow-to-page (&optional arg)
+ "Make text outside current page invisible.
+A numeric arg specifies to move forward or backward by that many pages,
+thus showing a page other than the one point was originally in."
+ (interactive "P")
+ (setq arg (if arg (prefix-numeric-value arg) 0))
+ (save-excursion
+ (widen)
+ (if (> arg 0)
+ (forward-page arg)
+ (if (< arg 0)
+ (forward-page (1- arg))))
+ ;; Find the end of the page.
+ (forward-page)
+ ;; If we stopped due to end of buffer, stay there.
+ ;; If we stopped after a page delimiter, put end of restriction
+ ;; at the beginning of that line.
+ (if (save-excursion (beginning-of-line)
+ (looking-at page-delimiter))
+ (beginning-of-line))
+ (narrow-to-region (point)
+ (progn
+ ;; Find the top of the page.
+ (forward-page -1)
+ ;; If we found beginning of buffer, stay there.
+ ;; If extra text follows page delimiter on same line,
+ ;; include it.
+ ;; Otherwise, show text starting with following line.
+ (if (and (eolp) (not (bobp)))
+ (forward-line 1))
+ (point)))))
+
+(defun count-lines-page ()
+ "Report number of lines on current page, and how many are before or after point."
+ (interactive)
+ (save-excursion
+ (let ((opoint (point)) beg end
+ total before after)
+ (forward-page)
+ (beginning-of-line)
+ (or (looking-at page-delimiter)
+ (end-of-line))
+ (setq end (point))
+ (backward-page)
+ (setq beg (point))
+ (setq total (count-lines beg end)
+ before (count-lines beg opoint)
+ after (count-lines opoint end))
+ (message "Page has %d lines (%d + %d)" total before after))))
+
+(defun what-page ()
+ "Print page and line number of point."
+ (interactive)
+ (save-restriction
+ (widen)
+ (save-excursion
+ (beginning-of-line)
+ (let ((count 1)
+ (opoint (point)))
+ (goto-char 1)
+ (while (re-search-forward page-delimiter opoint t)
+ (setq count (1+ count)))
+ (message "Page %d, line %d"
+ count
+ (1+ (count-lines (point) opoint)))))))
--- /dev/null
+;; Paragraph and sentence parsing.
+;; Copyright (C) 1985 Free Software Foundation, Inc.
+
+;; 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+
+(defvar paragraph-ignore-fill-prefix nil
+ "Non-nil means the paragraph commands are not affected by fill-prefix.
+This is desirable in modes where blank lines are the paragraph delimiters.")
+
+(defun forward-paragraph (&optional arg)
+ "Move forward to end of paragraph.
+With arg N, do it N times; negative arg -N means move forward N paragraphs.
+
+A line which `paragraph-start' matches either separates paragraphs
+\(if `paragraph-separate' matches it also) or is the first line of a paragraph.
+A paragraph end is the beginning of a line which is not part of the paragraph
+to which the end of the previous line belongs, or the end of the buffer."
+ (interactive "p")
+ (or arg (setq arg 1))
+ (let* ((fill-prefix-regexp
+ (and fill-prefix (not (equal fill-prefix ""))
+ (not paragraph-ignore-fill-prefix)
+ (regexp-quote fill-prefix)))
+ (paragraph-separate
+ (if fill-prefix-regexp
+ (concat paragraph-separate "\\|^"
+ fill-prefix-regexp "[ \t]*$")
+ paragraph-separate)))
+ (while (< arg 0)
+ (if (and (not (looking-at paragraph-separate))
+ (re-search-backward "^\n" (max (1- (point)) (point-min)) t))
+ nil
+ (forward-char -1) (beginning-of-line)
+ (while (and (not (bobp)) (looking-at paragraph-separate))
+ (forward-line -1))
+ (end-of-line)
+ ;; Search back for line that starts or separates paragraphs.
+ (if (if fill-prefix-regexp
+ ;; There is a fill prefix; it overrides paragraph-start.
+ (progn
+ (while (progn (beginning-of-line)
+ (and (not (bobp))
+ (not (looking-at paragraph-separate))
+ (looking-at fill-prefix-regexp)))
+ (forward-line -1))
+ (not (bobp)))
+ (re-search-backward paragraph-start nil t))
+ ;; Found one.
+ (progn
+ (while (and (not (eobp)) (looking-at paragraph-separate))
+ (forward-line 1))
+ (if (eq (char-after (- (point) 2)) ?\n)
+ (forward-line -1)))
+ ;; No starter or separator line => use buffer beg.
+ (goto-char (point-min))))
+ (setq arg (1+ arg)))
+ (while (> arg 0)
+ (beginning-of-line)
+ (while (prog1 (and (not (eobp))
+ (looking-at paragraph-separate))
+ (forward-line 1)))
+ (if fill-prefix-regexp
+ ;; There is a fill prefix; it overrides paragraph-start.
+ (while (and (not (eobp))
+ (not (looking-at paragraph-separate))
+ (looking-at fill-prefix-regexp))
+ (forward-line 1))
+ (if (re-search-forward paragraph-start nil t)
+ (goto-char (match-beginning 0))
+ (goto-char (point-max))))
+ (setq arg (1- arg)))))
+
+(defun backward-paragraph (&optional arg)
+ "Move backward to start of paragraph.
+With arg N, do it N times; negative arg -N means move forward N paragraphs.
+
+A paragraph start is the beginning of a line which is a first-line-of-paragraph
+or which is ordinary text and follows a paragraph-separating line; except:
+if the first real line of a paragraph is preceded by a blank line,
+the paragraph starts at that blank line.
+See forward-paragraph for more information."
+ (interactive "p")
+ (or arg (setq arg 1))
+ (forward-paragraph (- arg)))
+
+(defun mark-paragraph ()
+ "Put point at beginning of this paragraph, mark at end.
+The paragraph marked is the one that contains point or follows point."
+ (interactive)
+ (forward-paragraph 1)
+ (push-mark nil t)
+ (backward-paragraph 1))
+
+(defun kill-paragraph (arg)
+ "Kill forward to end of paragraph.
+With arg N, kill forward to Nth end of paragraph;
+negative arg -N means kill backward to Nth start of paragraph."
+ (interactive "*p")
+ (kill-region (point) (progn (forward-paragraph arg) (point))))
+
+(defun backward-kill-paragraph (arg)
+ "Kill back to start of paragraph.
+With arg N, kill back to Nth start of paragraph;
+negative arg -N means kill forward to Nth end of paragraph."
+ (interactive "*p")
+ (kill-region (point) (progn (backward-paragraph arg) (point))))
+
+(defun transpose-paragraphs (arg)
+ "Interchange this (or next) paragraph with previous one."
+ (interactive "*p")
+ (transpose-subr 'forward-paragraph arg))
+
+(defun start-of-paragraph-text ()
+ (let ((opoint (point)) npoint)
+ (forward-paragraph -1)
+ (setq npoint (point))
+ (skip-chars-forward " \t\n")
+ (if (>= (point) opoint)
+ (progn
+ (goto-char npoint)
+ (if (> npoint (point-min))
+ (start-of-paragraph-text))))))
+
+(defun end-of-paragraph-text ()
+ (let ((opoint (point)))
+ (forward-paragraph 1)
+ (if (eq (preceding-char) ?\n) (forward-char -1))
+ (if (<= (point) opoint)
+ (progn
+ (forward-char 1)
+ (if (< (point) (point-max))
+ (end-of-paragraph-text))))))
+
+(defun forward-sentence (&optional arg)
+ "Move forward to next sentence-end. With argument, repeat.
+With negative argument, move backward repeatedly to sentence-beginning.
+
+The variable `sentence-end' is a regular expression that matches ends
+of sentences. Also, every paragraph boundary terminates sentences as
+well."
+ (interactive "p")
+ (or arg (setq arg 1))
+ (while (< arg 0)
+ (let ((par-beg (save-excursion (start-of-paragraph-text) (point))))
+ (if (re-search-backward (concat sentence-end "[^ \t\n]") par-beg t)
+ (goto-char (1- (match-end 0)))
+ (goto-char par-beg)))
+ (setq arg (1+ arg)))
+ (while (> arg 0)
+ (let ((par-end (save-excursion (end-of-paragraph-text) (point))))
+ (if (re-search-forward sentence-end par-end t)
+ (skip-chars-backward " \t\n")
+ (goto-char par-end)))
+ (setq arg (1- arg))))
+
+(defun backward-sentence (&optional arg)
+ "Move backward to start of sentence. With arg, do it arg times.
+See forward-sentence for more information."
+ (interactive "p")
+ (or arg (setq arg 1))
+ (forward-sentence (- arg)))
+
+(defun kill-sentence (&optional arg)
+ "Kill from point to end of sentence.
+With arg, repeat; negative arg -N means kill back to Nth start of sentence."
+ (interactive "*p")
+ (let ((beg (point)))
+ (forward-sentence arg)
+ (kill-region beg (point))))
+
+(defun backward-kill-sentence (&optional arg)
+ "Kill back from point to start of sentence.
+With arg, repeat, or kill forward to Nth end of sentence if negative arg -N."
+ (interactive "*p")
+ (let ((beg (point)))
+ (backward-sentence arg)
+ (kill-region beg (point))))
+
+(defun mark-end-of-sentence (arg)
+ "Put mark at end of sentence. Arg works as in forward-sentence."
+ (interactive "p")
+ (push-mark
+ (save-excursion
+ (forward-sentence arg)
+ (point))))
+
+(defun transpose-sentences (arg)
+ "Interchange this (next) and previous sentence."
+ (interactive "*p")
+ (transpose-subr 'forward-sentence arg))
--- /dev/null
+;; Convert refer-style bibliographic entries to ones usable by latex bib
+;; Copyright (C) 1989 Free Software Foundation, Inc.
+
+;; 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;; Use: from a buffer containing the refer-style bibliography,
+;; M-x r2b-convert-buffer
+;; Program will prompt for an output buffer name, and will log
+;; warnings during the conversion process in the buffer *Log*.
+
+; HISTORY
+; 9/88, created
+; modified 1/19/89, allow books with editor but no author;
+; added %O ordering field;
+; appended illegal multiple fields, instead of
+; discarding;
+; added rule, a tech report whose %R number
+; contains "ISBN" is really a book
+; added rule, anything with an editor is a book
+; or a proceedings
+; added 'manual type, for items with institution
+; but no author or editor
+; fixed bug so trailing blanks are trimmed
+; added 'proceedings type
+; used "organization" field for proceedings
+; modified 2/16/89, updated help messages
+; modified 2/23/89, include capitalize stop words in r2b stop words,
+; fixed problems with contractions (e.g. it's),
+; caught multiple stop words in a row
+; modified 3/1/89, fixed capitialize-title for first words all caps
+; modified 3/15/89, allow use of " to delimit fields
+; modified 4/18/89, properly "quote" special characters on output
+(provide 'refer-to-bibtex)
+;**********************************************************
+; User Parameters
+
+(defvar r2b-trace-on nil "*trace conversion")
+
+(defvar r2b-journal-abbrevs
+ '(
+ )
+ " Abbreviation list for journal names.
+If the car of an element matches a journal name exactly, it is replaced by
+the cadr when output. Braces must be included if replacement is a
+{string}, but not if replacement is a bibtex abbreviation. The cadr
+may be eliminated if is exactly the same as the car.
+ Because titles are capitalized before matching, the abbreviation
+for the journal name should be listed as beginning with a capital
+letter, even if it really doesn't.
+ For example, a value of '((\"Aij\" \"{Artificial Intelligence}\")
+(\"Ijcai81\" \"ijcai7\")) would expand Aij to the text string
+\"Artificial Intelligence\", but would replace Ijcai81 with the
+BibTeX macro \"ijcai7\".")
+
+(defvar r2b-booktitle-abbrevs
+ '(
+ )
+ " Abbreviation list for book and proceedings names. If the car of
+an element matches a title or booktitle exactly, it is replaced by
+the cadr when output. Braces must be included if replacement is
+a {string}, but not if replacement is a bibtex abbreviation. The cadr
+may be eliminated if is exactly the same as the car.
+ Because titles are capitalized before matching, the abbreviated title
+should be listed as beginning with a capital letter, even if it doesn't.
+ For example, a value of '((\"Aij\" \"{Artificial Intelligence}\")
+(\"Ijcai81\" \"ijcai7\")) would expand Aij to the text string
+\"Artificial Intelligence\", but would replace Ijcai81 with the
+BibTeX macro \"ijcai7\".")
+
+(defvar r2b-proceedings-list
+ '()
+ " Assoc list of books or journals which are really conference proceedings,
+but whose name and whose abbrev expansion (as defined in r2b-journal-abbrevs
+and r2b-booktitle-abbrevs) does not contain the words 'conference' or
+'proceedings'. (Those cases are handled automatically.)
+The entry must match the given data exactly.
+ Because titles are capitalized before matching, the items in this list
+should begin with a capital letter.
+ For example, suppose the title \"Ijcai81\" is used for the proceedings of
+a conference, and it's expansion is the BibTeX macro \"ijcai7\". Then
+r2b-proceedings-list should be '((\"Ijcai81\") ...). If instead its
+expansion were \"Proceedings of the Seventh International Conference
+on Artificial Intelligence\", then you would NOT need to include Ijcai81
+in r2b-proceedings-list (although it wouldn't cause an error).")
+
+(defvar r2b-additional-stop-words
+ "Some\\|What"
+ "Words other than the capitialize-title-stop-words
+which are not to be used to build the citation key")
+
+
+(defvar r2b-delimit-with-quote
+ t
+ "*If true, then use \" to delimit fields, otherwise use braces")
+
+;**********************************************************
+; Utility Functions
+
+(defvar capitalize-title-stop-words
+ (concat
+ "the\\|and\\|of\\|is\\|a\\|an\\|of\\|for\\|in\\|to\\|in\\|on\\|at\\|"
+ "by\\|with\\|that\\|its")
+ "Words not to be capitialized in a title (unless they are the first
+word in the title)")
+
+(defvar capitalize-title-stop-regexp
+ (concat "\\(" capitalize-title-stop-words "\\)\\(\\b\\|'\\)"))
+
+(defun capitalize-title-region (begin end)
+ "Like capitalize-region, but don't capitalize stop words, except the first"
+ (interactive "r")
+ (let ((case-fold-search nil) (orig-syntax-table (syntax-table)))
+ (unwind-protect
+ (save-restriction
+ (set-syntax-table text-mode-syntax-table)
+ (narrow-to-region begin end)
+ (goto-char (point-min))
+ (if (looking-at "[A-Z][a-z]*[A-Z]")
+ (forward-word 1)
+ (capitalize-word 1))
+ (while (re-search-forward "\\<" nil t)
+ (if (looking-at "[A-Z][a-z]*[A-Z]")
+ (forward-word 1)
+ (if (let ((case-fold-search t))
+ (looking-at capitalize-title-stop-regexp))
+ (downcase-word 1)
+ (capitalize-word 1)))
+ ))
+ (set-syntax-table orig-syntax-table))))
+
+
+(defun capitalize-title (s)
+ "Like capitalize, but don't capitalize stop words, except the first"
+ (save-excursion
+ (set-buffer (get-buffer-create "$$$Scratch$$$"))
+ (erase-buffer)
+ (insert s)
+ (capitalize-title-region (point-min) (point-max))
+ (buffer-string)))
+
+;*********************************************************
+(defun r2b-reset ()
+ "unbind defvars, for debugging"
+ (interactive)
+ (makunbound 'r2b-journal-abbrevs)
+ (makunbound 'r2b-booktitle-abbrevs)
+ (makunbound 'r2b-proceedings-list)
+ (makunbound 'capitalize-title-stop-words)
+ (makunbound 'capitalize-title-stop-regexp)
+ (makunbound 'r2b-additional-stop-words)
+ (makunbound 'r2b-stop-regexp)
+ )
+
+(defvar r2b-stop-regexp
+ (concat "\\`\\(\\("
+ r2b-additional-stop-words "\\|" capitalize-title-stop-words
+ "\\)\\('\\w*\\)?\\W+\\)*\\([A-Z0-9]+\\)"))
+
+
+(defun r2b-trace (&rest args)
+ (if r2b-trace-on
+ (progn
+ (apply (function message) args)
+ (sit-for 0)
+ )))
+
+(defun r2b-match (exp)
+ "returns string matched in current buffer"
+ (buffer-substring (match-beginning exp) (match-end exp)))
+
+(defvar r2b-out-buf-name "*Out*" "*output from refer-to-bibtex" )
+(defvar r2b-log-name "*Log*" "*logs errors from refer-to-bibtex" )
+(defvar r2b-in-buf nil)
+(defvar r2b-out-buf nil)
+(defvar r2b-log nil)
+
+(defvar r2b-error-found nil)
+
+(setq r2b-variables '(
+ r2b-error-found
+ r2bv-author
+ r2bv-primary-author
+ r2bv-date
+ r2bv-year
+ r2bv-decade
+ r2bv-month
+ r2bv-title
+ r2bv-title-first-word
+ r2bv-editor
+ r2bv-annote
+ r2bv-tr
+ r2bv-address
+ r2bv-institution
+ r2bv-keywords
+ r2bv-booktitle
+ r2bv-journal
+ r2bv-volume
+ r2bv-number
+ r2bv-pages
+ r2bv-booktitle
+ r2bv-kn
+ r2bv-publisher
+ r2bv-organization
+ r2bv-school
+ r2bv-type
+ r2bv-where
+ r2bv-note
+ r2bv-ordering
+ ))
+
+(defun r2b-clear-variables ()
+ "set all global vars used by r2b to nil"
+ (let ((vars r2b-variables))
+ (while vars
+ (set (car vars) nil)
+ (setq vars (cdr vars)))
+ ))
+
+(defun r2b-warning (&rest args)
+ (setq r2b-error-found t)
+ (princ (apply (function format) args) r2b-log)
+ (princ "\n" r2b-log)
+ (princ "\n" r2b-out-buf)
+ (princ "% " r2b-out-buf)
+ (princ (apply (function format) args) r2b-out-buf)
+ )
+
+(defun r2b-get-field (var field &optional unique required capitalize)
+ "Set VAR to string value of FIELD, if any. If none, VAR is set to
+nil. If multiple fields appear, then separate values with the
+'\\nand\\t\\t', unless UNIQUE is non-nil, in which case log a warning
+and just concatenate the values. Trim off leading blanks and tabs on
+first line, and trailing blanks and tabs of every line. Log a warning
+and set VAR to the empty string if REQUIRED is true. Capitalize as a
+title if CAPITALIZE is true. Returns value of VAR."
+ (let (item val (not-past-end t))
+ (r2b-trace "snarfing %s" field)
+ (goto-char (point-min))
+ (while (and not-past-end
+ (re-search-forward
+ (concat "^" field "\\b[ \t]*\\(.*[^ \t\n]\\)[ \t]*") nil t))
+ (setq item (r2b-match 1))
+ (while (and (setq not-past-end (zerop (forward-line 1)))
+ (not (looking-at "[ \t]*$\\|%")))
+ (looking-at "\\(.*[^ \t\n]\\)[ \t]*$")
+ (setq item (concat item "\n" (r2b-match 1)))
+ )
+ (if (null val)
+ (setq val item)
+ (if unique
+ (progn
+ (r2b-warning "*Illegal multiple field %s %s" field item)
+ (setq val (concat val "\n" item))
+ )
+ (setq val (concat val "\n\t\tand " item))
+ )
+ )
+ )
+ (if (and val capitalize)
+ (setq val (capitalize-title val)))
+ (set var val)
+ (if (and (null val) required)
+ (r2b-require var))
+ ))
+
+(defun r2b-set-match (var n regexp string )
+ "set VAR to the Nth subpattern in REGEXP matched by STRING, or nil if none"
+ (set var
+ (if (and (stringp string) (string-match regexp string))
+ (substring string (match-beginning n) (match-end n))
+ nil)
+ )
+ )
+
+(defvar r2b-month-abbrevs
+ '(("jan") ("feb") ("mar") ("apr") ("may") ("jun") ("jul") ("aug")
+ ("sep") ("oct") ("nov") ("dec")))
+
+(defun r2b-convert-month ()
+ "Try to convert r2bv-month to a standard 3 letter name"
+ (if r2bv-month
+ (let ((months r2b-month-abbrevs))
+ (if (string-match "[^0-9]" r2bv-month)
+ (progn
+ (while (and months (not (string-match (car (car months))
+ r2bv-month)))
+ (setq months (cdr months)))
+ (if months
+ (setq r2bv-month (car (car months)))))
+ (progn
+ (setq months (car (read-from-string r2bv-month)))
+ (if (and (numberp months)
+ (> months 0)
+ (< months 13))
+ (setq r2bv-month (car (nth months r2b-month-abbrevs)))
+ (progn
+ (r2b-warning "* Ridiculous month")
+ (setq r2bv-month nil))
+ ))
+ ))
+ )
+ )
+
+(defun r2b-snarf-input ()
+ "parse buffer into global variables"
+ (let ((case-fold-search t))
+ (r2b-trace "snarfing...")
+ (sit-for 0)
+ (set-buffer r2b-in-buf)
+ (goto-char (point-min))
+ (princ " " r2b-log)
+ (princ (buffer-substring (point) (progn (end-of-line) (point))) r2b-log)
+ (terpri r2b-log)
+
+ (r2b-get-field 'r2bv-author "%A")
+ (r2b-get-field 'r2bv-editor "%E")
+ (cond
+ (r2bv-author
+ (r2b-set-match 'r2bv-primary-author 1
+ "\\b\\(\\w+\\)[ \t]*\\($\\|,\\)" r2bv-author)
+ )
+ (r2bv-editor
+ (r2b-set-match 'r2bv-primary-author 1
+ "\\b\\(\\w+\\)[ \t]*\\($\\|,\\)" r2bv-editor)
+ )
+ (t
+ (setq r2bv-primary-author "")
+ )
+ )
+
+ (r2b-get-field 'r2bv-date "%D" t t)
+ (r2b-set-match 'r2bv-year 0 "[12][0-9][0-9][0-9]" r2bv-date)
+ (and (null r2bv-year)
+ (r2b-set-match 'r2bv-year 1 "[^0-9]\\([0-9][0-9]\\)$" r2bv-date)
+ (setq r2bv-year (concat "19" r2bv-year)))
+ (r2b-set-match 'r2bv-decade 1 "..\\(..\\)" r2bv-year)
+ (r2b-set-match 'r2bv-month 0
+ "[0-9]+/\\|[a-zA-Z]+" r2bv-date)
+ (if (and (stringp r2bv-month) (string-match "\\(.*\\)/$" r2bv-month))
+ (setq r2bv-month (substring r2bv-month 0 (match-end 1))))
+ (r2b-convert-month)
+
+ (r2b-get-field 'r2bv-title "%T" t t t)
+ (r2b-set-match 'r2bv-title-first-word 4
+ r2b-stop-regexp
+ r2bv-title)
+
+ (r2b-get-field 'r2bv-annote "%X" t )
+ (r2b-get-field 'r2bv-tr "%R" t)
+ (r2b-get-field 'r2bv-address "%C" t)
+ (r2b-get-field 'r2bv-institution "%I" t)
+ (r2b-get-field 'r2bv-keywords "%K")
+ (r2b-get-field 'r2bv-booktitle "%B" t nil t)
+ (r2b-get-field 'r2bv-journal "%J" t nil t)
+ (r2b-get-field 'r2bv-volume "%V" t)
+ (r2b-get-field 'r2bv-number "%N" t)
+ (r2b-get-field 'r2bv-pages "%P" t)
+ (r2b-get-field 'r2bv-where "%W" t)
+ (r2b-get-field 'r2bv-ordering "%O" t)
+ )
+ )
+
+
+(defun r2b-put-field (field data &optional abbrevs)
+ "print bibtex FIELD = {DATA} if DATA not null; precede
+with a comma and newline; if ABBREVS list is given, then
+try to replace the {DATA} with an abbreviation"
+ (if data
+ (let (match nodelim multi-line index)
+ (cond
+ ((and abbrevs (setq match (assoc data abbrevs)))
+ (if (null (cdr match))
+ (setq data (car match))
+ (setq data (car (cdr match))))
+ (setq nodelim t))
+ ((and (not (equal data ""))
+ (not (string-match "[^0-9]" data)))
+ (setq nodelim t))
+ (t
+ (setq index 0)
+ (while (string-match "[\\~^]" data index)
+ (setq data (concat (substring data 0 (match-beginning 0))
+ "\\verb+"
+ (substring data (match-beginning 0) (match-end 0))
+ "+"
+ (substring data (match-end 0))))
+ (setq index (+ (match-end 0) 7)))
+ (setq index 0)
+ (while (string-match "[$&%#_{}]" data index)
+ (setq data (concat (substring data 0 (match-beginning 0))
+ "\\"
+ (substring data (match-beginning 0))))
+ (setq index (+ (match-end 0) 1)))
+ (setq index 0)
+ (if r2b-delimit-with-quote
+ (while (string-match "\"" data index)
+ (setq data (concat (substring data 0 (match-beginning 0))
+ "{\"}"
+ (substring data (match-end 0))))
+ (setq index (+ (match-end 0) 2))))
+ ))
+ (princ ", \n ")
+ (princ field)
+ (princ " =\t")
+ (if (not nodelim)
+ (if r2b-delimit-with-quote
+ (princ "\"")
+ (princ "{")))
+ (string-match ".*" data)
+ (if (> (match-end 0) 59)
+ (princ "\n"))
+ (princ data)
+ (if (not nodelim)
+ (if r2b-delimit-with-quote
+ (princ "\"")
+ (princ "}")))
+ )
+ ))
+
+
+(defun r2b-require (vars)
+ "If any of VARS is null, set to empty string and log error"
+ (cond
+ ((null vars))
+ ((listp vars) (r2b-require (car vars)) (r2b-require (cdr vars)))
+ (t
+ (if (null (symbol-value vars))
+ (progn
+ (r2b-warning "*Missing value for field %s" vars)
+ (set vars "")
+ )))
+ )
+ )
+
+
+(defmacro r2b-moveq (new old)
+ "set NEW to OLD and set OLD to nil"
+ (list 'progn (list 'setq new old) (list 'setq old 'nil)))
+
+(defun r2b-isa-proceedings (name)
+ "return t if NAME is the name of proceedings"
+ (and
+ name
+ (or
+ (string-match "proceedings\\|conference" name)
+ (assoc name r2b-proceedings-list)
+ (let ((match (assoc name r2b-booktitle-abbrevs)))
+ (and match
+ (string-match "proceedings\\|conference" (car (cdr match)))))
+ )))
+
+(defun r2b-isa-university (name)
+ "return t if NAME is a university or similar organization,
+but not a publisher"
+ (and
+ name
+ (string-match "university" name)
+ (not (string-match "press" name))
+
+ ))
+
+(defun r2b-barf-output ()
+ "generate bibtex based on global variables"
+ (let ((standard-output r2b-out-buf) (case-fold-search t) match)
+
+ (r2b-trace "...barfing")
+ (sit-for 0)
+ (set-buffer r2b-out-buf)
+
+ (setq r2bv-kn (concat r2bv-primary-author r2bv-decade
+ r2bv-title-first-word))
+
+ (setq r2bv-entry-kind
+ (cond
+ ((r2b-isa-proceedings r2bv-journal)
+ (r2b-moveq r2bv-booktitle r2bv-journal)
+ (if (r2b-isa-university r2bv-institution)
+ (r2b-moveq r2bv-organization r2bv-institution)
+ (r2b-moveq r2bv-publisher r2bv-institution))
+ (r2b-moveq r2bv-note r2bv-tr)
+ (r2b-require 'r2bv-author)
+ 'inproceedings)
+ ((r2b-isa-proceedings r2bv-booktitle)
+ (if (r2b-isa-university r2bv-institution)
+ (r2b-moveq r2bv-organization r2bv-institution)
+ (r2b-moveq r2bv-publisher r2bv-institution))
+ (r2b-moveq r2bv-note r2bv-tr)
+ (r2b-require 'r2bv-author)
+ 'inproceedings)
+ ((and r2bv-tr (string-match "phd" r2bv-tr))
+ (r2b-moveq r2bv-school r2bv-institution)
+ (r2b-require 'r2bv-school )
+ (r2b-require 'r2bv-author)
+ 'phdthesis)
+ ((and r2bv-tr (string-match "master" r2bv-tr))
+ (r2b-moveq r2bv-school r2bv-institution)
+ (r2b-require 'r2bv-school )
+ (r2b-require 'r2bv-author)
+ 'mastersthesis)
+ ((and r2bv-tr (string-match "draft\\|unpublish" r2bv-tr))
+ (r2b-moveq r2bv-note r2bv-institution)
+ (r2b-require 'r2bv-author)
+ 'unpublished)
+ (r2bv-journal
+ (r2b-require 'r2bv-author)
+ 'article)
+ (r2bv-booktitle
+ (r2b-moveq r2bv-publisher r2bv-institution)
+ (r2b-moveq r2bv-note r2bv-tr)
+ (r2b-require 'r2bv-publisher)
+ (r2b-require 'r2bv-author)
+ 'incollection)
+ ((and r2bv-author
+ (null r2bv-editor)
+ (string-match "\\`personal communication\\'" r2bv-title))
+ 'misc)
+ ((r2b-isa-proceedings r2bv-title)
+ (if (r2b-isa-university r2bv-institution)
+ (r2b-moveq r2bv-organization r2bv-institution)
+ (r2b-moveq r2bv-publisher r2bv-institution))
+ (r2b-moveq r2bv-note r2bv-tr)
+ 'proceedings)
+ ((or r2bv-editor
+ (and r2bv-author
+ (or
+ (null r2bv-tr)
+ (string-match "\\bisbn\\b" r2bv-tr))))
+ (r2b-moveq r2bv-publisher r2bv-institution)
+ (r2b-moveq r2bv-note r2bv-tr)
+ (r2b-require 'r2bv-publisher)
+ (if (null r2bv-editor)
+ (r2b-require 'r2bv-author))
+ 'book)
+ (r2bv-tr
+ (r2b-require 'r2bv-institution)
+ (if (string-match
+ "\\`\\(\\(.\\|\n\\)+\\)[ \t\n]+\\([^ \t\n]\\)+\\'"
+ r2bv-tr)
+ (progn
+ (setq r2bv-type (substring r2bv-tr 0 (match-end 1)))
+ (setq r2bv-number (substring r2bv-tr
+ (match-beginning 3)))
+ (setq r2bv-tr nil))
+ (r2b-moveq r2bv-number r2bv-tr))
+ (r2b-require 'r2bv-author)
+ 'techreport)
+ (r2bv-institution
+ (r2b-moveq r2bv-organization r2bv-institution)
+ 'manual)
+ (t
+ 'misc)
+ ))
+
+ (r2b-require '( r2bv-year))
+
+ (if r2b-error-found
+ (princ "\n% Warning -- Errors During Conversion Next Entry\n"))
+
+ (princ "\n@")
+ (princ r2bv-entry-kind)
+ (princ "( ")
+ (princ r2bv-kn)
+
+ (r2b-put-field "author" r2bv-author )
+ (r2b-put-field "title" r2bv-title r2b-booktitle-abbrevs)
+ (r2b-put-field "year" r2bv-year )
+
+ (r2b-put-field "month" r2bv-month r2b-month-abbrevs)
+ (r2b-put-field "journal" r2bv-journal r2b-journal-abbrevs)
+ (r2b-put-field "volume" r2bv-volume)
+ (r2b-put-field "type" r2bv-type)
+ (r2b-put-field "number" r2bv-number)
+ (r2b-put-field "booktitle" r2bv-booktitle r2b-booktitle-abbrevs)
+ (r2b-put-field "editor" r2bv-editor)
+ (r2b-put-field "publisher" r2bv-publisher)
+ (r2b-put-field "institution" r2bv-institution)
+ (r2b-put-field "organization" r2bv-organization)
+ (r2b-put-field "school" r2bv-school)
+ (r2b-put-field "pages" r2bv-pages)
+ (r2b-put-field "address" r2bv-address)
+ (r2b-put-field "note" r2bv-note)
+ (r2b-put-field "keywords" r2bv-keywords)
+ (r2b-put-field "where" r2bv-where)
+ (r2b-put-field "ordering" r2bv-ordering)
+ (r2b-put-field "annote" r2bv-annote)
+
+ (princ " )\n")
+ )
+ )
+
+
+(defun r2b-convert-record (output-name)
+ "transform current bib entry and append to buffer OUTPUT;
+do M-x r2b-help for more info"
+ (interactive
+ (list (read-string "Output to buffer: " r2b-out-buf-name)))
+ (let (rec-end rec-begin not-done)
+ (setq r2b-out-buf-name output-name)
+ (setq r2b-out-buf (get-buffer-create output-name))
+ (setq r2b-in-buf (current-buffer))
+ (set-buffer r2b-out-buf)
+ (goto-char (point-max))
+ (setq r2b-log (get-buffer-create r2b-log-name))
+ (set-buffer r2b-log)
+ (goto-char (point-max))
+ (set-buffer r2b-in-buf)
+ (setq not-done (re-search-forward "[^ \t\n]" nil t))
+ (if not-done
+ (progn
+ (re-search-backward "^[ \t]*$" nil 2)
+ (re-search-forward "^%")
+ (beginning-of-line nil)
+ (setq rec-begin (point))
+ (re-search-forward "^[ \t]*$" nil 2)
+ (setq rec-end (point))
+ (narrow-to-region rec-begin rec-end)
+ (r2b-clear-variables)
+ (r2b-snarf-input)
+ (r2b-barf-output)
+ (set-buffer r2b-in-buf)
+ (widen)
+ (goto-char rec-end)
+ t)
+ nil
+ )
+ ))
+
+
+(defun r2b-convert-buffer (output-name)
+ "transform current buffer and append to buffer OUTPUT;
+do M-x r2b-help for more info"
+ (interactive
+ (list (read-string "Output to buffer: " r2b-out-buf-name)))
+ (save-excursion
+ (setq r2b-log (get-buffer-create r2b-log-name))
+ (set-buffer r2b-log)
+ (erase-buffer))
+ (widen)
+ (goto-char (point-min))
+ (message "Working, please be patient...")
+ (sit-for 0)
+ (while (r2b-convert-record output-name) t)
+ (message "Done, results in %s, errors in %s"
+ r2b-out-buf-name r2b-log-name)
+ )
+
+(defvar r2b-load-quietly nil "*Don't print help message when loaded")
+
+(defvar r2b-help-message
+" Refer to Bibtex Bibliography Conversion
+
+A refer-style database is of the form:
+
+%A Joe Blow
+%T Great Thoughts I've Thought
+%D 1977
+etc.
+
+This utility converts these kind of databases to bibtex form, for
+users of TeX and LaTex. Instructions:
+1. Visit the file containing the refer-style database.
+2. The command
+ M-x r2b-convert-buffer
+ converts the entire buffer, appending it's output by default in a
+ buffer named *Out*, and logging progress and errors in a buffer
+ named *Log*. The original file is never modified.
+ Note that results are appended to *Out*, so if that buffer
+ buffer already exists and contains material you don't want to
+ save, you should kill it first.
+3. Switch to the buffer *Out* and save it as a named file.
+4. To convert a single refer-style entry, simply position the cursor
+ at the entry and enter
+ M-x r2b-convert-record
+ Again output is appended to *Out* and errors are logged in *Log*.
+
+This utility is very robust and pretty smart about determining the
+type of the entry. It includes facilities for expanding refer macros
+to text, or substituting bibtex macros. Do M-x describe-variable on
+ r2b-journal-abbrevs
+ r2b-booktitle-abbrevs
+ r2b-proceedings-list
+for information on these features.
+
+If you don't want to see this help message when you load this utility,
+then include the following line in your .emacs file:
+ (setq r2b-load-quietly t)
+To see this message again, perform
+ M-x r2b-help")
+
+
+(defun r2b-help ()
+ "print help message"
+ (interactive)
+ (with-output-to-temp-buffer "*Help*"
+ (princ r2b-help-message)))
+
+(if (not r2b-load-quietly)
+ (r2b-help))
+
+(message "r2b loaded")
+
--- /dev/null
+;; Spelling correction interface for Emacs.
+;; Copyright (C) 1985 Free Software Foundation, Inc.
+
+;; 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+
+(defvar spell-command "spell"
+ "*Command to run the spell program.")
+
+(defvar spell-filter nil
+ "*Filter function to process text before passing it to spell program.
+This function might remove text-processor commands.
+nil means don't alter the text before checking it.")
+
+(defun spell-buffer ()
+ "Check spelling of every word in the buffer.
+For each incorrect word, you are asked for the correct spelling
+and then put into a query-replace to fix some or all occurrences.
+If you do not want to change a word, just give the same word
+as its \"correct\" spelling; then the query replace is skipped."
+ (interactive)
+ (spell-region (point-min) (point-max) "buffer"))
+
+(defun spell-word ()
+ "Check spelling of word at or before point.
+If it is not correct, ask user for the correct spelling
+and query-replace the entire buffer to substitute it."
+ (interactive)
+ (let (beg end spell-filter)
+ (save-excursion
+ (if (not (looking-at "\\<"))
+ (forward-word -1))
+ (setq beg (point))
+ (forward-word 1)
+ (setq end (point)))
+ (spell-region beg end (buffer-substring beg end))))
+
+(defun spell-region (start end &optional description)
+ "Like spell-buffer but applies only to region.
+Used in a program, applies from START to END.
+DESCRIPTION is an optional string naming the unit being checked:
+for example, \"word\"."
+ (interactive "r")
+ (let ((filter spell-filter)
+ (buf (get-buffer-create " *temp*")))
+ (save-excursion
+ (set-buffer buf)
+ (widen)
+ (erase-buffer))
+ (message "Checking spelling of %s..." (or description "region"))
+ (if (and (null filter) (= ?\n (char-after (1- end))))
+ (if (string= "spell" spell-command)
+ (call-process-region start end "spell" nil buf)
+ (call-process-region start end shell-file-name
+ nil buf nil "-c" spell-command))
+ (let ((oldbuf (current-buffer)))
+ (save-excursion
+ (set-buffer buf)
+ (insert-buffer-substring oldbuf start end)
+ (or (bolp) (insert ?\n))
+ (if filter (funcall filter))
+ (if (string= "spell" spell-command)
+ (call-process-region (point-min) (point-max) "spell" t buf)
+ (call-process-region (point-min) (point-max) shell-file-name
+ t buf nil "-c" spell-command)))))
+ (message "Checking spelling of %s...%s"
+ (or description "region")
+ (if (save-excursion
+ (set-buffer buf)
+ (> (buffer-size) 0))
+ "not correct"
+ "correct"))
+ (let (word newword
+ (case-fold-search t)
+ (case-replace t))
+ (while (save-excursion
+ (set-buffer buf)
+ (> (buffer-size) 0))
+ (save-excursion
+ (set-buffer buf)
+ (goto-char (point-min))
+ (setq word (downcase
+ (buffer-substring (point)
+ (progn (end-of-line) (point)))))
+ (forward-char 1)
+ (delete-region (point-min) (point))
+ (setq newword
+ (read-input (concat "`" word
+ "' not recognized; edit a replacement: ")
+ word))
+ (flush-lines (concat "^" (regexp-quote word) "$")))
+ (if (not (equal word newword))
+ (progn
+ (goto-char (point-min))
+ (query-replace-regexp (concat "\\b" (regexp-quote word) "\\b")
+ newword)))))))
+
+
+(defun spell-string (string)
+ "Check spelling of string supplied as argument."
+ (interactive "sSpell string: ")
+ (let ((buf (get-buffer-create " *temp*")))
+ (save-excursion
+ (set-buffer buf)
+ (widen)
+ (erase-buffer)
+ (insert string "\n")
+ (if (string= "spell" spell-command)
+ (call-process-region (point-min) (point-max) "spell"
+ t t)
+ (call-process-region (point-min) (point-max) shell-file-name
+ t t nil "-c" spell-command))
+ (if (= 0 (buffer-size))
+ (message "%s is correct" string)
+ (goto-char (point-min))
+ (while (search-forward "\n" nil t)
+ (replace-match " "))
+ (message "%sincorrect" (buffer-substring 1 (point-max)))))))
--- /dev/null
+;; Text mode, and its ideosyncratic commands.
+;; Copyright (C) 1985 Free Software Foundation, Inc.
+
+;; 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+
+(defvar text-mode-syntax-table nil
+ "Syntax table used while in text mode.")
+
+(defvar text-mode-abbrev-table nil
+ "Abbrev table used while in text mode.")
+(define-abbrev-table 'text-mode-abbrev-table ())
+
+(if text-mode-syntax-table
+ ()
+ (setq text-mode-syntax-table (make-syntax-table))
+ (modify-syntax-entry ?\" ". " text-mode-syntax-table)
+ (modify-syntax-entry ?\\ ". " text-mode-syntax-table)
+ (modify-syntax-entry ?' "w " text-mode-syntax-table))
+
+(defvar text-mode-map nil
+ "Keymap for Text mode.
+Many other modes, such as Mail mode, Outline mode and Indented Text mode,
+inherit all the commands defined in this map.")
+
+(if text-mode-map
+ ()
+ (setq text-mode-map (make-sparse-keymap))
+ (define-key text-mode-map "\t" 'tab-to-tab-stop)
+ (define-key text-mode-map "\es" 'center-line)
+ (define-key text-mode-map "\eS" 'center-paragraph))
+
+\f
+;(defun non-saved-text-mode ()
+; "Like text-mode, but delete auto save file when file is saved for real."
+; (text-mode)
+; (make-local-variable 'delete-auto-save-files)
+; (setq delete-auto-save-files t))
+
+(defun text-mode ()
+ "Major mode for editing text intended for humans to read. Special commands:\\{text-mode-map}
+Turning on text-mode calls the value of the variable `text-mode-hook',
+if that value is non-nil."
+ (interactive)
+ (kill-all-local-variables)
+ (use-local-map text-mode-map)
+ (setq mode-name "Text")
+ (setq major-mode 'text-mode)
+ (setq local-abbrev-table text-mode-abbrev-table)
+ (set-syntax-table text-mode-syntax-table)
+ (run-hooks 'text-mode-hook))
+
+(defvar indented-text-mode-map ()
+ "Keymap for Indented Text mode.
+All the commands defined in Text mode are inherited unless overridden.")
+
+(if indented-text-mode-map
+ ()
+ (setq indented-text-mode-map (nconc (make-sparse-keymap) text-mode-map))
+ (define-key indented-text-mode-map "\t" 'indent-relative))
+
+(defun indented-text-mode ()
+ "Major mode for editing indented text intended for humans to read.\\{indented-text-mode-map}
+Turning on indented-text-mode calls the value of the variable `text-mode-hook',
+if that value is non-nil."
+ (interactive)
+ (kill-all-local-variables)
+ (use-local-map text-mode-map)
+ (define-abbrev-table 'text-mode-abbrev-table ())
+ (setq local-abbrev-table text-mode-abbrev-table)
+ (set-syntax-table text-mode-syntax-table)
+ (make-local-variable 'indent-line-function)
+ (setq indent-line-function 'indent-relative-maybe)
+ (use-local-map indented-text-mode-map)
+ (setq mode-name "Indented Text")
+ (setq major-mode 'indented-text-mode)
+ (run-hooks 'text-mode-hook))
+
+(defun change-log-mode ()
+ "Major mode for editing ChangeLog files. See M-x add-change-log-entry.
+Almost the same as Indented Text mode, but prevents numeric backups
+and sets `left-margin' to 8 and `fill-column' to 74."
+ (interactive)
+ (indented-text-mode)
+ (setq left-margin 8)
+ (setq fill-column 74)
+ (make-local-variable 'version-control)
+ (setq version-control 'never)
+ (run-hooks 'change-log-mode-hook))
+
+(defun center-paragraph ()
+ "Center each nonblank line in the paragraph at or after point.
+See center-line for more info."
+ (interactive)
+ (save-excursion
+ (forward-paragraph)
+ (or (bolp) (newline 1))
+ (let ((end (point)))
+ (backward-paragraph)
+ (center-region (point) end))))
+
+(defun center-region (from to)
+ "Center each nonblank line starting in the region.
+See center-line for more info."
+ (interactive "r")
+ (if (> from to)
+ (let ((tem to))
+ (setq to from from tem)))
+ (save-excursion
+ (save-restriction
+ (narrow-to-region from to)
+ (goto-char from)
+ (while (not (eobp))
+ (or (save-excursion (skip-chars-forward " \t") (eolp))
+ (center-line))
+ (forward-line 1)))))
+
+(defun center-line ()
+ "Center the line point is on, within the width specified by `fill-column'.
+This means adjusting the indentation so that it equals
+the distance between the end of the text and `fill-column'."
+ (interactive)
+ (save-excursion
+ (let (line-length)
+ (beginning-of-line)
+ (delete-horizontal-space)
+ (end-of-line)
+ (delete-horizontal-space)
+ (setq line-length (current-column))
+ (beginning-of-line)
+ (indent-to
+ (+ left-margin
+ (/ (- fill-column left-margin line-length) 2))))))
--- /dev/null
+;; Insert or remove underlining (done by overstriking) in Emacs.
+;; Copyright (C) 1985 Free Software Foundation, Inc.
+
+;; 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+
+(defun underline-region (start end)
+ "Underline all nonblank characters in the region.
+Works by overstriking underscores.
+Called from program, takes two arguments START and END
+which specify the range to operate on."
+ (interactive "r")
+ (save-excursion
+ (let ((end1 (make-marker)))
+ (move-marker end1 (max start end))
+ (goto-char (min start end))
+ (while (< (point) end1)
+ (or (looking-at "[_\^@- ]")
+ (insert "_\b"))
+ (forward-char 1)))))
+
+(defun ununderline-region (start end)
+ "Remove all underlining (overstruck underscores) in the region.
+Called from program, takes two arguments START and END
+which specify the range to operate on."
+ (interactive "r")
+ (save-excursion
+ (let ((end1 (make-marker)))
+ (move-marker end1 (max start end))
+ (goto-char (min start end))
+ (while (re-search-forward "_\b\\|\b_" end1 t)
+ (delete-char -2)))))
--- /dev/null
+;; Copyright (C) 1985, 1986 Free Software Foundation, inc.
+
+;; 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+
+;; This file is autloaded to handle certain conditions
+;; detected by the file-locking code within Emacs.
+;; The two entry points are `ask-user-about-lock' and
+;; `ask-user-about-supersession-threat'.
+
+
+(put 'file-locked 'error-conditions '(file-locked file-error error))
+
+(defun ask-user-about-lock (fn opponent)
+ "Ask user what to do when he wants to edit FILE but it is locked by USER.
+This function has a choice of three things to do:
+ do (signal 'buffer-file-locked (list FILE USER))
+ to refrain from editing the file
+ return t (grab the lock on the file)
+ return nil (edit the file even though it is locked).
+You can rewrite it to use any criterion you like to choose which one to do."
+ (discard-input)
+ (save-window-excursion
+ (let (answer)
+ (while (null answer)
+ (message "%s is locking %s: action (s, q, p, ?)? " opponent fn)
+ (let ((tem (let ((inhibit-quit t)
+ (cursor-in-echo-area t))
+ (prog1 (downcase (read-char))
+ (setq quit-flag nil)))))
+ (if (= tem help-char)
+ (ask-user-about-lock-help)
+ (setq answer (assoc tem '((?s . t)
+ (?q . yield)
+ (?\C-g . yield)
+ (?p . nil)
+ (?? . help))))
+ (cond ((null answer)
+ (beep)
+ (message "Please type q, s, or p; or ? for help")
+ (sit-for 3))
+ ((eq (cdr answer) 'help)
+ (ask-user-about-lock-help)
+ (setq answer nil))
+ ((eq (cdr answer) 'yield)
+ (signal 'file-locked (list "File is locked" fn opponent)))))))
+ (cdr answer))))
+
+(defun ask-user-about-lock-help ()
+ (with-output-to-temp-buffer "*Help*"
+ (princ "It has been detected that you want to modify a file that someone else has
+already started modifying in EMACS.
+
+You can <s>teal the file; The other user becomes the
+ intruder if (s)he ever unmodifies the file and then changes it again.
+You can <p>roceed; you edit at your own (and the other user's) risk.
+You can <q>uit; don't modify this file.")))
+
+(put
+ 'file-supersession 'error-conditions '(file-supersession file-error error))
+
+(defun ask-user-about-supersession-threat (fn)
+ "Ask a user who is about to modify an obsolete buffer what to do.
+This function has two choices: it can return, in which case the modification
+of the buffer will proceed, or it can (signal 'file-supersession (file)),
+in which case the proposed buffer modification will not be made.
+
+You can rewrite this to use any criterion you like to choose which one to do.
+The buffer in question is current when this function is called."
+ (discard-input)
+ (save-window-excursion
+ (let (answer)
+ (while (null answer)
+ (message "File has changed on disk; really want to edit the buffer? (y, n or C-h) ")
+ (let ((tem (downcase (let ((cursor-in-echo-area t))
+ (read-char)))))
+ (setq answer
+ (if (= tem help-char)
+ 'help
+ (cdr (assoc tem '((?n . yield)
+ (?\C-g . yield)
+ (?y . proceed)
+ (?? . help))))))
+ (cond ((null answer)
+ (beep)
+ (message "Please type y or n; or ? for help")
+ (sit-for 3))
+ ((eq answer 'help)
+ (ask-user-about-supersession-help)
+ (setq answer nil))
+ ((eq answer 'yield)
+ (signal 'file-supersession
+ (list "File changed on disk" fn))))))
+ (message
+ "File on disk now will become a backup file if you save these changes.")
+ (setq buffer-backed-up nil))))
+
+(defun ask-user-about-supersession-help ()
+ (with-output-to-temp-buffer "*Help*"
+ (princ "You want to modify a buffer whose disk file has changed
+since you last read it in or saved it with this buffer.
+
+If you say `y' to go ahead and modify this buffer,
+you risk ruining the work of whoever rewrote the file.
+If you say `n', the change you started to make will be aborted.
+
+Usually, you should type `n' and then `M-x revert-buffer',
+to get the latest version of the file, then make the change again.")))
+
+
--- /dev/null
+;; Override parts of files.el for VMS.
+;; Copyright (C) 1986 Free Software Foundation, Inc.
+
+;; 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+
+;;; Functions that need redefinition
+
+;;; VMS file names are upper case, but buffer names are more
+;;; convenient in lower case.
+
+(defun create-file-buffer (filename)
+ "Create a suitably named buffer for visiting FILENAME, and return it.
+FILENAME (sans directory) is used unchanged if that name is free;
+otherwise a string <2> or <3> or ... is appended to get an unused name."
+ (generate-new-buffer (downcase (file-name-nondirectory filename))))
+
+;;; Given a string FN, return a similar name which is a legal VMS filename.
+;;; This is used to avoid invalid auto save file names.
+(defun make-legal-file-name (fn)
+ (setq fn (copy-sequence fn))
+ (let ((dot nil) (indx 0) (len (length fn)) chr)
+ (while (< indx len)
+ (setq chr (aref fn indx))
+ (cond
+ ((eq chr ?.) (if dot (aset fn indx ?_) (setq dot t)))
+ ((not (or (and (>= chr ?a) (<= chr ?z)) (and (>= chr ?A) (<= chr ?Z))
+ (and (>= chr ?0) (<= chr ?9))
+ (eq chr ?$) (eq chr ?_) (and (eq chr ?-) (> indx 0))))
+ (aset fn indx ?_)))
+ (setq indx (1+ indx))))
+ fn)
+
+;;; Auto save filesnames start with _$ and end with $.
+
+(defun make-auto-save-file-name ()
+ "Return file name to use for auto-saves of current buffer.
+Does not consider auto-save-visited-file-name; that is checked
+before calling this function.
+This is a separate function so your .emacs file or site-init.el can redefine it.
+See also auto-save-file-name-p."
+ (if buffer-file-name
+ (concat (file-name-directory buffer-file-name)
+ "_$"
+ (file-name-nondirectory buffer-file-name)
+ "$")
+ (expand-file-name (concat "_$_" (make-legal-file-name (buffer-name)) "$"))))
+
+(defun auto-save-file-name-p (filename)
+ "Return t if FILENAME can be yielded by make-auto-save-file-name.
+FILENAME should lack slashes.
+This is a separate function so your .emacs file or site-init.el can redefine it."
+ (string-match "^_\\$.*\\$" filename))
+
+(defun vms-suspend-resume-hook ()
+ "When resuming suspended Emacs, check for file to be found.
+If the logical name `EMACS_FILE_NAME' is defined, `find-file' that file."
+ (let ((file (vms-system-info "LOGICAL" "EMACS_FILE_NAME")))
+ (if file (find-file file))))
+
+(setq suspend-resume-hook 'vms-suspend-resume-hook)
+
+(defun vms-suspend-hook ()
+ "Don't allow suspending if logical name `DONT_SUSPEND_EMACS' is defined."
+ (if (vms-system-info "LOGICAL" "DONT_SUSPEND_EMACS")
+ (error "Can't suspend this emacs"))
+ nil)
+
+(setq suspend-hook 'vms-suspend-hook)
+
+(defun vms-read-directory (dirname switches buffer)
+ (save-excursion
+ (set-buffer buffer)
+ (subprocess-command-to-buffer
+ (concat "DIRECTORY " switches " " dirname)
+ buffer)
+ (goto-char (point-min))
+ ;; Remove all the trailing blanks.
+ (while (search-forward " \n")
+ (forward-char -1)
+ (delete-horizontal-space))
+ (goto-char (point-min))))
+
+(setq dired-listing-switches
+ "/SIZE/DATE/OWNER/WIDTH=(FILENAME=32,SIZE=5)")
--- /dev/null
+;; GNU Emacs window commands aside from those written in C.
+;; Copyright (C) 1985, 1989 Free Software Foundation, Inc.
+
+;; 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+
+(defun count-windows (&optional minibuf)
+ "Returns the number of visible windows.
+Optional arg NO-MINI non-nil means don't count the minibuffer
+even if it is active."
+ (let ((count 0))
+ (walk-windows (function (lambda ()
+ (setq count (+ count 1))))
+ minibuf)
+ count))
+
+(defun balance-windows ()
+ "Makes all visible windows the same size (approximately)."
+ (interactive)
+ (let ((count 0))
+ (walk-windows (function (lambda (w)
+ (setq count (+ count 1))))
+ 'nomini)
+ (let ((size (/ (screen-height) count)))
+ (walk-windows (function (lambda (w)
+ (select-window w)
+ (enlarge-window (- size (window-height)))))
+ 'nomini))))
+
+(defun split-window-vertically (&optional arg)
+ "Split current window into two windows, one above the other.
+This window becomes the uppermost of the two, and gets
+ARG lines. No arg means split equally."
+ (interactive "P")
+ (let ((old-w (selected-window))
+ new-w bottom)
+ (setq new-w (split-window nil (and arg (prefix-numeric-value arg))))
+ (save-excursion
+ (set-buffer (window-buffer))
+ (goto-char (window-start))
+ (vertical-motion (window-height))
+ (set-window-start new-w (point))
+ (if (> (point) (window-point new-w))
+ (set-window-point new-w (point)))
+ (vertical-motion -1)
+ (setq bottom (point)))
+ (if (<= bottom (point))
+ (set-window-point old-w (1- bottom)))))
+
+(defun split-window-horizontally (&optional arg)
+ "Split current window into two windows side by side.
+This window becomes the leftmost of the two, and gets
+ARG columns. No arg means split equally."
+ (interactive "P")
+ (split-window nil (and arg (prefix-numeric-value arg)) t))
+
+(defun enlarge-window-horizontally (arg)
+ "Make current window ARG columns wider."
+ (interactive "p")
+ (enlarge-window arg t))
+
+(defun shrink-window-horizontally (arg)
+ "Make current window ARG columns narrower."
+ (interactive "p")
+ (shrink-window arg t))
+
+(defun window-config-to-register (name)
+ "Save the current window configuration in register REG (a letter).
+It can be later retrieved using \\[M-x register-to-window-config]."
+ (interactive "cSave window configuration in register: ")
+ (set-register name (current-window-configuration)))
+
+(defun register-to-window-config (name)
+ "Restore (make current) the window configuration in register REG (a letter).
+Use with a register previously set with \\[window-config-to-register]."
+ (interactive "cRestore window configuration from register: ")
+ (set-window-configuration (get-register name)))
+
+(define-key ctl-x-map "2" 'split-window-vertically)
+(define-key ctl-x-map "5" 'split-window-horizontally)
+(define-key ctl-x-map "6" 'window-config-to-register)
+(define-key ctl-x-map "7" 'register-to-window-config)
+(define-key ctl-x-map "}" 'enlarge-window-horizontally)
+(define-key ctl-x-map "{" 'shrink-window-horizontally)
projects / emacs.git / commitdiff