Mercurial > emacs
changeset 36:9697c13298e5
Initial revision
| author | Joseph Arceneaux <jla@gnu.org> |
|---|---|
| date | Tue, 31 Oct 1989 16:00:07 +0000 |
| parents | 63b375f17a65 |
| children | e48c0f5e6696 |
| files | lib-src/emacstool.c lisp/=gosmacs.el lisp/case-table.el lisp/disp-table.el lisp/ehelp.el lisp/emacs-lisp/helper.el lisp/emulation/mlconvert.el lisp/float-sup.el lisp/hexl.el lisp/ledit.el lisp/macros.el lisp/mail/emacsbug.el lisp/mail/mail-utils.el lisp/mail/rmailedit.el lisp/mail/rmailkwd.el lisp/makesum.el lisp/novice.el lisp/play/dissociate.el lisp/play/gomoku.el lisp/play/spook.el lisp/progmodes/icon.el lisp/rect.el lisp/tabify.el lisp/textmodes/nroff-mode.el lisp/textmodes/page.el lisp/textmodes/paragraphs.el lisp/textmodes/refbib.el lisp/textmodes/spell.el lisp/textmodes/text-mode.el lisp/textmodes/underline.el lisp/userlock.el lisp/vms-patch.el lisp/window.el |
| diffstat | 33 files changed, 7240 insertions(+), 0 deletions(-) [+] |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib-src/emacstool.c Tue Oct 31 16:00:07 1989 +0000 @@ -0,0 +1,340 @@ +/* + * + * 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); + + +/* + * 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; +} + +/* + * 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)); +} + + +/* + * 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); +} + +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 Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/=gosmacs.el Tue Oct 31 16:00:07 1989 +0000 @@ -0,0 +1,102 @@ +;; 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 Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/case-table.el Tue Oct 31 16:00:07 1989 +0000 @@ -0,0 +1,101 @@ +;; 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 Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/disp-table.el Tue Oct 31 16:00:07 1989 +0000 @@ -0,0 +1,115 @@ +;; 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 Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/ehelp.el Tue Oct 31 16:00:07 1989 +0000 @@ -0,0 +1,338 @@ +;; 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)))) + + + +;(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)) + + +(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)))) + + +(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) + + + + +;;;; 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 Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/emacs-lisp/helper.el Tue Oct 31 16:00:07 1989 +0000 @@ -0,0 +1,147 @@ +;; 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 Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/emulation/mlconvert.el Tue Oct 31 16:00:07 1989 +0000 @@ -0,0 +1,272 @@ +;; 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 Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/float-sup.el Tue Oct 31 16:00:07 1989 +0000 @@ -0,0 +1,53 @@ +;; 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 Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/hexl.el Tue Oct 31 16:00:07 1989 +0000 @@ -0,0 +1,668 @@ +;; -*-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 Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/ledit.el Tue Oct 31 16:00:07 1989 +0000 @@ -0,0 +1,138 @@ +;; 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 Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/macros.el Tue Oct 31 16:00:07 1989 +0000 @@ -0,0 +1,103 @@ +;; 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 Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/mail/emacsbug.el Tue Oct 31 16:00:07 1989 +0000 @@ -0,0 +1,38 @@ +;; 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 Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/mail/mail-utils.el Tue Oct 31 16:00:07 1989 +0000 @@ -0,0 +1,195 @@ +;; 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))) + +(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)))))))))) + +;; 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 Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/mail/rmailedit.el Tue Oct 31 16:00:07 1989 +0000 @@ -0,0 +1,105 @@ +;; "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 Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/mail/rmailkwd.el Tue Oct 31 16:00:07 1989 +0000 @@ -0,0 +1,260 @@ +;; "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) + +(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))))))) + +;; 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)))) + +;; 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)))) + +;;; 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 Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/makesum.el Tue Oct 31 16:00:07 1989 +0000 @@ -0,0 +1,100 @@ +;; 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 Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/novice.el Tue Oct 31 16:00:07 1989 +0000 @@ -0,0 +1,105 @@ +;; 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 Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/play/dissociate.el Tue Oct 31 16:00:07 1989 +0000 @@ -0,0 +1,87 @@ +;; 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 Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/play/gomoku.el Tue Oct 31 16:00:07 1989 +0000 @@ -0,0 +1,1166 @@ +;; 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. + +;;; +;;; 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)) + +;;; +;;; 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))))) + +;;; +;;; 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)) + +;;; +;;; 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))) + +;;; +;;; 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))))))) + +;;; +;;; 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)) + +;;; +;;; 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)) + +;;; +;;; 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 + +;;; +;;; 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))) + +;;; +;;; 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)))) + +;;; +;;; 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 + +;;; +;;; 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 Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/play/spook.el Tue Oct 31 16:00:07 1989 +0000 @@ -0,0 +1,109 @@ +;; 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 Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/progmodes/icon.el Tue Oct 31 16:00:07 1989 +0000 @@ -0,0 +1,550 @@ +;; 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.") + +(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)) + +;; 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))))) + +(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)))))) + +(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)) + +(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 Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/rect.el Tue Oct 31 16:00:07 1989 +0000 @@ -0,0 +1,205 @@ +;; 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 Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/tabify.el Tue Oct 31 16:00:07 1989 +0000 @@ -0,0 +1,51 @@ +;; 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 Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/textmodes/nroff-mode.el Tue Oct 31 16:00:07 1989 +0000 @@ -0,0 +1,203 @@ +;; 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 Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/textmodes/page.el Tue Oct 31 16:00:07 1989 +0000 @@ -0,0 +1,123 @@ +;; 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 Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/textmodes/paragraphs.el Tue Oct 31 16:00:07 1989 +0000 @@ -0,0 +1,205 @@ +;; 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 Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/textmodes/refbib.el Tue Oct 31 16:00:07 1989 +0000 @@ -0,0 +1,715 @@ +;; 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 Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/textmodes/spell.el Tue Oct 31 16:00:07 1989 +0000 @@ -0,0 +1,132 @@ +;; 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 Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/textmodes/text-mode.el Tue Oct 31 16:00:07 1989 +0000 @@ -0,0 +1,147 @@ +;; 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)) + + +;(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 Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/textmodes/underline.el Tue Oct 31 16:00:07 1989 +0000 @@ -0,0 +1,46 @@ +;; 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 "_")) + (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 "_\\|_" end1 t) + (delete-char -2)))))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/userlock.el Tue Oct 31 16:00:07 1989 +0000 @@ -0,0 +1,124 @@ +;; 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 Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/vms-patch.el Tue Oct 31 16:00:07 1989 +0000 @@ -0,0 +1,99 @@ +;; 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 Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/window.el Tue Oct 31 16:00:07 1989 +0000 @@ -0,0 +1,98 @@ +;; 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)