diff options
Diffstat (limited to 'lisp/play')
| -rw-r--r-- | lisp/play/blackbox.el | 421 | ||||
| -rw-r--r-- | lisp/play/cookie1.el | 165 | ||||
| -rw-r--r-- | lisp/play/decipher.el | 1057 | ||||
| -rw-r--r-- | lisp/play/dissociate.el | 101 | ||||
| -rw-r--r-- | lisp/play/doctor.el | 1614 | ||||
| -rw-r--r-- | lisp/play/dunnet.el | 3343 | ||||
| -rw-r--r-- | lisp/play/gomoku.el | 1182 | ||||
| -rw-r--r-- | lisp/play/handwrite.el | 1376 | ||||
| -rw-r--r-- | lisp/play/hanoi.el | 227 | ||||
| -rw-r--r-- | lisp/play/life.el | 283 | ||||
| -rw-r--r-- | lisp/play/meese.el | 27 | ||||
| -rw-r--r-- | lisp/play/morse.el | 121 | ||||
| -rw-r--r-- | lisp/play/mpuz.el | 443 | ||||
| -rw-r--r-- | lisp/play/solitaire.el | 455 | ||||
| -rw-r--r-- | lisp/play/spook.el | 69 | ||||
| -rw-r--r-- | lisp/play/studly.el | 63 | ||||
| -rw-r--r-- | lisp/play/yow.el | 130 |
17 files changed, 0 insertions, 11077 deletions
diff --git a/lisp/play/blackbox.el b/lisp/play/blackbox.el deleted file mode 100644 index 8de46c2f025..00000000000 --- a/lisp/play/blackbox.el +++ /dev/null @@ -1,421 +0,0 @@ -;;; blackbox.el --- blackbox game in Emacs Lisp - -;; Copyright (C) 1985, 1986, 1987, 1992 Free Software Foundation, Inc. - -;; Author: F. Thomas May <uw-nsr!uw-warp!tom@beaver.cs.washington.edu> -;; Adapted-By: ESR -;; Keywords: games - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; by F. Thomas May <uw-nsr!uw-warp!tom@beaver.cs.washington.edu> -;; doc comment by Root Boy Jim <rbj@dsys.icst.nbs.gov>, 27 Apr 89 -;; interface improvements by ESR, Dec 5 1991. - -;; The object of the game is to find four hidden balls by shooting rays -;; into the black box. There are four possibilities: 1) the ray will -;; pass thru the box undisturbed, 2) it will hit a ball and be absorbed, -;; 3) it will be deflected and exit the box, or 4) be deflected immediately, -;; not even being allowed entry into the box. -;; -;; The strange part is the method of deflection. It seems that rays will -;; not pass next to a ball, and change direction at right angles to avoid it. -;; -;; R 3 -;; 1 - - - - - - - - 1 -;; - - - - - - - - -;; - O - - - - - - 3 -;; 2 - - - - O - O - -;; 4 - - - - - - - - -;; 5 - - - - - - - - 5 -;; - - - - - - - - R -;; H - - - - - - - O -;; 2 H 4 H -;; -;; Rays which enter and exit are numbered. You can see that rays 1 & 5 pass -;; thru the box undisturbed. Ray 2 is deflected by the northwesternmost -;; ball. Likewise rays 3 and 4. Rays which hit balls and are absorbed are -;; marked with H. The bottom of the left and the right of the bottom hit -;; the southeastern ball directly. Rays may also hit balls after being -;; reflected. Consider the H on the bottom next to the 4. It bounces off -;; the NW-ern most ball and hits the central ball. A ray shot from above -;; the right side 5 would hit the SE-ern most ball. The R beneath the 5 -;; is because the ball is returned instantly. It is not allowed into -;; the box if it would reflect immediately. The R on the top is a more -;; leisurely return. Both central balls would tend to deflect it east -;; or west, but it cannot go either way, so it just retreats. -;; -;; At the end of the game, if you've placed guesses for as many balls as -;; there are in the box, the true board position will be revealed. Each -;; `x' is an incorrect guess of yours; `o' is the true location of a ball. - -;;; Code: - -(defvar blackbox-mode-map nil "") - -(if blackbox-mode-map - () - (setq blackbox-mode-map (make-keymap)) - (suppress-keymap blackbox-mode-map t) - (define-key blackbox-mode-map "\C-f" 'bb-right) - (define-key blackbox-mode-map [right] 'bb-right) - (define-key blackbox-mode-map "\C-b" 'bb-left) - (define-key blackbox-mode-map [left] 'bb-left) - (define-key blackbox-mode-map "\C-p" 'bb-up) - (define-key blackbox-mode-map [up] 'bb-up) - (define-key blackbox-mode-map "\C-n" 'bb-down) - (define-key blackbox-mode-map [down] 'bb-down) - (define-key blackbox-mode-map "\C-e" 'bb-eol) - (define-key blackbox-mode-map "\C-a" 'bb-bol) - (define-key blackbox-mode-map " " 'bb-romp) - (define-key blackbox-mode-map [insert] 'bb-romp) - (define-key blackbox-mode-map "\C-m" 'bb-done) - (define-key blackbox-mode-map [kp-enter] 'bb-done)) - -;; Blackbox mode is suitable only for specially formatted data. -(put 'blackbox-mode 'mode-class 'special) - -(defun blackbox-mode () - "Major mode for playing blackbox. To learn how to play blackbox, -see the documentation for function `blackbox'. - -The usual mnemonic keys move the cursor around the box. -\\<blackbox-mode-map>\\[bb-bol] and \\[bb-eol] move to the beginning and end of line, respectively. - -\\[bb-romp] -- send in a ray from point, or toggle a ball at point -\\[bb-done] -- end game and get score -" - (interactive) - (kill-all-local-variables) - (use-local-map blackbox-mode-map) - (setq truncate-lines t) - (setq major-mode 'blackbox-mode) - (setq mode-name "Blackbox")) - -;;;###autoload -(defun blackbox (num) - "Play blackbox. Optional prefix argument is the number of balls; -the default is 4. - -What is blackbox? - -Blackbox is a game of hide and seek played on an 8 by 8 grid (the -Blackbox). Your opponent (Emacs, in this case) has hidden several -balls (usually 4) within this box. By shooting rays into the box and -observing where they emerge it is possible to deduce the positions of -the hidden balls. The fewer rays you use to find the balls, the lower -your score. - -Overview of play: - -\\<blackbox-mode-map>\ -To play blackbox, type \\[blackbox]. An optional prefix argument -specifies the number of balls to be hidden in the box; the default is -four. - -The cursor can be moved around the box with the standard cursor -movement keys. - -To shoot a ray, move the cursor to the edge of the box and press SPC. -The result will be determined and the playfield updated. - -You may place or remove balls in the box by moving the cursor into the -box and pressing \\[bb-romp]. - -When you think the configuration of balls you have placed is correct, -press \\[bb-done]. You will be informed whether you are correct or -not, and be given your score. Your score is the number of letters and -numbers around the outside of the box plus five for each incorrectly -placed ball. If you placed any balls incorrectly, they will be -indicated with `x', and their actual positions indicated with `o'. - -Details: - -There are three possible outcomes for each ray you send into the box: - - Detour: the ray is deflected and emerges somewhere other than - where you sent it in. On the playfield, detours are - denoted by matching pairs of numbers -- one where the - ray went in, and the other where it came out. - - Reflection: the ray is reflected and emerges in the same place - it was sent in. On the playfield, reflections are - denoted by the letter `R'. - - Hit: the ray strikes a ball directly and is absorbed. It does - not emerge from the box. On the playfield, hits are - denoted by the letter `H'. - -The rules for how balls deflect rays are simple and are best shown by -example. - -As a ray approaches a ball it is deflected ninety degrees. Rays can -be deflected multiple times. In the diagrams below, the dashes -represent empty box locations and the letter `O' represents a ball. -The entrance and exit points of each ray are marked with numbers as -described under \"Detour\" above. Note that the entrance and exit -points are always interchangeable. `*' denotes the path taken by the -ray. - -Note carefully the relative positions of the ball and the ninety -degree deflection it causes. - - 1 - - * - - - - - - - - - - - - - - - - - - - - - - - - * - - - - - - - - - - - - - - - - - - - - - - -1 * * - - - - - - - - - - - - - - - O - - - - O - - - - O - - - - - - - O - - - - - - - * * * * - - - - - - - - - - - - - - * * * * * 2 3 * * * - - * - - - - - - - - - - - - - - * - - - - - - - O - * - - - - - - - - - - - - - - * - - - - - - - - * * - - - - - - - - - - - - - - * - - - - - - - - * - O - - 2 3 - -As mentioned above, a reflection occurs when a ray emerges from the same point -it was sent in. This can happen in several ways: - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - O - - - - - O - O - - - - - - - - - - - -R * * * * - - - - - - - * - - - - O - - - - - - - - - - - - O - - - - - - * - - - - R - - - - - - - - - - - - - - - - - - - - * - - - - - - - - - - - - - - - - - - - - - - - - * - - - - - - - - - - - - - - - - - - - - - R * * * * - - - - - - - - - - - - - - - - - - - - - - - - - O - - - - - - - - - - - - -In the first example, the ray is deflected downwards by the upper -ball, then left by the lower ball, and finally retraces its path to -its point of origin. The second example is similar. The third -example is a bit anomalous but can be rationalized by realizing the -ray never gets a chance to get into the box. Alternatively, the ray -can be thought of as being deflected downwards and immediately -emerging from the box. - -A hit occurs when a ray runs straight into a ball: - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - O - - - - - - - - - - - - - - - - O - - - H * * * * - - - - - - - - - - - - - H * * * * O - - - - - - * - - - - - - - - - - - - - - - - - O - - - - - - O - - - - -H * * * O - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -Be sure to compare the second example of a hit with the first example of -a reflection." - (interactive "P") - (switch-to-buffer "*Blackbox*") - (blackbox-mode) - (setq buffer-read-only t) - (buffer-disable-undo (current-buffer)) - (setq bb-board (bb-init-board (or num 4))) - (setq bb-balls-placed nil) - (setq bb-x -1) - (setq bb-y -1) - (setq bb-score 0) - (setq bb-detour-count 0) - (bb-insert-board) - (bb-goto (cons bb-x bb-y))) - -(defun bb-init-board (num-balls) - (random t) - (let (board pos) - (while (>= (setq num-balls (1- num-balls)) 0) - (while - (progn - (setq pos (cons (random 8) (random 8))) - (bb-member pos board))) - (setq board (cons pos board))) - board)) - -(defun bb-insert-board () - (let (i (buffer-read-only nil)) - (erase-buffer) - (insert " \n") - (setq i 8) - (while (>= (setq i (1- i)) 0) - (insert " - - - - - - - - \n")) - (insert " \n") - (insert (format "\nThere are %d balls in the box" (length bb-board))) - )) - -(defun bb-right () - (interactive) - (if (= bb-x 8) - () - (forward-char 2) - (setq bb-x (1+ bb-x)))) - -(defun bb-left () - (interactive) - (if (= bb-x -1) - () - (backward-char 2) - (setq bb-x (1- bb-x)))) - -(defun bb-up () - (interactive) - (if (= bb-y -1) - () - (previous-line 1) - (setq bb-y (1- bb-y)))) - -(defun bb-down () - (interactive) - (if (= bb-y 8) - () - (next-line 1) - (setq bb-y (1+ bb-y)))) - -(defun bb-eol () - (interactive) - (setq bb-x 8) - (bb-goto (cons bb-x bb-y))) - -(defun bb-bol () - (interactive) - (setq bb-x -1) - (bb-goto (cons bb-x bb-y))) - -(defun bb-romp () - (interactive) - (cond - ((and - (or (= bb-x -1) (= bb-x 8)) - (or (= bb-y -1) (= bb-y 8)))) - ((bb-outside-box bb-x bb-y) - (bb-trace-ray bb-x bb-y)) - (t - (bb-place-ball bb-x bb-y)))) - -(defun bb-place-ball (x y) - (let ((coord (cons x y))) - (cond - ((bb-member coord bb-balls-placed) - (setq bb-balls-placed (bb-delete coord bb-balls-placed)) - (bb-update-board "-")) - (t - (setq bb-balls-placed (cons coord bb-balls-placed)) - (bb-update-board "O"))))) - -(defun bb-trace-ray (x y) - (let ((result (bb-trace-ray-2 - t - x - (cond - ((= x -1) 1) - ((= x 8) -1) - (t 0)) - y - (cond - ((= y -1) 1) - ((= y 8) -1) - (t 0))))) - (cond - ((eq result 'hit) - (bb-update-board "H") - (setq bb-score (1+ bb-score))) - ((equal result (cons x y)) - (bb-update-board "R") - (setq bb-score (1+ bb-score))) - (t - (setq bb-detour-count (1+ bb-detour-count)) - (bb-update-board (format "%d" bb-detour-count)) - (save-excursion - (bb-goto result) - (bb-update-board (format "%d" bb-detour-count))) - (setq bb-score (+ bb-score 2)))))) - -(defun bb-trace-ray-2 (first x dx y dy) - (cond - ((and (not first) - (bb-outside-box x y)) - (cons x y)) - ((bb-member (cons (+ x dx) (+ y dy)) bb-board) - 'hit) - ((bb-member (cons (+ x dx dy) (+ y dy dx)) bb-board) - (bb-trace-ray-2 nil x (- dy) y (- dx))) - ((bb-member (cons (+ x dx (- dy)) (+ y dy (- dx))) bb-board) - (bb-trace-ray-2 nil x dy y dx)) - (t - (bb-trace-ray-2 nil (+ x dx) dx (+ y dy) dy)))) - -(defun bb-done () - "Finish the game and report score." - (interactive) - (let (bogus-balls) - (cond - ((not (= (length bb-balls-placed) (length bb-board))) - (message "There %s %d hidden ball%s; you have placed %d." - (if (= (length bb-board) 1) "is" "are") - (length bb-board) - (if (= (length bb-board) 1) "" "s") - (length bb-balls-placed))) - (t - (setq bogus-balls (bb-show-bogus-balls bb-balls-placed bb-board)) - (if (= bogus-balls 0) - (message "Right! Your score is %d." bb-score) - (message "Oops! You missed %d ball%s. Your score is %d." - bogus-balls - (if (= bogus-balls 1) "" "s") - (+ bb-score (* 5 bogus-balls)))) - (bb-goto '(-1 . -1)))))) - -(defun bb-show-bogus-balls (balls-placed board) - (bb-show-bogus-balls-2 balls-placed board "x") - (bb-show-bogus-balls-2 board balls-placed "o")) - -(defun bb-show-bogus-balls-2 (list-1 list-2 c) - (cond - ((null list-1) - 0) - ((bb-member (car list-1) list-2) - (bb-show-bogus-balls-2 (cdr list-1) list-2 c)) - (t - (bb-goto (car list-1)) - (bb-update-board c) - (1+ (bb-show-bogus-balls-2 (cdr list-1) list-2 c))))) - -(defun bb-outside-box (x y) - (or (= x -1) (= x 8) (= y -1) (= y 8))) - -(defun bb-goto (pos) - (goto-char (+ (* (car pos) 2) (* (cdr pos) 22) 26))) - -(defun bb-update-board (c) - (let ((buffer-read-only nil)) - (backward-char (1- (length c))) - (delete-char (length c)) - (insert c) - (backward-char 1))) - -(defun bb-member (elt list) - "Returns non-nil if ELT is an element of LIST." - (eval (cons 'or (mapcar (function (lambda (x) (equal x elt))) list)))) - -(defun bb-delete (item list) - "Deletes ITEM from LIST and returns a copy." - (cond - ((equal item (car list)) (cdr list)) - (t (cons (car list) (bb-delete item (cdr list)))))) - -;;; blackbox.el ends here diff --git a/lisp/play/cookie1.el b/lisp/play/cookie1.el deleted file mode 100644 index 3f8087fa2fa..00000000000 --- a/lisp/play/cookie1.el +++ /dev/null @@ -1,165 +0,0 @@ -;;; cookie1.el --- retrieve random phrases from fortune cookie files - -;; Copyright (C) 1993 Free Software Foundation, Inc. - -;; Author: Eric S. Raymond <esr@snark.thyrsus.com> -;; Maintainer: FSF -;; Keywords: games -;; Created: Mon Mar 22 17:06:26 1993 - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; Support for random cookie fetches from phrase files, used for such -;; critical applications as emulating Zippy the Pinhead and confounding -;; the NSA Trunk Trawler. -;; -;; The two entry points are `cookie' and `cookie-insert'. The helper -;; function `shuffle-vector' may be of interest to programmers. -;; -;; The code expects phrase files to be in one of two formats: -;; -;; * ITS-style LINS format (strings terminated by ASCII 0 characters, -;; leading whitespace ignored). -;; -;; * UNIX fortune file format (quotes terminated by %% on a line by itself). -;; -;; Everything up to the first delimiter is treated as a comment. Other -;; formats could be supported by adding alternates to the regexp -;; `cookie-delimiter'. -;; -;; This code derives from Steve Strassman's 1987 spook.el package, but -;; has been generalized so that it supports multiple simultaneous -;; cookie databases and fortune files. It is intended to be called -;; from other packages such as yow.el and spook.el. -;; -;; TO DO: teach cookie-snarf to auto-detect ITS PINS or UNIX fortune(6) -;; format and do the right thing. - -;;; Code: - -; Randomize the seed in the random number generator. -(random t) - -(defconst cookie-delimiter "\n%%\n\\|\0" - "Delimiter used to separate cookie file entries.") - -(defvar cookie-cache (make-vector 511 0) - "Cache of cookie files that have already been snarfed.") - -;;;###autoload -(defun cookie (phrase-file startmsg endmsg) - "Return a random phrase from PHRASE-FILE. When the phrase file -is read in, display STARTMSG at beginning of load, ENDMSG at end." - (let ((cookie-vector (cookie-snarf phrase-file startmsg endmsg))) - (shuffle-vector cookie-vector) - (aref cookie-vector 1))) - -;;;###autoload -(defun cookie-insert (phrase-file &optional count startmsg endmsg) - "Insert random phrases from PHRASE-FILE; COUNT of them. When the phrase file -is read in, display STARTMSG at beginning of load, ENDMSG at end." - (let ((cookie-vector (cookie-snarf phrase-file startmsg endmsg))) - (shuffle-vector cookie-vector) - (let ((start (point))) - (insert ?\n) - (cookie1 (min (- (length cookie-vector) 1) (or count 1)) cookie-vector) - (insert ?\n) - (fill-region-as-paragraph start (point) nil)))) - -(defun cookie1 (arg cookie-vec) - "Inserts a cookie phrase ARG times." - (cond ((zerop arg) t) - (t (insert (aref cookie-vec arg)) - (insert " ") - (cookie1 (1- arg) cookie-vec)))) - -;;;###autoload -(defun cookie-snarf (phrase-file startmsg endmsg) - "Reads in the PHRASE-FILE, returns it as a vector of strings. -Emit STARTMSG and ENDMSG before and after. Caches the result; second -and subsequent calls on the same file won't go to disk." - (let ((sym (intern-soft phrase-file cookie-cache))) - (and sym (not (equal (symbol-function sym) - (nth 5 (file-attributes phrase-file)))) - (yes-or-no-p (concat phrase-file - " has changed. Read new contents? ")) - (setq sym nil)) - (if sym - (symbol-value sym) - (setq sym (intern phrase-file cookie-cache)) - (message "%s" startmsg) - (save-excursion - (let ((buf (generate-new-buffer "*cookie*")) - (result nil)) - (set-buffer buf) - (fset sym (nth 5 (file-attributes phrase-file))) - (insert-file-contents (expand-file-name phrase-file)) - (re-search-forward cookie-delimiter) - (while (progn (skip-chars-forward " \t\n\r\f") (not (eobp))) - (let ((beg (point))) - (re-search-forward cookie-delimiter) - (setq result (cons (buffer-substring beg (1- (point))) - result)))) - (kill-buffer buf) - (message "%s" endmsg) - (set sym (apply 'vector result))))))) - -(defun read-cookie (prompt phrase-file startmsg endmsg &optional require-match) - "Prompt with PROMPT and read with completion among cookies in PHRASE-FILE. -STARTMSG and ENDMSG are passed along to `cookie-snarf'. -Optional fifth arg REQUIRE-MATCH non-nil forces a matching cookie." - ;; Make sure the cookies are in the cache. - (or (intern-soft phrase-file cookie-cache) - (cookie-snarf phrase-file startmsg endmsg)) - (completing-read prompt - (let ((sym (intern phrase-file cookie-cache))) - ;; We cache the alist form of the cookie in a property. - (or (get sym 'completion-alist) - (let* ((alist nil) - (vec (cookie-snarf phrase-file - startmsg endmsg)) - (i (length vec))) - (while (> (setq i (1- i)) 0) - (setq alist (cons (list (aref vec i)) alist))) - (put sym 'completion-alist alist)))) - nil require-match nil nil)) - -; 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. -; -;;;###autoload -(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 (random (- len i)))) - (setq temp (aref vector i)) - (aset vector i (aref vector j)) - (aset vector j temp) - (setq i (1+ i)))) - vector) - -(provide 'cookie1) - -;;; cookie1.el ends here diff --git a/lisp/play/decipher.el b/lisp/play/decipher.el deleted file mode 100644 index 3e487ff3232..00000000000 --- a/lisp/play/decipher.el +++ /dev/null @@ -1,1057 +0,0 @@ -;;; decipher.el --- Cryptanalyze monoalphabetic substitution ciphers -;; -;; Copyright (C) 1995, 1996 Free Software Foundation, Inc. -;; -;; Author: Christopher J. Madsen <ac608@yfn.ysu.edu> -;; Keywords: games -;; -;; This file is part of GNU Emacs. -;; -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. -;; -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Quick Start: -;; -;; To decipher a message, type or load it into a buffer and type -;; `M-x decipher'. This will format the buffer and place it into -;; Decipher mode. You can save your work to a file with the normal -;; Emacs save commands; when you reload the file it will automatically -;; enter Decipher mode. -;; -;; I'm not going to discuss how to go about breaking a cipher; try -;; your local library for a book on cryptanalysis. One book you might -;; find is: -;; Cryptanalysis: A study of ciphers and their solution -;; Helen Fouche Gaines -;; ISBN 0-486-20097-3 - -;;; Commentary: -;; -;; This package is designed to help you crack simple substitution -;; ciphers where one letter stands for another. It works for ciphers -;; with or without word divisions. (You must set the variable -;; decipher-ignore-spaces for ciphers without word divisions.) -;; -;; First, some quick definitions: -;; ciphertext The encrypted message (what you start with) -;; plaintext The decrypted message (what you are trying to get) -;; -;; Decipher mode displays ciphertext in uppercase and plaintext in -;; lowercase. You must enter the plaintext in lowercase; uppercase -;; letters are interpreted as commands. The ciphertext may be entered -;; in mixed case; `M-x decipher' will convert it to uppercase. -;; -;; Decipher mode depends on special characters in the first column of -;; each line. The command `M-x decipher' inserts these characters for -;; you. The characters and their meanings are: -;; ( The plaintext & ciphertext alphabets on the first line -;; ) The ciphertext & plaintext alphabets on the second line -;; : A line of ciphertext (with plaintext below) -;; > A line of plaintext (with ciphertext above) -;; % A comment -;; Each line in the buffer MUST begin with one of these characters (or -;; be left blank). In addition, comments beginning with `%!' are reserved -;; for checkpoints; see decipher-make-checkpoint & decipher-restore-checkpoint -;; for more information. -;; -;; While the cipher message may contain digits or punctuation, Decipher -;; mode will ignore these characters. -;; -;; The buffer is made read-only so it can't be modified by normal -;; Emacs commands. -;; -;; Decipher supports Font Lock mode. To use it, you can also add -;; (add-hook 'decipher-mode-hook 'turn-on-font-lock) -;; See the variable `decipher-font-lock-keywords' if you want to customize -;; the faces used. I'd like to thank Simon Marshall for his help in making -;; Decipher work well with Font Lock. - -;;; Things To Do: -;; -;; Email me if you have any suggestions or would like to help. -;; But be aware that I work on Decipher only sporadically. -;; -;; 1. The consonant-line shortcut -;; 2. More functions for analyzing ciphertext - -;;;=================================================================== -;;; Variables: -;;;=================================================================== - -(eval-when-compile - (require 'cl)) - -(defvar decipher-force-uppercase t - "*Non-nil means to convert ciphertext to uppercase. -Nil means the case of the ciphertext is preserved. -This variable must be set before typing `\\[decipher]'.") - -(defvar decipher-ignore-spaces nil - "*Non-nil means to ignore spaces and punctuation when counting digrams. -You should set this to `nil' if the cipher message is divided into words, -or `t' if it is not. -This variable is buffer-local.") -(make-variable-buffer-local 'decipher-ignore-spaces) - -(defvar decipher-undo-limit 5000 - "The maximum number of entries in the undo list. -When the undo list exceeds this number, 100 entries are deleted from -the tail of the list.") - -;; End of user modifiable variables -;;-------------------------------------------------------------------- - -(defvar decipher-font-lock-keywords - '(("^:.*" . font-lock-keyword-face) - ("^>.*" . font-lock-string-face) - ("^%!.*" . font-lock-reference-face) - ("^%.*" . font-lock-comment-face) - ("\\`(\\([a-z]+\\) +\\([A-Z]+\\)" - (1 font-lock-string-face) - (2 font-lock-keyword-face)) - ("^)\\([A-Z ]+\\)\\([a-z ]+\\)" - (1 font-lock-keyword-face) - (2 font-lock-string-face))) - "Expressions to fontify in Decipher mode. - -Ciphertext uses `font-lock-keyword-face', plaintext uses -`font-lock-string-face', comments use `font-lock-comment-face', and -checkpoints use `font-lock-reference-face'. You can customize the -display by changing these variables. For best results, I recommend -that all faces use the same background color. - -For example, to display ciphertext in the `bold' face, use - (add-hook 'decipher-mode-hook - (lambda () (set (make-local-variable 'font-lock-keyword-face) - 'bold))) -in your `.emacs' file.") - -(defvar decipher-mode-map nil - "Keymap for Decipher mode.") -(if (not decipher-mode-map) - (progn - (setq decipher-mode-map (make-keymap)) - (suppress-keymap decipher-mode-map) - (define-key decipher-mode-map "A" 'decipher-show-alphabet) - (define-key decipher-mode-map "C" 'decipher-complete-alphabet) - (define-key decipher-mode-map "D" 'decipher-digram-list) - (define-key decipher-mode-map "F" 'decipher-frequency-count) - (define-key decipher-mode-map "M" 'decipher-make-checkpoint) - (define-key decipher-mode-map "N" 'decipher-adjacency-list) - (define-key decipher-mode-map "R" 'decipher-restore-checkpoint) - (define-key decipher-mode-map "U" 'decipher-undo) - (define-key decipher-mode-map " " 'decipher-keypress) - (substitute-key-definition 'undo 'decipher-undo - decipher-mode-map global-map) - (substitute-key-definition 'advertised-undo 'decipher-undo - decipher-mode-map global-map) - (let ((key ?a)) - (while (<= key ?z) - (define-key decipher-mode-map (vector key) 'decipher-keypress) - (incf key))))) - -(defvar decipher-stats-mode-map nil - "Keymap for Decipher-Stats mode.") -(if (not decipher-stats-mode-map) - (progn - (setq decipher-stats-mode-map (make-keymap)) - (suppress-keymap decipher-stats-mode-map) - (define-key decipher-stats-mode-map "D" 'decipher-digram-list) - (define-key decipher-stats-mode-map "F" 'decipher-frequency-count) - (define-key decipher-stats-mode-map "N" 'decipher-adjacency-list) - )) - -(defvar decipher-mode-syntax-table nil - "Decipher mode syntax table") - -(if decipher-mode-syntax-table - () - (let ((table (make-syntax-table)) - (c ?0)) - (while (<= c ?9) - (modify-syntax-entry c "_" table) ;Digits are not part of words - (incf c)) - (setq decipher-mode-syntax-table table))) - -(defvar decipher-alphabet nil) -;; This is an alist containing entries (PLAIN-CHAR . CIPHER-CHAR), -;; where PLAIN-CHAR runs from ?a to ?z and CIPHER-CHAR is an uppercase -;; letter or space (which means no mapping is known for that letter). -;; This *must* contain entries for all lowercase characters. -(make-variable-buffer-local 'decipher-alphabet) - -(defvar decipher-stats-buffer nil - "The buffer which displays statistics for this ciphertext. -Do not access this variable directly, use the function -`decipher-stats-buffer' instead.") -(make-variable-buffer-local 'decipher-stats-buffer) - -(defvar decipher-undo-list-size 0 - "The number of entries in the undo list.") -(make-variable-buffer-local 'decipher-undo-list-size) - -(defvar decipher-undo-list nil - "The undo list for this buffer. -Each element is either a cons cell (PLAIN-CHAR . CIPHER-CHAR) or a -list of such cons cells.") -(make-variable-buffer-local 'decipher-undo-list) - -(defvar decipher-pending-undo-list nil) - -;; The following variables are used by the analysis functions -;; and are defined here to avoid byte-compiler warnings. -;; Don't mess with them unless you know what you're doing. -(defvar decipher-char nil - "See the functions decipher-loop-with-breaks and decipher-loop-no-breaks.") -(defvar decipher--prev-char) -(defvar decipher--digram) -(defvar decipher--digram-list) -(defvar decipher--before) -(defvar decipher--after) -(defvar decipher--freqs) - -;;;=================================================================== -;;; Code: -;;;=================================================================== -;; Main entry points: -;;-------------------------------------------------------------------- - -;;;###autoload -(defun decipher () - "Format a buffer of ciphertext for cryptanalysis and enter Decipher mode." - (interactive) - ;; Make sure the buffer ends in a newline: - (goto-char (point-max)) - (or (bolp) - (insert "\n")) - ;; See if it's already in decipher format: - (goto-char (point-min)) - (if (looking-at "^(abcdefghijklmnopqrstuvwxyz \ -ABCDEFGHIJKLMNOPQRSTUVWXYZ -\\*-decipher-\\*-\n)") - (message "Buffer is already formatted, entering Decipher mode...") - ;; Add the alphabet at the beginning of the file - (insert "(abcdefghijklmnopqrstuvwxyz \ -ABCDEFGHIJKLMNOPQRSTUVWXYZ -*-decipher-*-\n)\n\n") - ;; Add lines for the solution: - (let (begin) - (while (not (eobp)) - (if (looking-at "^%") - (forward-line) ;Leave comments alone - (delete-horizontal-space) - (if (eolp) - (forward-line) ;Just leave blank lines alone - (insert ":") ;Mark ciphertext line - (setq begin (point)) - (forward-line) - (if decipher-force-uppercase - (upcase-region begin (point))) ;Convert ciphertext to uppercase - (insert ">\n"))))) ;Mark plaintext line - (delete-blank-lines) ;Remove any blank lines - (delete-blank-lines)) ; at end of buffer - (goto-line 4) - (decipher-mode)) - -;;;###autoload -(defun decipher-mode () - "Major mode for decrypting monoalphabetic substitution ciphers. -Lower-case letters enter plaintext. -Upper-case letters are commands. - -The buffer is made read-only so that normal Emacs commands cannot -modify it. - -The most useful commands are: -\\<decipher-mode-map> -\\[decipher-digram-list] Display a list of all digrams & their frequency -\\[decipher-frequency-count] Display the frequency of each ciphertext letter -\\[decipher-adjacency-list]\ - Show adjacency list for current letter (lists letters appearing next to it) -\\[decipher-make-checkpoint] Save the current cipher alphabet (checkpoint) -\\[decipher-restore-checkpoint] Restore a saved cipher alphabet (checkpoint)" - (interactive) - (kill-all-local-variables) - (setq buffer-undo-list t ;Disable undo - indent-tabs-mode nil ;Do not use tab characters - major-mode 'decipher-mode - mode-name "Decipher") - (if decipher-force-uppercase - (setq case-fold-search nil)) ;Case is significant when searching - (use-local-map decipher-mode-map) - (set-syntax-table decipher-mode-syntax-table) - (decipher-read-alphabet) - (set (make-local-variable 'font-lock-defaults) - '(decipher-font-lock-keywords t)) - ;; Make the buffer writable when we exit Decipher mode: - (make-local-hook 'change-major-mode-hook) - (add-hook 'change-major-mode-hook - (lambda () (setq buffer-read-only nil - buffer-undo-list nil)) - nil t) - (run-hooks 'decipher-mode-hook) - (setq buffer-read-only t)) -(put 'decipher-mode 'mode-class 'special) - -;;-------------------------------------------------------------------- -;; Normal key handling: -;;-------------------------------------------------------------------- - -(defmacro decipher-last-command-char () - ;; Return the char which ran this command (for compatibility with XEmacs) - (if (fboundp 'event-to-character) - '(event-to-character last-command-event) - 'last-command-event)) - -(defun decipher-keypress () - "Enter a plaintext or ciphertext character." - (interactive) - (let ((decipher-function 'decipher-set-map) - buffer-read-only) ;Make buffer writable - (save-excursion - (or (save-excursion - (beginning-of-line) - (let ((first-char (following-char))) - (cond - ((= ?: first-char) - t) - ((= ?> first-char) - nil) - ((= ?\( first-char) - (setq decipher-function 'decipher-alphabet-keypress) - t) - ((= ?\) first-char) - (setq decipher-function 'decipher-alphabet-keypress) - nil) - (t - (error "Bad location"))))) - (let (goal-column) - (previous-line 1))) - (let ((char-a (following-char)) - (char-b (decipher-last-command-char))) - (or (and (not (= ?w (char-syntax char-a))) - (= char-b ?\ )) ;Spacebar just advances on non-letters - (funcall decipher-function char-a char-b))))) - (forward-char)) - -(defun decipher-alphabet-keypress (a b) - ;; Handle keypresses in the alphabet lines. - ;; A is the character in the alphabet row (which starts with '(') - ;; B is the character pressed - (cond ((and (>= a ?A) (<= a ?Z)) - ;; If A is uppercase, then it is in the ciphertext alphabet: - (decipher-set-map a b)) - ((and (>= a ?a) (<= a ?z)) - ;; If A is lowercase, then it is in the plaintext alphabet: - (if (= b ?\ ) - ;; We are clearing the association (if any): - (if (/= ?\ (setq b (cdr (assoc a decipher-alphabet)))) - (decipher-set-map b ?\ )) - ;; Associate the plaintext char with the char pressed: - (decipher-set-map b a))) - (t - ;; If A is not a letter, that's a problem: - (error "Bad character")))) - -;;-------------------------------------------------------------------- -;; Undo: -;;-------------------------------------------------------------------- - -(defun decipher-undo () - "Undo a change in Decipher mode." - (interactive) - ;; If we don't get all the way thru, make last-command indicate that - ;; for the following command. - (setq this-command t) - (or (eq major-mode 'decipher-mode) - (error "This buffer is not in Decipher mode")) - (or (eq last-command 'decipher-undo) - (setq decipher-pending-undo-list decipher-undo-list)) - (or decipher-pending-undo-list - (error "No further undo information")) - (let ((undo-rec (pop decipher-pending-undo-list)) - buffer-read-only ;Make buffer writable - redo-map redo-rec undo-map) - (or (consp (car undo-rec)) - (setq undo-rec (list undo-rec))) - (while (setq undo-map (pop undo-rec)) - (setq redo-map (decipher-get-undo (cdr undo-map) (car undo-map))) - (if redo-map - (setq redo-rec - (if (consp (car redo-map)) - (append redo-map redo-rec) - (cons redo-map redo-rec)))) - (decipher-set-map (cdr undo-map) (car undo-map) t)) - (decipher-add-undo redo-rec)) - (setq this-command 'decipher-undo) - (message "Undo!")) - -(defun decipher-add-undo (undo-rec) - "Add UNDO-REC to the undo list." - (if undo-rec - (progn - (push undo-rec decipher-undo-list) - (incf decipher-undo-list-size) - (if (> decipher-undo-list-size decipher-undo-limit) - (let ((new-size (- decipher-undo-limit 100))) - ;; Truncate undo list to NEW-SIZE elements: - (setcdr (nthcdr (1- new-size) decipher-undo-list) nil) - (setq decipher-undo-list-size new-size)))))) - -(defun decipher-get-undo-copy (cons) - (if cons - (cons (car cons) (cdr cons)))) - -(defun decipher-get-undo (cipher-char plain-char) - ;; Return an undo record that will undo the result of - ;; (decipher-set-map CIPHER-CHAR PLAIN-CHAR) - ;; We must copy the cons cell because the original cons cells will be - ;; modified using setcdr. - (let ((cipher-map (decipher-get-undo-copy (rassoc cipher-char decipher-alphabet))) - (plain-map (decipher-get-undo-copy (assoc plain-char decipher-alphabet)))) - (cond ((equal ?\ plain-char) - cipher-map) - ((equal cipher-char (cdr plain-map)) - nil) ;We aren't changing anything - ((equal ?\ (cdr plain-map)) - (or cipher-map (cons ?\ cipher-char))) - (cipher-map - (list plain-map cipher-map)) - (t - plain-map)))) - -;;-------------------------------------------------------------------- -;; Mapping ciphertext and plaintext: -;;-------------------------------------------------------------------- - -(defun decipher-set-map (cipher-char plain-char &optional no-undo) - ;; Associate a ciphertext letter with a plaintext letter - ;; CIPHER-CHAR must be an uppercase or lowercase letter - ;; PLAIN-CHAR must be a lowercase letter (or a space) - ;; NO-UNDO if non-nil means do not record undo information - ;; Any existing associations for CIPHER-CHAR or PLAIN-CHAR will be erased. - (setq cipher-char (upcase cipher-char)) - (or (and (>= cipher-char ?A) (<= cipher-char ?Z)) - (error "Bad character")) ;Cipher char must be uppercase letter - (or no-undo - (decipher-add-undo (decipher-get-undo cipher-char plain-char))) - (let ((cipher-string (char-to-string cipher-char)) - (plain-string (char-to-string plain-char)) - case-fold-search ;Case is significant - mapping bound) - (save-excursion - (goto-char (point-min)) - (if (setq mapping (rassoc cipher-char decipher-alphabet)) - (progn - (setcdr mapping ?\ ) - (search-forward-regexp (concat "^([a-z]*" - (char-to-string (car mapping)))) - (decipher-insert ?\ ) - (beginning-of-line))) - (if (setq mapping (assoc plain-char decipher-alphabet)) - (progn - (if (/= ?\ (cdr mapping)) - (decipher-set-map (cdr mapping) ?\ t)) - (setcdr mapping cipher-char) - (search-forward-regexp (concat "^([a-z]*" plain-string)) - (decipher-insert cipher-char) - (beginning-of-line))) - (search-forward-regexp (concat "^([a-z]+ [A-Z]*" cipher-string)) - (decipher-insert plain-char) - (setq case-fold-search t ;Case is not significant - cipher-string (downcase cipher-string)) - (let ((font-lock-fontify-region-function 'ignore)) - ;; insert-and-inherit will pick the right face automatically - (while (search-forward-regexp "^:" nil t) - (setq bound (save-excursion (end-of-line) (point))) - (while (search-forward cipher-string bound 'end) - (decipher-insert plain-char))))))) - -(defun decipher-insert (char) - ;; Insert CHAR in the row below point. It replaces any existing - ;; character in that position. - (let ((col (1- (current-column)))) - (save-excursion - (forward-line) - (or (= ?\> (following-char)) - (= ?\) (following-char)) - (error "Bad location")) - (move-to-column col t) - (or (eolp) - (delete-char 1)) - (insert-and-inherit char)))) - -;;-------------------------------------------------------------------- -;; Checkpoints: -;;-------------------------------------------------------------------- -;; A checkpoint is a comment of the form: -;; %!ABCDEFGHIJKLMNOPQRSTUVWXYZ! Description -;; Such comments are usually placed at the end of the buffer following -;; this header (which is inserted by decipher-make-checkpoint): -;; %--------------------------- -;; % Checkpoints: -;; % abcdefghijklmnopqrstuvwxyz -;; but this is not required; checkpoints can be placed anywhere. -;; -;; The description is optional; all that is required is the alphabet. - -(defun decipher-make-checkpoint (desc) - "Checkpoint the current cipher alphabet. -This records the current alphabet so you can return to it later. -You may have any number of checkpoints. -Type `\\[decipher-restore-checkpoint]' to restore a checkpoint." - (interactive "sCheckpoint description: ") - (or (stringp desc) - (setq desc "")) - (let (alphabet - buffer-read-only ;Make buffer writable - mapping) - (goto-char (point-min)) - (re-search-forward "^)") - (move-to-column 27 t) - (setq alphabet (buffer-substring-no-properties (- (point) 26) (point))) - (if (re-search-forward "^%![A-Z ]+!" nil 'end) - nil ; Add new checkpoint with others - (if (re-search-backward "^% *Local Variables:" nil t) - ;; Add checkpoints before local variables list: - (progn (forward-line -1) - (or (looking-at "^ *$") - (progn (forward-line) (insert ?\n) (forward-line -1))))) - (insert "\n%" (make-string 69 ?\-) - "\n% Checkpoints:\n% abcdefghijklmnopqrstuvwxyz\n")) - (beginning-of-line) - (insert "%!" alphabet "! " desc ?\n))) - -(defun decipher-restore-checkpoint () - "Restore the cipher alphabet from a checkpoint. -If point is not on a checkpoint line, moves to the first checkpoint line. -If point is on a checkpoint, restores that checkpoint. - -Type `\\[decipher-make-checkpoint]' to make a checkpoint." - (interactive) - (beginning-of-line) - (if (looking-at "%!\\([A-Z ]+\\)!") - ;; Restore this checkpoint: - (let ((alphabet (match-string 1)) - buffer-read-only) ;Make buffer writable - (goto-char (point-min)) - (re-search-forward "^)") - (or (eolp) - (delete-region (point) (progn (end-of-line) (point)))) - (insert alphabet) - (decipher-resync)) - ;; Move to the first checkpoint: - (goto-char (point-min)) - (if (re-search-forward "^%![A-Z ]+!" nil t) - (message "Select the checkpoint to restore and type `%s'" - (substitute-command-keys "\\[decipher-restore-checkpoint]")) - (error "No checkpoints in this buffer")))) - -;;-------------------------------------------------------------------- -;; Miscellaneous commands: -;;-------------------------------------------------------------------- - -(defun decipher-complete-alphabet () - "Complete the cipher alphabet. -This fills any blanks in the cipher alphabet with the unused letters -in alphabetical order. Use this when you have a keyword cipher and -you have determined the keyword." - (interactive) - (let ((cipher-char ?A) - (ptr decipher-alphabet) - buffer-read-only ;Make buffer writable - plain-map undo-rec) - (while (setq plain-map (pop ptr)) - (if (equal ?\ (cdr plain-map)) - (progn - (while (rassoc cipher-char decipher-alphabet) - ;; Find the next unused letter - (incf cipher-char)) - (push (cons ?\ cipher-char) undo-rec) - (decipher-set-map cipher-char (car plain-map) t)))) - (decipher-add-undo undo-rec))) - -(defun decipher-show-alphabet () - "Display the current cipher alphabet in the message line." - (interactive) - (message - (mapconcat (lambda (a) - (concat - (char-to-string (car a)) - (char-to-string (cdr a)))) - decipher-alphabet - ""))) - -(defun decipher-resync () - "Reprocess the buffer using the alphabet from the top. -This regenerates all deciphered plaintext and clears the undo list. -You should use this if you edit the ciphertext." - (interactive) - (message "Reprocessing buffer...") - (let (alphabet - buffer-read-only ;Make buffer writable - mapping) - (save-excursion - (decipher-read-alphabet) - (setq alphabet decipher-alphabet) - (goto-char (point-min)) - (and (re-search-forward "^).+" nil t) - (replace-match ")" nil nil)) - (while (re-search-forward "^>.+" nil t) - (replace-match ">" nil nil)) - (decipher-read-alphabet) - (while (setq mapping (pop alphabet)) - (or (equal ?\ (cdr mapping)) - (decipher-set-map (cdr mapping) (car mapping)))))) - (setq decipher-undo-list nil - decipher-undo-list-size 0) - (message "Reprocessing buffer...done")) - -;;-------------------------------------------------------------------- -;; Miscellaneous functions: -;;-------------------------------------------------------------------- - -(defun decipher-read-alphabet () - "Build the decipher-alphabet from the alphabet line in the buffer." - (save-excursion - (goto-char (point-min)) - (search-forward-regexp "^)") - (move-to-column 27 t) - (setq decipher-alphabet nil) - (let ((plain-char ?z)) - (while (>= plain-char ?a) - (backward-char) - (push (cons plain-char (following-char)) decipher-alphabet) - (decf plain-char))))) - -;;;=================================================================== -;;; Analyzing ciphertext: -;;;=================================================================== - -(defun decipher-frequency-count () - "Display the frequency count in the statistics buffer." - (interactive) - (decipher-analyze) - (decipher-display-regexp "^A" "^[A-Z][A-Z]")) - -(defun decipher-digram-list () - "Display the list of digrams in the statistics buffer." - (interactive) - (decipher-analyze) - (decipher-display-regexp "[A-Z][A-Z] +[0-9]" "^$")) - -(defun decipher-adjacency-list (cipher-char) - "Display the adjacency list for the letter at point. -The adjacency list shows all letters which come next to CIPHER-CHAR. - -An adjacency list (for the letter X) looks like this: - 1 1 1 1 1 3 2 1 3 8 -X: A B C D E F G H I J K L M N O P Q R S T U V W X Y Z * 11 14 9% - 1 1 1 2 1 1 2 5 7 -This says that X comes before D once, and after B once. X begins 5 -words, and ends 3 words (`*' represents a space). X comes before 8 -different letters, after 7 differerent letters, and is next to a total -of 11 different letters. It occurs 14 times, making up 9% of the -ciphertext." - (interactive (list (upcase (following-char)))) - (decipher-analyze) - (let (start end) - (save-excursion - (set-buffer (decipher-stats-buffer)) - (goto-char (point-min)) - (or (re-search-forward (format "^%c: " cipher-char) nil t) - (error "Character `%c' is not used in ciphertext." cipher-char)) - (forward-line -1) - (setq start (point)) - (forward-line 3) - (setq end (point))) - (decipher-display-range start end))) - -;;-------------------------------------------------------------------- -(defun decipher-analyze () - "Perform frequency analysis on the current buffer if necessary." - (cond - ;; If this is the statistics buffer, do nothing: - ((eq major-mode 'decipher-stats-mode)) - ;; If this is the Decipher buffer, see if the stats buffer exists: - ((eq major-mode 'decipher-mode) - (or (and (bufferp decipher-stats-buffer) - (buffer-name decipher-stats-buffer)) - (decipher-analyze-buffer))) - ;; Otherwise: - (t (error "This buffer is not in Decipher mode")))) - -;;-------------------------------------------------------------------- -(defun decipher-display-range (start end) - "Display text between START and END in the statistics buffer. -START and END are positions in the statistics buffer. Makes the -statistics buffer visible and sizes the window to just fit the -displayed text, but leaves the current window selected." - (let ((stats-buffer (decipher-stats-buffer)) - (current-window (selected-window)) - (pop-up-windows t)) - (or (eq (current-buffer) stats-buffer) - (pop-to-buffer stats-buffer)) - (goto-char start) - (or (one-window-p t) - (enlarge-window (- (1+ (count-lines start end)) (window-height)))) - (recenter 0) - (select-window current-window))) - -(defun decipher-display-regexp (start-regexp end-regexp) - "Display text between two regexps in the statistics buffer. - -START-REGEXP matches the first line to display. -END-REGEXP matches the line after that which ends the display. -The ending line is included in the display unless it is blank." - (let (start end) - (save-excursion - (set-buffer (decipher-stats-buffer)) - (goto-char (point-min)) - (re-search-forward start-regexp) - (beginning-of-line) - (setq start (point)) - (re-search-forward end-regexp) - (beginning-of-line) - (or (looking-at "^ *$") - (forward-line 1)) - (setq end (point))) - (decipher-display-range start end))) - -;;-------------------------------------------------------------------- -(defun decipher-loop-with-breaks (func) - "Loop through ciphertext, calling FUNC once for each letter & word division. - -FUNC is called with no arguments, and its return value is unimportant. -It may examine `decipher-char' to see the current ciphertext -character. `decipher-char' contains either an uppercase letter or a space. - -FUNC is called exactly once between words, with `decipher-char' set to -a space. - -See `decipher-loop-no-breaks' if you do not care about word divisions." - (let ((decipher-char ?\ ) - (decipher--loop-prev-char ?\ )) - (save-excursion - (goto-char (point-min)) - (funcall func) ;Space marks beginning of first word - (while (search-forward-regexp "^:" nil t) - (while (not (eolp)) - (setq decipher-char (upcase (following-char))) - (or (and (>= decipher-char ?A) (<= decipher-char ?Z)) - (setq decipher-char ?\ )) - (or (and (equal decipher-char ?\ ) - (equal decipher--loop-prev-char ?\ )) - (funcall func)) - (setq decipher--loop-prev-char decipher-char) - (forward-char)) - (or (equal decipher-char ?\ ) - (progn - (setq decipher-char ?\ ; - decipher--loop-prev-char ?\ ) - (funcall func))))))) - -(defun decipher-loop-no-breaks (func) - "Loop through ciphertext, calling FUNC once for each letter. - -FUNC is called with no arguments, and its return value is unimportant. -It may examine `decipher-char' to see the current ciphertext letter. -`decipher-char' contains an uppercase letter. - -Punctuation and spacing in the ciphertext are ignored. -See `decipher-loop-with-breaks' if you care about word divisions." - (let (decipher-char) - (save-excursion - (goto-char (point-min)) - (while (search-forward-regexp "^:" nil t) - (while (not (eolp)) - (setq decipher-char (upcase (following-char))) - (and (>= decipher-char ?A) - (<= decipher-char ?Z) - (funcall func)) - (forward-char)))))) - -;;-------------------------------------------------------------------- -;; Perform the analysis: -;;-------------------------------------------------------------------- - -(defun decipher-insert-frequency-counts (freq-list total) - "Insert frequency counts in current buffer. -Each element of FREQ-LIST is a list (LETTER FREQ ...). -TOTAL is the total number of letters in the ciphertext." - (let ((i 4) temp-list) - (while (> i 0) - (setq temp-list freq-list) - (while temp-list - (insert (caar temp-list) - (format "%4d%3d%% " - (cadar temp-list) - (/ (* 100 (cadar temp-list)) total))) - (setq temp-list (nthcdr 4 temp-list))) - (insert ?\n) - (setq freq-list (cdr freq-list) - i (1- i))))) - -(defun decipher--analyze () - ;; Perform frequency analysis on ciphertext. - ;; - ;; This function is called repeatedly with decipher-char set to each - ;; character of ciphertext. It uses decipher--prev-char to remember - ;; the previous ciphertext character. - ;; - ;; It builds several data structures, which must be initialized - ;; before the first call to decipher--analyze. The arrays are - ;; indexed with A = 0, B = 1, ..., Z = 25, SPC = 26 (if used). - ;; decipher--after: (initialize to zeros) - ;; A vector of 26 vectors of 27 integers. The first vector - ;; represents the number of times A follows each character, the - ;; second vector represents B, and so on. - ;; decipher--before: (initialize to zeros) - ;; The same as decipher--after, but representing the number of - ;; times the character precedes each other character. - ;; decipher--digram-list: (initialize to nil) - ;; An alist with an entry for each digram (2-character sequence) - ;; encountered. Each element is a cons cell (DIGRAM . FREQ), - ;; where DIGRAM is a 2 character string and FREQ is the number - ;; of times it occurs. - ;; decipher--freqs: (initialize to zeros) - ;; A vector of 26 integers, counting the number of occurrences - ;; of the corresponding characters. - (setq decipher--digram (format "%c%c" decipher--prev-char decipher-char)) - (incf (cdr (or (assoc decipher--digram decipher--digram-list) - (car (push (cons decipher--digram 0) - decipher--digram-list))))) - (and (>= decipher--prev-char ?A) - (incf (aref (aref decipher--before (- decipher--prev-char ?A)) - (if (equal decipher-char ?\ ) - 26 - (- decipher-char ?A))))) - (and (>= decipher-char ?A) - (incf (aref decipher--freqs (- decipher-char ?A))) - (incf (aref (aref decipher--after (- decipher-char ?A)) - (if (equal decipher--prev-char ?\ ) - 26 - (- decipher--prev-char ?A))))) - (setq decipher--prev-char decipher-char)) - -(defun decipher--digram-counts (counts) - "Generate the counts for an adjacency list." - (let ((total 0)) - (concat - (mapconcat (lambda (x) - (cond ((> x 99) (incf total) "XX") - ((> x 0) (incf total) (format "%2d" x)) - (t " "))) - counts - "") - (format "%4d" (if (> (aref counts 26) 0) - (1- total) ;Don't count space - total))))) - -(defun decipher--digram-total (before-count after-count) - "Count the number of different letters a letter appears next to." - ;; We do not include spaces (word divisions) in this count. - (let ((total 0) - (i 26)) - (while (>= (decf i) 0) - (if (or (> (aref before-count i) 0) - (> (aref after-count i) 0)) - (incf total))) - total)) - -(defun decipher-analyze-buffer () - "Perform frequency analysis and store results in statistics buffer. -Creates the statistics buffer if it doesn't exist." - (let ((decipher--prev-char (if decipher-ignore-spaces ?\ ?\*)) - (decipher--before (make-vector 26 nil)) - (decipher--after (make-vector 26 nil)) - (decipher--freqs (make-vector 26 0)) - (total-chars 0) - decipher--digram decipher--digram-list freq-list) - (message "Scanning buffer...") - (let ((i 26)) - (while (>= (decf i) 0) - (aset decipher--before i (make-vector 27 0)) - (aset decipher--after i (make-vector 27 0)))) - (if decipher-ignore-spaces - (progn - (decipher-loop-no-breaks 'decipher--analyze) - ;; The first character of ciphertext was marked as following a space: - (let ((i 26)) - (while (>= (decf i) 0) - (aset (aref decipher--after i) 26 0)))) - (decipher-loop-with-breaks 'decipher--analyze)) - (message "Processing results...") - (setcdr (last decipher--digram-list 2) nil) ;Delete the phony "* " digram - ;; Sort the digram list by frequency and alphabetical order: - (setq decipher--digram-list (sort (sort decipher--digram-list - (lambda (a b) (string< (car a) (car b)))) - (lambda (a b) (> (cdr a) (cdr b))))) - ;; Generate the frequency list: - ;; Each element is a list of 3 elements (LETTER FREQ DIFFERENT), - ;; where LETTER is the ciphertext character, FREQ is the number - ;; of times it occurs, and DIFFERENT is the number of different - ;; letters it appears next to. - (let ((i 26)) - (while (>= (decf i) 0) - (setq freq-list - (cons (list (+ i ?A) - (aref decipher--freqs i) - (decipher--digram-total (aref decipher--before i) - (aref decipher--after i))) - freq-list) - total-chars (+ total-chars (aref decipher--freqs i))))) - (save-excursion - ;; Switch to statistics buffer, creating it if necessary: - (set-buffer (decipher-stats-buffer t)) - ;; This can't happen, but it never hurts to double-check: - (or (eq major-mode 'decipher-stats-mode) - (error "Buffer %s is not in Decipher-Stats mode" (buffer-name))) - (setq buffer-read-only nil) - (erase-buffer) - ;; Display frequency counts for letters A-Z: - (decipher-insert-frequency-counts freq-list total-chars) - (insert ?\n) - ;; Display frequency counts for letters in order of frequency: - (setq freq-list (sort freq-list - (lambda (a b) (> (second a) (second b))))) - (decipher-insert-frequency-counts freq-list total-chars) - ;; Display letters in order of frequency: - (insert ?\n (mapconcat (lambda (a) (char-to-string (car a))) - freq-list nil) - "\n\n") - ;; Display list of digrams in order of frequency: - (let* ((rows (floor (+ (length decipher--digram-list) 9) 10)) - (i rows) - temp-list) - (while (> i 0) - (setq temp-list decipher--digram-list) - (while temp-list - (insert (caar temp-list) - (format "%3d " - (cdar temp-list))) - (setq temp-list (nthcdr rows temp-list))) - (delete-horizontal-space) - (insert ?\n) - (setq decipher--digram-list (cdr decipher--digram-list) - i (1- i)))) - ;; Display adjacency list for each letter, sorted in descending - ;; order of the number of adjacent letters: - (setq freq-list (sort freq-list - (lambda (a b) (> (third a) (third b))))) - (let ((temp-list freq-list) - entry i) - (while (setq entry (pop temp-list)) - (if (equal 0 (second entry)) - nil ;This letter was not used - (setq i (- (car entry) ?A)) - (insert ?\n " " - (decipher--digram-counts (aref decipher--before i)) ?\n - (car entry) - ": A B C D E F G H I J K L M N O P Q R S T U V W X Y Z *" - (format "%4d %4d %3d%%\n " - (third entry) (second entry) - (/ (* 100 (second entry)) total-chars)) - (decipher--digram-counts (aref decipher--after i)) ?\n)))) - (setq buffer-read-only t) - (set-buffer-modified-p nil) - )) - (message nil)) - -;;==================================================================== -;; Statistics Buffer: -;;==================================================================== - -(defun decipher-stats-mode () - "Major mode for displaying ciphertext statistics." - (interactive) - (kill-all-local-variables) - (setq buffer-read-only t - buffer-undo-list t ;Disable undo - case-fold-search nil ;Case is significant when searching - indent-tabs-mode nil ;Do not use tab characters - major-mode 'decipher-stats-mode - mode-name "Decipher-Stats") - (use-local-map decipher-stats-mode-map) - (run-hooks 'decipher-stats-mode-hook)) -(put 'decipher-stats-mode 'mode-class 'special) - -;;-------------------------------------------------------------------- - -(defun decipher-display-stats-buffer () - "Make the statistics buffer visible, but do not select it." - (let ((stats-buffer (decipher-stats-buffer)) - (current-window (selected-window))) - (or (eq (current-buffer) stats-buffer) - (progn - (pop-to-buffer stats-buffer) - (select-window current-window))))) - -(defun decipher-stats-buffer (&optional create) - "Return the buffer used for decipher statistics. -If CREATE is non-nil, create the buffer if it doesn't exist. -This is guaranteed to return a buffer in Decipher-Stats mode; -if it can't, it signals an error." - (cond - ;; We may already be in the statistics buffer: - ((eq major-mode 'decipher-stats-mode) - (current-buffer)) - ;; See if decipher-stats-buffer exists: - ((and (bufferp decipher-stats-buffer) - (buffer-name decipher-stats-buffer)) - (or (save-excursion - (set-buffer decipher-stats-buffer) - (eq major-mode 'decipher-stats-mode)) - (error "Buffer %s is not in Decipher-Stats mode" - (buffer-name decipher-stats-buffer))) - decipher-stats-buffer) - ;; Create a new buffer if requested: - (create - (let ((stats-name (concat "*" (buffer-name) "*"))) - (setq decipher-stats-buffer - (if (eq 'decipher-stats-mode - (cdr-safe (assoc 'major-mode - (buffer-local-variables - (get-buffer stats-name))))) - ;; We just lost track of the statistics buffer: - (get-buffer stats-name) - (generate-new-buffer stats-name)))) - (save-excursion - (set-buffer decipher-stats-buffer) - (decipher-stats-mode)) - decipher-stats-buffer) - ;; Give up: - (t (error "No statistics buffer")))) - -;;==================================================================== - -(provide 'decipher) - -;;;(defun decipher-show-undo-list () -;;; "Display the undo list (for debugging purposes)." -;;; (interactive) -;;; (with-output-to-temp-buffer "*Decipher Undo*" -;;; (let ((undo-list decipher-undo-list) -;;; undo-rec undo-map) -;;; (save-excursion -;;; (set-buffer "*Decipher Undo*") -;;; (while (setq undo-rec (pop undo-list)) -;;; (or (consp (car undo-rec)) -;;; (setq undo-rec (list undo-rec))) -;;; (insert ?\() -;;; (while (setq undo-map (pop undo-rec)) -;;; (insert (cdr undo-map) (car undo-map) ?\ )) -;;; (delete-backward-char 1) -;;; (insert ")\n")))))) - -;;; decipher.el ends here diff --git a/lisp/play/dissociate.el b/lisp/play/dissociate.el deleted file mode 100644 index 93a9f9e79ab..00000000000 --- a/lisp/play/dissociate.el +++ /dev/null @@ -1,101 +0,0 @@ -;;; dissociate.el --- scramble text amusingly for Emacs. - -;; Copyright (C) 1985 Free Software Foundation, Inc. - -;; Maintainer: FSF -;; Keywords: games - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; The single entry point, `dissociated-press', applies a travesty -;; generator to the current buffer. The results can be quite amusing. - -;;; Code: - -;;;###autoload -(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)) - (if (= (point-max) (point-min)) - (error "The buffer contains no text to start from")) - (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)))) - (goto-char (1+ (random (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)))) - -;;; dissociate.el ends here diff --git a/lisp/play/doctor.el b/lisp/play/doctor.el deleted file mode 100644 index faba5e1cf26..00000000000 --- a/lisp/play/doctor.el +++ /dev/null @@ -1,1614 +0,0 @@ -;;; doctor.el --- psychological help for frustrated users. -;;; (censored version--see below) - -;; Copyright (C) 1985, 1987, 1994, 1996 Free Software Foundation, Inc. - -;; Maintainer: FSF -;; Keywords: games - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; The single entry point `doctor', simulates a Rogerian analyst using -;; phrase-production techniques similar to the classic ELIZA demonstration -;; of pseudo-AI. - -;; This file has been censored by the Communications Decency Act. -;; Some of its features were removed. The law was promoted as a ban -;; on pornography, but it bans far more than that. The doctor program -;; did not contain pornography, but part of it was prohibited -;; nonetheless. - -;; For information on US government censorship of the Internet, and -;; what you can do to bring back freedom of the press, see the web -;; site http://www.vtw.org/ - -;;; Code: - -(defun doctor-cadr (x) (car (cdr x))) -(defun doctor-caddr (x) (car (cdr (cdr x)))) -(defun doctor-cddr (x) (cdr (cdr x))) - -(defun // (x) x) - -(defmacro $ (what) - "quoted arg form of doctor-$" - (list 'doctor-$ (list 'quote what))) - -(defun doctor-$ (what) - "Return the car of a list, rotating the list each time" - (let* ((vv (symbol-value what)) - (first (car vv)) - (ww (append (cdr vv) (list first)))) - (set what ww) - first)) - -(defvar doctor-mode-map nil) -(if doctor-mode-map - nil - (setq doctor-mode-map (make-sparse-keymap)) - (define-key doctor-mode-map "\n" 'doctor-read-print) - (define-key doctor-mode-map "\r" 'doctor-ret-or-read)) - -(defun doctor-mode () - "Major mode for running the Doctor (Eliza) program. -Like Text mode with Auto Fill mode -except that RET when point is after a newline, or LFD at any time, -reads the sentence before point, and prints the Doctor's answer." - (interactive) - (text-mode) - (make-doctor-variables) - (use-local-map doctor-mode-map) - (setq major-mode 'doctor-mode) - (setq mode-name "Doctor") - (turn-on-auto-fill) - (doctor-type '(i am the psychotherapist \. - for your protection, i have been censored according to - the Communications Decency Act \. - ($ please) ($ describe) your ($ problems) \. - each time you are finished talking, type \R\E\T twice \.)) - (insert "\n")) - -(defun make-doctor-variables () - (make-local-variable 'typos) - (setq typos - (mapcar (function (lambda (x) - (put (car x) 'doctor-correction (doctor-cadr x)) - (put (doctor-cadr x) 'doctor-expansion (doctor-caddr x)) - (car x))) - '((theyll they\'ll (they will)) - (theyre they\'re (they are)) - (hes he\'s (he is)) - (he7s he\'s (he is)) - (im i\'m (you are)) - (i7m i\'m (you are)) - (isa is\ a (is a)) - (thier their (their)) - (dont don\'t (do not)) - (don7t don\'t (do not)) - (you7re you\'re (i am)) - (you7ve you\'ve (i have)) - (you7ll you\'ll (i will))))) - (make-local-variable 'found) - (setq found nil) - (make-local-variable 'owner) - (setq owner nil) - (make-local-variable 'history) - (setq history nil) - (make-local-variable '*debug*) - (setq *debug* nil) - (make-local-variable 'inter) - (setq inter - '((well\,) - (hmmm \.\.\.\ so\,) - (so) - (\.\.\.and) - (then))) - (make-local-variable 'continue) - (setq continue - '((continue) - (proceed) - (go on) - (keep going) )) - (make-local-variable 'relation) - (setq relation - '((your relationship with) - (something you remember about) - (your feelings toward) - (some experiences you have had with) - (how you feel about))) - (make-local-variable 'fears) - (setq fears '( (($ whysay) you are ($ afraidof) (// feared) \?) - (you seem terrified by (// feared) \.) - (when did you first feel ($ afraidof) (// feared) \?) )) - (make-local-variable 'sure) - (setq sure '((sure)(positive)(certain)(absolutely sure))) - (make-local-variable 'afraidof) - (setq afraidof '( (afraid of) (frightened by) (scared of) )) - (make-local-variable 'areyou) - (setq areyou '( (are you)(have you been)(have you been) )) - (make-local-variable 'isrelated) - (setq isrelated '( (has something to do with)(is related to) - (could be the reason for) (is caused by)(is because of))) - (make-local-variable 'arerelated) - (setq arerelated '((have something to do with)(are related to) - (could have caused)(could be the reason for) (are caused by) - (are because of))) - (make-local-variable 'moods) - (setq moods '( (($ areyou)(// found) often \?) - (what causes you to be (// found) \?) - (($ whysay) you are (// found) \?) )) - (make-local-variable 'maybe) - (setq maybe - '((maybe) - (perhaps) - (possibly))) - (make-local-variable 'whatwhen) - (setq whatwhen - '((what happened when) - (what would happen if))) - (make-local-variable 'hello) - (setq hello - '((how do you do \?) (hello \.) (howdy!) (hello \.) (hi \.) (hi there \.))) - (make-local-variable 'drnk) - (setq drnk - '((do you drink a lot of (// found) \?) - (do you get drunk often \?) - (($ describe) your drinking habits \.) )) - (make-local-variable 'drugs) - (setq drugs '( (do you use (// found) often \?)(($ areyou) - addicted to (// found) \?)(do you realize that drugs can - be very harmful \?)(($ maybe) you should try to quit using (// found) - \.))) - (make-local-variable 'whywant) - (setq whywant '( (($ whysay) (// subj) might ($ want) (// obj) \?) - (how does it feel to want \?) - (why should (// subj) get (// obj) \?) - (when did (// subj) first ($ want) (// obj) \?) - (($ areyou) obsessed with (// obj) \?) - (why should i give (// obj) to (// subj) \?) - (have you ever gotten (// obj) \?) )) - (make-local-variable 'canyou) - (setq canyou '((of course i can \.) - (why should i \?) - (what makes you think i would even want to \?) - (i am the doctor\, i can do anything i damn please \.) - (not really\, it\'s not up to me \.) - (depends\, how important is it \?) - (i could\, but i don\'t think it would be a wise thing to do \.) - (can you \?) - (maybe i can\, maybe i can\'t \.\.\.) - (i don\'t think i should do that \.))) - (make-local-variable 'want) - (setq want '( (want) (desire) (wish) (want) (hope) )) - (make-local-variable 'shortlst) - (setq shortlst - '((can you elaborate on that \?) - (($ please) continue \.) - (go on\, don\'t be afraid \.) - (i need a little more detail please \.) - (you\'re being a bit brief\, ($ please) go into detail \.) - (can you be more explicit \?) - (and \?) - (($ please) go into more detail \?) - (you aren\'t being very talkative today\!) - (is that all there is to it \?) - (why must you respond so briefly \?))) - - (make-local-variable 'famlst) - (setq famlst - '((tell me ($ something) about (// owner) family \.) - (you seem to dwell on (// owner) family \.) - (($ areyou) hung up on (// owner) family \?))) - (make-local-variable 'huhlst) - (setq huhlst - '((($ whysay)(// sent) \?) - (is it because of ($ things) that you say (// sent) \?) )) - (make-local-variable 'longhuhlst) - (setq longhuhlst - '((($ whysay) that \?) - (i don\'t understand \.) - (($ thlst)) - (($ areyou) ($ afraidof) that \?))) - (make-local-variable 'feelings-about) - (setq feelings-about - '((feelings about) - (apprehensions toward) - (thoughts on) - (emotions toward))) - (make-local-variable 'random-adjective) - (setq random-adjective - '((vivid) - (emotionally stimulating) - (exciting) - (boring) - (interesting) - (recent) - (random) ;How can we omit this? - (unusual) - (shocking) - (embarrassing))) - (make-local-variable 'whysay) - (setq whysay - '((why do you say) - (what makes you believe) - (are you sure that) - (do you really think) - (what makes you think) )) - (make-local-variable 'isee) - (setq isee - '((i see \.\.\.) - (yes\,) - (i understand \.) - (oh \.) )) - (make-local-variable 'please) - (setq please - '((please\,) - (i would appreciate it if you would) - (perhaps you could) - (please\,) - (would you please) - (why don\'t you) - (could you))) - (make-local-variable 'bye) - (setq bye - '((my secretary will send you a bill \.) - (bye bye \.) - (see ya \.) - (ok\, talk to you some other time \.) - (talk to you later \.) - (ok\, have fun \.) - (ciao \.))) - (make-local-variable 'something) - (setq something - '((something) - (more) - (how you feel))) - (make-local-variable 'things) - (setq things - '(;(your interests in computers) ;; let's make this less computer oriented - ;(the machines you use) - (your plans) - ;(your use of computers) - (your life) - ;(other machines you use) - (the people you hang around with) - ;(computers you like) - (problems at school) - (any hobbies you have) - ;(other computers you use) - (your sex life) - (hangups you have) - (your inhibitions) - (some problems in your childhood) - ;(knowledge of computers) - (some problems at home))) - (make-local-variable 'describe) - (setq describe - '((describe) - (tell me about) - (talk about) - (discuss) - (tell me more about) - (elaborate on))) - (make-local-variable 'ibelieve) - (setq ibelieve - '((i believe) (i think) (i have a feeling) (it seems to me that) - (it looks like))) - (make-local-variable 'problems) - (setq problems '( (problems) - (inhibitions) - (hangups) - (difficulties) - (anxieties) - (frustrations) )) - (make-local-variable 'bother) - (setq bother - '((does it bother you that) - (are you annoyed that) - (did you ever regret) - (are you sorry) - (are you satisfied with the fact that))) - (make-local-variable 'machlst) - (setq machlst - '((you have your mind on (// found) \, it seems \.) - (you think too much about (// found) \.) - (you should try taking your mind off of (// found)\.) - (are you a computer hacker \?))) - (make-local-variable 'qlist) - (setq qlist - '((what do you think \?) - (i\'ll ask the questions\, if you don\'t mind!) - (i could ask the same thing myself \.) - (($ please) allow me to do the questioning \.) - (i have asked myself that question many times \.) - (($ please) try to answer that question yourself \.))) - (make-local-variable 'foullst) - (setq foullst - '((($ please) watch your tongue!) - (($ please) avoid such unwholesome thoughts \.) - (($ please) get your mind out of the gutter \.) - (such lewdness is not appreciated \.))) - (make-local-variable 'deathlst) - (setq deathlst - '((this is not a healthy way of thinking \.) - (($ bother) you\, too\, may die someday \?) - (i am worried by your obsession with this topic!) - (did you watch a lot of crime and violence on television as a child \?)) - ) - (make-local-variable 'sexlst) - (setq sexlst - '((($ areyou) ($ afraidof) sex \?) - (($ describe)($ something) about your sexual history \.) - (($ please)($ describe) your sex life \.\.\.) - (($ describe) your ($ feelings-about) your sexual partner \.) - (($ describe) your most ($ random-adjective) sexual experience \.) - (($ areyou) satisfied with (// lover) \.\.\. \?))) - (make-local-variable 'neglst) - (setq neglst - '((why not \?) - (($ bother) i ask that \?) - (why not \?) - (why not \?) - (how come \?) - (($ bother) i ask that \?))) - (make-local-variable 'beclst) - (setq beclst '( - (is it because (// sent) that you came to me \?) - (($ bother)(// sent) \?) - (when did you first know that (// sent) \?) - (is the fact that (// sent) the real reason \?) - (does the fact that (// sent) explain anything else \?) - (($ areyou)($ sure)(// sent) \? ) )) - (make-local-variable 'shortbeclst) - (setq shortbeclst '( - (($ bother) i ask you that \?) - (that\'s not much of an answer!) - (($ inter) why won\'t you talk about it \?) - (speak up!) - (($ areyou) ($ afraidof) talking about it \?) - (don\'t be ($ afraidof) elaborating \.) - (($ please) go into more detail \.))) - (make-local-variable 'thlst) - (setq thlst '( - (($ maybe)($ things)($ arerelated) this \.) - (is it because of ($ things) that you are going through all this \?) - (how do you reconcile ($ things) \? ) - (($ maybe) this ($ isrelated)($ things) \?) )) - (make-local-variable 'remlst) - (setq remlst '( (earlier you said ($ history) \?) - (you mentioned that ($ history) \?) - (($ whysay)($ history) \? ) )) - (make-local-variable 'toklst) - (setq toklst - '((is this how you relax \?) - (how long have you been smoking grass \?) - (($ areyou) ($ afraidof) of being drawn to using harder stuff \?))) - (make-local-variable 'states) - (setq states - '((do you get (// found) often \?) - (do you enjoy being (// found) \?) - (what makes you (// found) \?) - (how often ($ areyou)(// found) \?) - (when were you last (// found) \?))) - (make-local-variable 'replist) - (setq replist - '((i . (you)) - (my . (your)) - (me . (you)) - (you . (me)) - (your . (my)) - (mine . (yours)) - (yours . (mine)) - (our . (your)) - (ours . (yours)) - (we . (you)) - (dunno . (do not know)) -;; (yes . ()) - (no\, . ()) - (yes\, . ()) - (ya . (i)) - (aint . (am not)) - (wanna . (want to)) - (gimme . (give me)) - (gotta . (have to)) - (gonna . (going to)) - (never . (not ever)) - (doesn\'t . (does not)) - (don\'t . (do not)) - (aren\'t . (are not)) - (isn\'t . (is not)) - (won\'t . (will not)) - (can\'t . (cannot)) - (haven\'t . (have not)) - (i\'m . (you are)) - (ourselves . (yourselves)) - (myself . (yourself)) - (yourself . (myself)) - (you\'re . (i am)) - (you\'ve . (i have)) - (i\'ve . (you have)) - (i\'ll . (you will)) - (you\'ll . (i shall)) - (i\'d . (you would)) - (you\'d . (i would)) - (here . (there)) - (please . ()) - (eh\, . ()) - (eh . ()) - (oh\, . ()) - (oh . ()) - (shouldn\'t . (should not)) - (wouldn\'t . (would not)) - (won\'t . (will not)) - (hasn\'t . (has not)))) - (make-local-variable 'stallmanlst) - (setq stallmanlst '( - (($ describe) your ($ feelings-about) him \.) - (($ areyou) a friend of Stallman \?) - (($ bother) Stallman is ($ random-adjective) \?) - (($ ibelieve) you are ($ afraidof) him \.))) - (make-local-variable 'schoollst) - (setq schoollst '( - (($ describe) your (// found) \.) - (($ bother) your grades could ($ improve) \?) - (($ areyou) ($ afraidof) (// found) \?) - (($ maybe) this ($ isrelated) to your attitude \.) - (($ areyou) absent often \?) - (($ maybe) you should study ($ something) \.))) - (make-local-variable 'improve) - (setq improve '((improve) (be better) (be improved) (be higher))) - (make-local-variable 'elizalst) - (setq elizalst '( - (($ areyou) ($ sure) \?) - (($ ibelieve) you have ($ problems) with (// found) \.) - (($ whysay) (// sent) \?))) - (make-local-variable 'sportslst) - (setq sportslst '( - (tell me ($ something) about (// found) \.) - (($ describe) ($ relation) (// found) \.) - (do you find (// found) ($ random-adjective) \?))) - (make-local-variable 'mathlst) - (setq mathlst '( - (($ describe) ($ something) about math \.) - (($ maybe) your ($ problems) ($ arerelated) (// found) \.) - (i do\'nt know much (// found) \, but ($ continue) - anyway \.))) - (make-local-variable 'zippylst) - (setq zippylst '( - (($ areyou) Zippy \?) - (($ ibelieve) you have some serious ($ problems) \.) - (($ bother) you are a pinhead \?))) - (make-local-variable 'chatlst) - (setq chatlst '( - (($ maybe) we could chat \.) - (($ please) ($ describe) ($ something) about chat mode \.) - (($ bother) our discussion is so ($ random-adjective) \?))) - (make-local-variable 'abuselst) - (setq abuselst '( - (($ please) try to be less abusive \.) - (($ describe) why you call me (// found) \.) - (i\'ve had enough of you!))) - (make-local-variable 'abusewords) - (setq abusewords '(boring bozo clown clumsy cretin dumb dummy - fool foolish gnerd gnurd idiot jerk - lose loser louse lousy luse luser - moron nerd nurd oaf oafish reek - stink stupid tool toolish twit)) - (make-local-variable 'howareyoulst) - (setq howareyoulst '((how are you) (hows it going) (hows it going eh) - (how\'s it going) (how\'s it going eh) (how goes it) - (whats up) (whats new) (what\'s up) (what\'s new) - (howre you) (how\'re you) (how\'s everything) - (how is everything) (how do you do) - (how\'s it hanging) (que pasa) - (how are you doing) (what do you say))) - (make-local-variable 'whereoutp) - (setq whereoutp '( huh remem rthing ) ) - (make-local-variable 'subj) - (setq subj nil) - (make-local-variable 'verb) - (setq verb nil) - (make-local-variable 'obj) - (setq obj nil) - (make-local-variable 'feared) - (setq feared nil) - (make-local-variable 'repetitive-shortness) - (setq repetitive-shortness '(0 . 0)) - (make-local-variable '**mad**) - (setq **mad** nil) - (make-local-variable 'rms-flag) - (setq rms-flag nil) - (make-local-variable 'eliza-flag) - (setq eliza-flag nil) - (make-local-variable 'zippy-flag) - (setq zippy-flag nil) - (make-local-variable 'lover) - (setq lover '(your partner)) - (make-local-variable 'bak) - (setq bak nil) - (make-local-variable 'lincount) - (setq lincount 0) - (make-local-variable '*print-upcase*) - (setq *print-upcase* nil) - (make-local-variable '*print-space*) - (setq *print-space* nil) - (make-local-variable 'howdyflag) - (setq howdyflag nil) - (make-local-variable 'object) - (setq object nil)) - -;; Define equivalence classes of words that get treated alike. - -(defun doctor-meaning (x) (get x 'doctor-meaning)) - -(defmacro doctor-put-meaning (symb val) - "Store the base meaning of a word on the property list." - (list 'put (list 'quote symb) ''doctor-meaning val)) - -(doctor-put-meaning howdy 'howdy) -(doctor-put-meaning hi 'howdy) -(doctor-put-meaning greetings 'howdy) -(doctor-put-meaning hello 'howdy) -(doctor-put-meaning tops20 'mach) -(doctor-put-meaning tops-20 'mach) -(doctor-put-meaning tops 'mach) -(doctor-put-meaning pdp11 'mach) -(doctor-put-meaning computer 'mach) -(doctor-put-meaning unix 'mach) -(doctor-put-meaning machine 'mach) -(doctor-put-meaning computers 'mach) -(doctor-put-meaning machines 'mach) -(doctor-put-meaning pdp11s 'mach) -(doctor-put-meaning foo 'mach) -(doctor-put-meaning foobar 'mach) -(doctor-put-meaning multics 'mach) -(doctor-put-meaning macsyma 'mach) -(doctor-put-meaning teletype 'mach) -(doctor-put-meaning la36 'mach) -(doctor-put-meaning vt52 'mach) -(doctor-put-meaning zork 'mach) -(doctor-put-meaning trek 'mach) -(doctor-put-meaning startrek 'mach) -(doctor-put-meaning advent 'mach) -(doctor-put-meaning pdp 'mach) -(doctor-put-meaning dec 'mach) -(doctor-put-meaning commodore 'mach) -(doctor-put-meaning vic 'mach) -(doctor-put-meaning bbs 'mach) -(doctor-put-meaning modem 'mach) -(doctor-put-meaning baud 'mach) -(doctor-put-meaning macintosh 'mach) -(doctor-put-meaning vax 'mach) -(doctor-put-meaning vms 'mach) -(doctor-put-meaning ibm 'mach) -(doctor-put-meaning pc 'mach) -(doctor-put-meaning bitching 'foul) -(doctor-put-meaning bastard 'foul) -(doctor-put-meaning damn 'foul) -(doctor-put-meaning damned 'foul) -(doctor-put-meaning hell 'foul) -(doctor-put-meaning suck 'foul) -(doctor-put-meaning sucking 'foul) -(doctor-put-meaning sux 'foul) -(doctor-put-meaning ass 'foul) -(doctor-put-meaning whore 'foul) -(doctor-put-meaning bitch 'foul) -(doctor-put-meaning asshole 'foul) -(doctor-put-meaning shrink 'foul) -(doctor-put-meaning pot 'toke) -(doctor-put-meaning grass 'toke) -(doctor-put-meaning weed 'toke) -(doctor-put-meaning marijuana 'toke) -(doctor-put-meaning acapulco 'toke) -(doctor-put-meaning columbian 'toke) -(doctor-put-meaning tokin 'toke) -(doctor-put-meaning joint 'toke) -(doctor-put-meaning toke 'toke) -(doctor-put-meaning toking 'toke) -(doctor-put-meaning tokin\' 'toke) -(doctor-put-meaning toked 'toke) -(doctor-put-meaning roach 'toke) -(doctor-put-meaning pills 'drug) -(doctor-put-meaning dope 'drug) -(doctor-put-meaning acid 'drug) -(doctor-put-meaning lsd 'drug) -(doctor-put-meaning speed 'drug) -(doctor-put-meaning heroin 'drug) -(doctor-put-meaning hash 'drug) -(doctor-put-meaning cocaine 'drug) -(doctor-put-meaning uppers 'drug) -(doctor-put-meaning downers 'drug) -(doctor-put-meaning loves 'loves) -(doctor-put-meaning love 'love) -(doctor-put-meaning loved 'love) -(doctor-put-meaning hates 'hates) -(doctor-put-meaning dislikes 'hates) -(doctor-put-meaning hate 'hate) -(doctor-put-meaning hated 'hate) -(doctor-put-meaning dislike 'hate) -(doctor-put-meaning stoned 'state) -(doctor-put-meaning drunk 'state) -(doctor-put-meaning drunken 'state) -(doctor-put-meaning high 'state) -(doctor-put-meaning horny 'state) -(doctor-put-meaning blasted 'state) -(doctor-put-meaning happy 'state) -(doctor-put-meaning paranoid 'state) -(doctor-put-meaning wish 'desire) -(doctor-put-meaning wishes 'desire) -(doctor-put-meaning want 'desire) -(doctor-put-meaning desire 'desire) -(doctor-put-meaning like 'desire) -(doctor-put-meaning hope 'desire) -(doctor-put-meaning hopes 'desire) -(doctor-put-meaning desires 'desire) -(doctor-put-meaning wants 'desire) -(doctor-put-meaning desires 'desire) -(doctor-put-meaning likes 'desire) -(doctor-put-meaning needs 'desire) -(doctor-put-meaning need 'desire) -(doctor-put-meaning frustrated 'mood) -(doctor-put-meaning depressed 'mood) -(doctor-put-meaning annoyed 'mood) -(doctor-put-meaning upset 'mood) -(doctor-put-meaning unhappy 'mood) -(doctor-put-meaning excited 'mood) -(doctor-put-meaning worried 'mood) -(doctor-put-meaning lonely 'mood) -(doctor-put-meaning angry 'mood) -(doctor-put-meaning mad 'mood) -(doctor-put-meaning jealous 'mood) -(doctor-put-meaning afraid 'fear) -(doctor-put-meaning terrified 'fear) -(doctor-put-meaning fear 'fear) -(doctor-put-meaning scared 'fear) -(doctor-put-meaning frightened 'fear) -(doctor-put-meaning virginity 'sexnoun) -(doctor-put-meaning virgins 'sexnoun) -(doctor-put-meaning virgin 'sexnoun) -(doctor-put-meaning cock 'sexnoun) -(doctor-put-meaning cocks 'sexnoun) -(doctor-put-meaning dick 'sexnoun) -(doctor-put-meaning dicks 'sexnoun) -(doctor-put-meaning prostitute 'sexnoun) -(doctor-put-meaning condom 'sexnoun) -(doctor-put-meaning sex 'sexnoun) -(doctor-put-meaning rapes 'sexnoun) -(doctor-put-meaning wife 'family) -(doctor-put-meaning family 'family) -(doctor-put-meaning brothers 'family) -(doctor-put-meaning sisters 'family) -(doctor-put-meaning parent 'family) -(doctor-put-meaning parents 'family) -(doctor-put-meaning brother 'family) -(doctor-put-meaning sister 'family) -(doctor-put-meaning father 'family) -(doctor-put-meaning mother 'family) -(doctor-put-meaning husband 'family) -(doctor-put-meaning siblings 'family) -(doctor-put-meaning grandmother 'family) -(doctor-put-meaning grandfather 'family) -(doctor-put-meaning maternal 'family) -(doctor-put-meaning paternal 'family) -(doctor-put-meaning stab 'death) -(doctor-put-meaning murder 'death) -(doctor-put-meaning murders 'death) -(doctor-put-meaning suicide 'death) -(doctor-put-meaning suicides 'death) -(doctor-put-meaning kill 'death) -(doctor-put-meaning kills 'death) -(doctor-put-meaning die 'death) -(doctor-put-meaning dies 'death) -(doctor-put-meaning died 'death) -(doctor-put-meaning dead 'death) -(doctor-put-meaning death 'death) -(doctor-put-meaning deaths 'death) -(doctor-put-meaning pain 'symptoms) -(doctor-put-meaning ache 'symptoms) -(doctor-put-meaning fever 'symptoms) -(doctor-put-meaning sore 'symptoms) -(doctor-put-meaning aching 'symptoms) -(doctor-put-meaning stomachache 'symptoms) -(doctor-put-meaning headache 'symptoms) -(doctor-put-meaning hurts 'symptoms) -(doctor-put-meaning disease 'symptoms) -(doctor-put-meaning virus 'symptoms) -(doctor-put-meaning vomit 'symptoms) -(doctor-put-meaning vomiting 'symptoms) -(doctor-put-meaning barf 'symptoms) -(doctor-put-meaning toothache 'symptoms) -(doctor-put-meaning hurt 'symptoms) -(doctor-put-meaning rum 'alcohol) -(doctor-put-meaning gin 'alcohol) -(doctor-put-meaning vodka 'alcohol) -(doctor-put-meaning alcohol 'alcohol) -(doctor-put-meaning bourbon 'alcohol) -(doctor-put-meaning beer 'alcohol) -(doctor-put-meaning wine 'alcohol) -(doctor-put-meaning whiskey 'alcohol) -(doctor-put-meaning scotch 'alcohol) -(doctor-put-meaning screw 'sexverb) -(doctor-put-meaning screwing 'sexverb) -(doctor-put-meaning rape 'sexverb) -(doctor-put-meaning raped 'sexverb) -(doctor-put-meaning kiss 'sexverb) -(doctor-put-meaning kissing 'sexverb) -(doctor-put-meaning kisses 'sexverb) -(doctor-put-meaning screws 'sexverb) -(doctor-put-meaning because 'conj) -(doctor-put-meaning but 'conj) -(doctor-put-meaning however 'conj) -(doctor-put-meaning besides 'conj) -(doctor-put-meaning anyway 'conj) -(doctor-put-meaning that 'conj) -(doctor-put-meaning except 'conj) -(doctor-put-meaning why 'conj) -(doctor-put-meaning how 'conj) -(doctor-put-meaning until 'when) -(doctor-put-meaning when 'when) -(doctor-put-meaning whenever 'when) -(doctor-put-meaning while 'when) -(doctor-put-meaning since 'when) -(doctor-put-meaning rms 'rms) -(doctor-put-meaning stallman 'rms) -(doctor-put-meaning school 'school) -(doctor-put-meaning schools 'school) -(doctor-put-meaning skool 'school) -(doctor-put-meaning grade 'school) -(doctor-put-meaning grades 'school) -(doctor-put-meaning teacher 'school) -(doctor-put-meaning teachers 'school) -(doctor-put-meaning classes 'school) -(doctor-put-meaning professor 'school) -(doctor-put-meaning prof 'school) -(doctor-put-meaning profs 'school) -(doctor-put-meaning professors 'school) -(doctor-put-meaning mit 'school) -(doctor-put-meaning emacs 'eliza) -(doctor-put-meaning eliza 'eliza) -(doctor-put-meaning liza 'eliza) -(doctor-put-meaning elisa 'eliza) -(doctor-put-meaning weizenbaum 'eliza) -(doctor-put-meaning doktor 'eliza) -(doctor-put-meaning athletics 'sports) -(doctor-put-meaning baseball 'sports) -(doctor-put-meaning basketball 'sports) -(doctor-put-meaning football 'sports) -(doctor-put-meaning frisbee 'sports) -(doctor-put-meaning gym 'sports) -(doctor-put-meaning gymnastics 'sports) -(doctor-put-meaning hockey 'sports) -(doctor-put-meaning lacrosse 'sports) -(doctor-put-meaning soccer 'sports) -(doctor-put-meaning softball 'sports) -(doctor-put-meaning sports 'sports) -(doctor-put-meaning swimming 'sports) -(doctor-put-meaning swim 'sports) -(doctor-put-meaning tennis 'sports) -(doctor-put-meaning volleyball 'sports) -(doctor-put-meaning math 'math) -(doctor-put-meaning mathematics 'math) -(doctor-put-meaning mathematical 'math) -(doctor-put-meaning theorem 'math) -(doctor-put-meaning axiom 'math) -(doctor-put-meaning lemma 'math) -(doctor-put-meaning algebra 'math) -(doctor-put-meaning algebraic 'math) -(doctor-put-meaning trig 'math) -(doctor-put-meaning trigonometry 'math) -(doctor-put-meaning trigonometric 'math) -(doctor-put-meaning geometry 'math) -(doctor-put-meaning geometric 'math) -(doctor-put-meaning calculus 'math) -(doctor-put-meaning arithmetic 'math) -(doctor-put-meaning zippy 'zippy) -(doctor-put-meaning zippy 'zippy) -(doctor-put-meaning pinhead 'zippy) -(doctor-put-meaning chat 'chat) - -;;;###autoload -(defun doctor () - "Switch to *doctor* buffer and start giving psychotherapy." - (interactive) - (switch-to-buffer "*doctor*") - (doctor-mode)) - -(defun doctor-ret-or-read (arg) - "Insert a newline if preceding character is not a newline. -Otherwise call the Doctor to parse preceding sentence." - (interactive "*p") - (if (= (preceding-char) ?\n) - (doctor-read-print) - (newline arg))) - -(defun doctor-read-print nil - "top level loop" - (interactive) - (let ((sent (doctor-readin))) - (insert "\n") - (setq lincount (1+ lincount)) - (doctor-doc sent) - (insert "\n") - (setq bak sent))) - -(defun doctor-readin nil - "Read a sentence. Return it as a list of words." - (let (sentence) - (backward-sentence 1) - (while (not (eobp)) - (setq sentence (append sentence (list (doctor-read-token))))) - sentence)) - -(defun doctor-read-token () - "read one word from buffer" - (prog1 (intern (downcase (buffer-substring (point) - (progn - (forward-word 1) - (point))))) - (re-search-forward "\\Sw*"))) - -;; Main processing function for sentences that have been read. - -(defun doctor-doc (sent) - (cond - ((equal sent '(foo)) - (doctor-type '(bar! ($ please)($ continue) \.))) - ((member sent howareyoulst) - (doctor-type '(i\'m ok \. ($ describe) yourself \.))) - ((or (member sent '((good bye) (see you later) (i quit) (so long) - (go away) (get lost))) - (memq (car sent) - '(bye halt break quit done exit goodbye - bye\, stop pause goodbye\, stop pause))) - (doctor-type ($ bye))) - ((and (eq (car sent) 'you) - (memq (doctor-cadr sent) abusewords)) - (setq found (doctor-cadr sent)) - (doctor-type ($ abuselst))) - ((eq (car sent) 'whatmeans) - (doctor-def (doctor-cadr sent))) - ((equal sent '(parse)) - (doctor-type (list 'subj '= subj ", " - 'verb '= verb "\n" - 'object 'phrase '= obj "," - 'noun 'form '= object "\n" - 'current 'keyword 'is found - ", " - 'most 'recent 'possessive - 'is owner "\n" - 'sentence 'used 'was - "..." - '(// bak)))) - ;; ((eq (car sent) 'forget) - ;; (set (doctor-cadr sent) nil) - ;; (doctor-type '(($ isee)($ please) - ;; ($ continue)\.))) - (t - (if (doctor-defq sent) (doctor-define sent found)) - (if (> (length sent) 12)(doctor-shorten sent)) - (setq sent (doctor-correct-spelling (doctor-replace sent replist))) - (cond ((and (not (memq 'me sent))(not (memq 'i sent)) - (memq 'am sent)) - (setq sent (doctor-replace sent '((am . (are))))))) - (cond ((equal (car sent) 'yow) (doctor-zippy)) - ((< (length sent) 2) - (cond ((eq (doctor-meaning (car sent)) 'howdy) - (doctor-howdy)) - (t (doctor-short)))) - (t - (if (memq 'am sent) - (setq sent (doctor-replace sent '((me . (i)))))) - (setq sent (doctor-fixup sent)) - (if (and (eq (car sent) 'do) (eq (doctor-cadr sent) 'not)) - (cond ((zerop (random 3)) - (doctor-type '(are you ($ afraidof) that \?))) - ((zerop (random 2)) - (doctor-type '(don\'t tell me what to do \. i am the - psychiatrist here!)) - (doctor-rthing)) - (t - (doctor-type '(($ whysay) that i shouldn\'t - (doctor-cddr sent) - \?)))) - (doctor-go (doctor-wherego sent)))))))) - -;; Things done to process sentences once read. - -(defun doctor-correct-spelling (sent) - "Correct the spelling and expand each word in sentence." - (if sent - (apply 'append (mapcar '(lambda (word) - (if (memq word typos) - (get (get word 'doctor-correction) 'doctor-expansion) - (list word))) - sent)))) - -(defun doctor-shorten (sent) - "Make a sentence manageably short using a few hacks." - (let (foo - retval - (temp '(because but however besides anyway until - while that except why how))) - (while temp - (setq foo (memq (car temp) sent)) - (if (and foo - (> (length foo) 3)) - (setq sent foo - sent (doctor-fixup sent) - temp nil - retval t) - (setq temp (cdr temp)))) - retval)) - -(defun doctor-define (sent found) - (doctor-svo sent found 1 nil) - (and - (doctor-nounp subj) - (not (doctor-pronounp subj)) - subj - (doctor-meaning object) - (put subj 'doctor-meaning (doctor-meaning object)) - t)) - -(defun doctor-defq (sent) - "Set global var FOUND to first keyword found in sentence SENT." - (setq found nil) - (let ((temp '(means applies mean refers refer related - similar defined associated linked like same))) - (while temp - (if (memq (car temp) sent) - (setq found (car temp) - temp nil) - (setq temp (cdr temp))))) - found) - -(defun doctor-def (x) - (progn - (doctor-type (list 'the 'word x 'means (doctor-meaning x) 'to 'me)) - nil)) - -(defun doctor-forget () - "Delete the last element of the history list." - (setq history (reverse (cdr (reverse history))))) - -(defun doctor-query (x) - "Prompt for a line of input from the minibuffer until a noun or verb is seen. -Put dialogue in buffer." - (let (a - (prompt (concat (doctor-make-string x) - " what \? ")) - retval) - (while (not retval) - (while (not a) - (insert ?\n - prompt - (read-string prompt) - ?\n) - (setq a (doctor-readin))) - (while (and a (not retval)) - (cond ((doctor-nounp (car a)) - (setq retval (car a))) - ((doctor-verbp (car a)) - (setq retval (doctor-build - (doctor-build x " ") - (car a)))) - ((setq a (cdr a)))))) - retval)) - -(defun doctor-subjsearch (sent key type) - "Search for the subject of a sentence SENT, looking for the noun closest -to and preceding KEY by at least TYPE words. Set global variable subj to -the subject noun, and return the portion of the sentence following it." - (let ((i (- (length sent) (length (memq key sent)) type))) - (while (and (> i -1) (not (doctor-nounp (nth i sent)))) - (setq i (1- i))) - (cond ((> i -1) - (setq subj (nth i sent)) - (nthcdr (1+ i) sent)) - (t - (setq subj 'you) - nil)))) - -(defun doctor-nounp (x) - "Returns t if the symbol argument is a noun." - (or (doctor-pronounp x) - (not (or (doctor-verbp x) - (equal x 'not) - (doctor-prepp x) - (doctor-modifierp x) )) )) - -(defun doctor-pronounp (x) - "Returns t if the symbol argument is a pronoun." - (memq x '( - i me mine myself - we us ours ourselves ourself - you yours yourself yourselves - he him himself she hers herself - it that those this these things thing - they them themselves theirs - anybody everybody somebody - anyone everyone someone - anything something everything))) - -(mapcar (function (lambda (x) (put x 'doctor-sentence-type 'verb))) - '(abort aborted aborts ask asked asks am - applied applies apply are associate - associated ate - be became become becomes becoming - been being believe believed believes - bit bite bites bore bored bores boring bought buy buys buying - call called calling calls came can caught catch come - contract contracted contracts control controlled controls - could croak croaks croaked cut cuts - dare dared define defines dial dialed dials did die died dies - dislike disliked - dislikes do does drank drink drinks drinking - drive drives driving drove dying - eat eating eats expand expanded expands - expect expected expects expel expels expelled - explain explained explains - fart farts feel feels felt fight fights find finds finding - forget forgets forgot fought found - gave get gets getting give gives go goes going gone got gotten - had harm harms has hate hated hates have having - hear heard hears hearing help helped helping helps - hit hits hope hoped hopes hurt hurts - implies imply is - join joined joins jump jumped jumps - keep keeping keeps kept - kill killed killing kills kiss kissed kisses kissing - knew know knows - laid lay lays let lets lie lied lies like liked likes - liking listen listens - login look looked looking looks - lose losing lost - love loved loves loving - luse lusing lust lusts - made make makes making may mean means meant might - move moved moves moving must - need needed needs - order ordered orders ought - paid pay pays pick picked picking picks - placed placing prefer prefers put puts - ran rape raped rapes - read reading reads recall receive received receives - refer refered referred refers - relate related relates remember remembered remembers - romp romped romps run running runs - said sang sat saw say says - screw screwed screwing screws scrod see sees seem seemed - seems seen sell selling sells - send sendind sends sent shall shoot shot should - sing sings sit sits sitting sold studied study - take takes taking talk talked talking talks tell tells telling - think thinks - thought told took tooled touch touched touches touching - transfer transferred transfers transmit transmits transmitted - type types types typing - walk walked walking walks want wanted wants was watch - watched watching went were will wish would work worked works - write writes writing wrote use used uses using)) - -(defun doctor-verbp (x) (if (symbolp x) - (eq (get x 'doctor-sentence-type) 'verb))) - -(defun doctor-plural (x) - "Form the plural of the word argument." - (let ((foo (doctor-make-string x))) - (cond ((string-equal (substring foo -1) "s") - (cond ((string-equal (substring foo -2 -1) "s") - (intern (concat foo "es"))) - (t x))) - ((string-equal (substring foo -1) "y") - (intern (concat (substring foo 0 -1) - "ies"))) - (t (intern (concat foo "s")))))) - -(defun doctor-setprep (sent key) - (let ((val) - (foo (memq key sent))) - (cond ((doctor-prepp (doctor-cadr foo)) - (setq val (doctor-getnoun (doctor-cddr foo))) - (cond (val val) - (t 'something))) - ((doctor-articlep (doctor-cadr foo)) - (setq val (doctor-getnoun (doctor-cddr foo))) - (cond (val (doctor-build (doctor-build (doctor-cadr foo) " ") val)) - (t 'something))) - (t 'something)))) - -(defun doctor-getnoun (x) - (cond ((null x)(setq object 'something)) - ((atom x)(setq object x)) - ((eq (length x) 1) - (setq object (cond - ((doctor-nounp (setq object (car x))) object) - (t (doctor-query object))))) - ((eq (car x) 'to) - (doctor-build 'to\ (doctor-getnoun (cdr x)))) - ((doctor-prepp (car x)) - (doctor-getnoun (cdr x))) - ((not (doctor-nounp (car x))) - (doctor-build (doctor-build (cdr (assq (car x) - (append - '((a . this) - (some . this) - (one . that)) - (list - (cons - (car x) (car x)))))) - " ") - (doctor-getnoun (cdr x)))) - (t (setq object (car x))) )) - -(defun doctor-modifierp (x) - (or (doctor-adjectivep x) - (doctor-adverbp x) - (doctor-othermodifierp x))) - -(defun doctor-adjectivep (x) - (or (numberp x) - (doctor-nmbrp x) - (doctor-articlep x) - (doctor-colorp x) - (doctor-sizep x) - (doctor-possessivepronounp x))) - -(defun doctor-adverbp (xx) - (let ((xxstr (doctor-make-string xx))) - (and (>= (length xxstr) 2) - (string-equal (substring (doctor-make-string xx) -2) "ly")))) - -(defun doctor-articlep (x) - (memq x '(the a an))) - -(defun doctor-nmbrp (x) - (memq x '(one two three four five six seven eight nine ten - eleven twelve thirteen fourteen fifteen - sixteen seventeen eighteen nineteen - twenty thirty forty fifty sixty seventy eighty ninety - hundred thousand million billion - half quarter - first second third fourth fifth - sixth seventh eighth ninth tenth))) - -(defun doctor-colorp (x) - (memq x '(beige black blue brown crimson - gray grey green - orange pink purple red tan tawny - violet white yellow))) - -(defun doctor-sizep (x) - (memq x '(big large tall fat wide thick - small petite short thin skinny))) - -(defun doctor-possessivepronounp (x) - (memq x '(my your his her our their))) - -(defun doctor-othermodifierp (x) - (memq x '(all also always amusing any anyway associated awesome - bad beautiful best better but certain clear - ever every fantastic fun funny - good great grody gross however if ignorant - less linked losing lusing many more much - never nice obnoxious often poor pretty real related rich - similar some stupid super superb - terrible terrific too total tubular ugly very))) - -(defun doctor-prepp (x) - (memq x '(about above after around as at - before beneath behind beside between by - for from in inside into - like near next of on onto over - same through thru to toward towards - under underneath with without))) - -(defun doctor-remember (thing) - (cond ((null history) - (setq history (list thing))) - (t (setq history (append history (list thing)))))) - -(defun doctor-type (x) - (setq x (doctor-fix-2 x)) - (doctor-txtype (doctor-assm x))) - -(defun doctor-fixup (sent) - (setq sent (append - (cdr - (assq (car sent) - (append - '((me i) - (him he) - (her she) - (them they) - (okay) - (well) - (sigh) - (hmm) - (hmmm) - (hmmmm) - (hmmmmm) - (gee) - (sure) - (great) - (oh) - (fine) - (ok) - (no)) - (list (list (car sent) - (car sent)))))) - (cdr sent))) - (doctor-fix-2 sent)) - -(defun doctor-fix-2 (sent) - (let ((foo sent)) - (while foo - (if (and (eq (car foo) 'me) - (doctor-verbp (doctor-cadr foo))) - (rplaca foo 'i) - (cond ((eq (car foo) 'you) - (cond ((memq (doctor-cadr foo) '(am be been is)) - (rplaca (cdr foo) 'are)) - ((memq (doctor-cadr foo) '(has)) - (rplaca (cdr foo) 'have)) - ((memq (doctor-cadr foo) '(was)) - (rplaca (cdr foo) 'were)))) - ((equal (car foo) 'i) - (cond ((memq (doctor-cadr foo) '(are is be been)) - (rplaca (cdr foo) 'am)) - ((memq (doctor-cadr foo) '(were)) - (rplaca (cdr foo) 'was)) - ((memq (doctor-cadr foo) '(has)) - (rplaca (cdr foo) 'have)))) - ((and (doctor-verbp (car foo)) - (eq (doctor-cadr foo) 'i) - (not (doctor-verbp (car (doctor-cddr foo))))) - (rplaca (cdr foo) 'me)) - ((and (eq (car foo) 'a) - (doctor-vowelp (string-to-char - (doctor-make-string (doctor-cadr foo))))) - (rplaca foo 'an)) - ((and (eq (car foo) 'an) - (not (doctor-vowelp (string-to-char - (doctor-make-string (doctor-cadr foo)))))) - (rplaca foo 'a))) - (setq foo (cdr foo)))) - sent)) - -(defun doctor-vowelp (x) - (memq x '(?a ?e ?i ?o ?u))) - -(defun doctor-replace (sent rlist) - "Replace any element of SENT that is the car of a replacement -element pair in RLIST." - (apply 'append - (mapcar - (function - (lambda (x) - (cdr (or (assq x rlist) ; either find a replacement - (list x x))))) ; or fake an identity mapping - sent))) - -(defun doctor-wherego (sent) - (cond ((null sent)($ whereoutp)) - ((null (doctor-meaning (car sent))) - (doctor-wherego (cond ((zerop (random 2)) - (reverse (cdr sent))) - (t (cdr sent))))) - (t - (setq found (car sent)) - (doctor-meaning (car sent))))) - -(defun doctor-svo (sent key type mem) - "Find subject, verb and object in sentence SENT with focus on word KEY. -TYPE is number of words preceding KEY to start looking for subject. -MEM is t if results are to be put on Doctor's memory stack. -Return in the global variables SUBJ, VERB and OBJECT." - (let ((foo (doctor-subjsearch sent key type))) - (or foo - (setq foo sent - mem nil)) - (while (and (null (doctor-verbp (car foo))) (cdr foo)) - (setq foo (cdr foo))) - (setq verb (car foo)) - (setq obj (doctor-getnoun (cdr foo))) - (cond ((eq object 'i)(setq object 'me)) - ((eq subj 'me)(setq subj 'i))) - (cond (mem (doctor-remember (list subj verb obj)))))) - -(defun doctor-possess (sent key) - "Set possessive in SENT for keyword KEY. -Hack on previous word, setting global variable OWNER to correct result." - (let* ((i (- (length sent) (length (memq key sent)) 1)) - (prev (if (< i 0) 'your - (nth i sent)))) - (setq owner (if (or (doctor-possessivepronounp prev) - (string-equal "s" - (substring (doctor-make-string prev) - -1))) - prev - 'your)))) - -;; Output of replies. - -(defun doctor-txtype (ans) - "Output to buffer a list of symbols or strings as a sentence." - (setq *print-upcase* t *print-space* nil) - (mapcar 'doctor-type-symbol ans) - (insert "\n")) - -(defun doctor-type-symbol (word) - "Output a symbol to the buffer with some fancy case and spacing hacks." - (setq word (doctor-make-string word)) - (if (string-equal word "i") (setq word "I")) - (if *print-upcase* - (progn - (setq word (capitalize word)) - (if *print-space* - (insert " ")))) - (cond ((or (string-match "^[.,;:?! ]" word) - (not *print-space*)) - (insert word)) - (t (insert ?\ word))) - (and auto-fill-function - (> (current-column) fill-column) - (apply auto-fill-function nil)) - (setq *print-upcase* (string-match "[.?!]$" word) - *print-space* t)) - -(defun doctor-build (str1 str2) - "Make a symbol out of the concatenation of the two non-list arguments." - (cond ((null str1) str2) - ((null str2) str1) - ((and (atom str1) - (atom str2)) - (intern (concat (doctor-make-string str1) - (doctor-make-string str2)))) - (t nil))) - -(defun doctor-make-string (obj) - (cond ((stringp obj) obj) - ((symbolp obj) (symbol-name obj)) - ((numberp obj) (int-to-string obj)) - (t ""))) - -(defun doctor-concat (x y) - "Like append, but force atomic arguments to be lists." - (append - (if (and x (atom x)) (list x) x) - (if (and y (atom y)) (list y) y))) - -(defun doctor-assm (proto) - (cond ((null proto) nil) - ((atom proto) (list proto)) - ((atom (car proto)) - (cons (car proto) (doctor-assm (cdr proto)))) - (t (doctor-concat (doctor-assm (eval (car proto))) (doctor-assm (cdr proto)))))) - -;; Functions that handle specific words or meanings when found. - -(defun doctor-go (destination) - "Call a `doctor-*' function." - (funcall (intern (concat "doctor-" (doctor-make-string destination))))) - -(defun doctor-desire1 () - (doctor-go ($ whereoutp))) - -(defun doctor-huh () - (cond ((< (length sent) 9) (doctor-type ($ huhlst))) - (t (doctor-type ($ longhuhlst))))) - -(defun doctor-rthing () (doctor-type ($ thlst))) - -(defun doctor-remem () (cond ((null history)(doctor-huh)) - ((doctor-type ($ remlst))))) - -(defun doctor-howdy () - (cond ((not howdyflag) - (doctor-type '(($ hello) what brings you to see me \?)) - (setq howdyflag t)) - (t - (doctor-type '(($ ibelieve) we\'ve introduced ourselves already \.)) - (doctor-type '(($ please) ($ describe) ($ things) \.))))) - -(defun doctor-when () - (cond ((< (length (memq found sent)) 3)(doctor-short)) - (t - (setq sent (cdr (memq found sent))) - (setq sent (doctor-fixup sent)) - (doctor-type '(($ whatwhen)(// sent) \?))))) - -(defun doctor-conj () - (cond ((< (length (memq found sent)) 4)(doctor-short)) - (t - (setq sent (cdr (memq found sent))) - (setq sent (doctor-fixup sent)) - (cond ((eq (car sent) 'of) - (doctor-type '(are you ($ sure) that is the real reason \?)) - (setq things (cons (cdr sent) things))) - (t - (doctor-remember sent) - (doctor-type ($ beclst))))))) - -(defun doctor-short () - (cond ((= (car repetitive-shortness) (1- lincount)) - (rplacd repetitive-shortness - (1+ (cdr repetitive-shortness)))) - (t - (rplacd repetitive-shortness 1))) - (rplaca repetitive-shortness lincount) - (cond ((> (cdr repetitive-shortness) 6) - (cond ((not **mad**) - (doctor-type '(($ areyou) - just trying to see what kind of things - i have in my vocabulary \? please try to - carry on a reasonable conversation!)) - (setq **mad** t)) - (t - (doctor-type '(i give up \. you need a lesson in creative - writing \.\.\.)) - ))) - (t - (cond ((equal sent (doctor-assm '(yes))) - (doctor-type '(($ isee) ($ inter) ($ whysay) this is so \?))) - ((equal sent (doctor-assm '(because))) - (doctor-type ($ shortbeclst))) - ((equal sent (doctor-assm '(no))) - (doctor-type ($ neglst))) - (t (doctor-type ($ shortlst))))))) - -(defun doctor-alcohol () (doctor-type ($ drnk))) - -(defun doctor-desire () - (let ((foo (memq found sent))) - (cond ((< (length foo) 2) - (doctor-go (doctor-build (doctor-meaning found) 1))) - ((memq (doctor-cadr foo) '(a an)) - (rplacd foo (append '(to have) (cdr foo))) - (doctor-svo sent found 1 nil) - (doctor-remember (list subj 'would 'like obj)) - (doctor-type ($ whywant))) - ((not (eq (doctor-cadr foo) 'to)) - (doctor-go (doctor-build (doctor-meaning found) 1))) - (t - (doctor-svo sent found 1 nil) - (doctor-remember (list subj 'would 'like obj)) - (doctor-type ($ whywant)))))) - -(defun doctor-drug () - (doctor-type ($ drugs)) - (doctor-remember (list 'you 'used found))) - -(defun doctor-toke () - (doctor-type ($ toklst))) - -(defun doctor-state () - (doctor-type ($ states))(doctor-remember (list 'you 'were found))) - -(defun doctor-mood () - (doctor-type ($ moods))(doctor-remember (list 'you 'felt found))) - -(defun doctor-fear () - (setq feared (doctor-setprep sent found)) - (doctor-type ($ fears)) - (doctor-remember (list 'you 'were 'afraid 'of feared))) - -(defun doctor-hate () - (doctor-svo sent found 1 t) - (cond ((memq 'not sent) (doctor-forget) (doctor-huh)) - ((equal subj 'you) - (doctor-type '(why do you (// verb)(// obj) \?))) - (t (doctor-type '(($ whysay)(list subj verb obj)))))) - -(defun doctor-symptoms () - (doctor-type '(($ maybe) you should consult a doctor of medicine\, - i am a psychiatrist \.))) - -(defun doctor-hates () - (doctor-svo sent found 1 t) - (doctor-hates1)) - -(defun doctor-hates1 () - (doctor-type '(($ whysay)(list subj verb obj)))) - -(defun doctor-loves () - (doctor-svo sent found 1 t) - (doctor-qloves)) - -(defun doctor-qloves () - (doctor-type '(($ bother)(list subj verb obj) \?))) - -(defun doctor-love () - (doctor-svo sent found 1 t) - (cond ((memq 'not sent) (doctor-forget) (doctor-huh)) - ((memq 'to sent) (doctor-hates1)) - (t - (cond ((equal object 'something) - (setq object '(this person you love)))) - (cond ((equal subj 'you) - (setq lover obj) - (cond ((equal lover '(this person you love)) - (setq lover '(your partner)) - (doctor-forget) - (doctor-type '(with whom are you in love \?))) - ((doctor-type '(($ please) - ($ describe) - ($ relation) - (// lover) - \.))))) - ((equal subj 'i) - (doctor-txtype '(we were discussing you!))) - (t (doctor-forget) - (setq obj 'someone) - (setq verb (doctor-build verb 's)) - (doctor-qloves)))))) - -(defun doctor-mach () - (setq found (doctor-plural found)) - (doctor-type ($ machlst))) - -(defun doctor-sexnoun () (doctor-sexverb)) - -(defun doctor-sexverb () - (if (or (memq 'me sent)(memq 'myself sent)(memq 'i sent)) - (doctor-foul) - (doctor-type ($ sexlst)))) - -(defun doctor-death () (doctor-type ($ deathlst))) - -(defun doctor-foul () - (doctor-type ($ foullst))) - -(defun doctor-family () - (doctor-possess sent found) - (doctor-type ($ famlst))) - -;; I did not add this -- rms. -;; But he might have removed it. I put it back. --roland -(defun doctor-rms () - (cond (rms-flag (doctor-type ($ stallmanlst))) - (t (setq rms-flag t) (doctor-type '(do you know Stallman \?))))) - -(defun doctor-school nil (doctor-type ($ schoollst))) - -(defun doctor-eliza () - (cond (eliza-flag (doctor-type ($ elizalst))) - (t (setq eliza-flag t) - (doctor-type '((// found) \? hah ! - ($ please) ($ continue) \.))))) - -(defun doctor-sports () (doctor-type ($ sportslst))) - -(defun doctor-math () (doctor-type ($ mathlst))) - -(defun doctor-zippy () - (cond (zippy-flag (doctor-type ($ zippylst))) - (t (setq zippy-flag t) - (doctor-type '(yow! are we interactive yet \?))))) - - -(defun doctor-chat () (doctor-type ($ chatlst))) - -(defun doctor-strangelove () - (interactive) - (insert "Mein fuehrer!!\n") - (doctor-read-print)) - -;;; doctor.el ends here diff --git a/lisp/play/dunnet.el b/lisp/play/dunnet.el deleted file mode 100644 index 2e6ee21b1c1..00000000000 --- a/lisp/play/dunnet.el +++ /dev/null @@ -1,3343 +0,0 @@ -;;; dunnet.el --- Text adventure for Emacs - -;; Copyright (C) 1992, 1993 Free Software Foundation, Inc. - -;; Author: Ron Schnell <ronnie@media.mit.edu> -;; Created: 25 Jul 1992 -;; Version: 2.0 -;; Keywords: games - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; This game can be run in batch mode. To do this, use: -;; emacs -batch -l dunnet - -;;; !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -;;; The log file should be set for your system, and it must -;;; be writable by all. - - -(defvar dun-log-file "/usr/local/dunnet.score" - "Name of file to store score information for dunnet.") - -(if nil - (eval-and-compile (setq byte-compile-warnings nil))) - -(eval-when-compile - (require 'cl)) - -;;;; Mode definitions for interactive mode - -(defun dun-mode () - "Major mode for running dunnet." - (interactive) - (text-mode) - (make-local-variable 'scroll-step) - (setq scroll-step 2) - (use-local-map dungeon-mode-map) - (setq major-mode 'dungeon-mode) - (setq mode-name "Dungeon")) - -(defun dun-parse (arg) - "Function called when return is pressed in interactive mode to parse line." - (interactive "*p") - (beginning-of-line) - (setq beg (+ (point) 1)) - (end-of-line) - (if (and (not (= beg (point))) (not (< (point) beg)) - (string= ">" (buffer-substring (- beg 1) beg))) - (progn - (setq line (downcase (buffer-substring beg (point)))) - (princ line) - (if (eq (dun-vparse dun-ignore dun-verblist line) -1) - (dun-mprinc "I don't understand that.\n"))) - (goto-char (point-max)) - (dun-mprinc "\n")) - (dun-messages)) - -(defun dun-messages () - (if dun-dead - (text-mode) - (if (eq dungeon-mode 'dungeon) - (progn - (if (not (= room dun-current-room)) - (progn - (dun-describe-room dun-current-room) - (setq room dun-current-room))) - (dun-fix-screen) - (dun-mprinc ">"))))) - - -;;;###autoload -(defun dunnet () - "Switch to *dungeon* buffer and start game." - (interactive) - (switch-to-buffer "*dungeon*") - (insert "This version of Dunnet has been censored for your protection -in accord with the Communications Decency Act.\n\n") - (dun-mode) - (setq dun-dead nil) - (setq room 0) - (dun-messages)) - -;;;; -;;;; This section contains all of the verbs and commands. -;;;; - -;;; Give long description of room if haven't been there yet. Otherwise -;;; short. Also give long if we were called with negative room number. - -(defun dun-describe-room (room) - (if (and (not (member (abs room) dun-light-rooms)) - (not (member obj-lamp dun-inventory))) - (dun-mprincl "It is pitch dark. You are likely to be eaten by a grue.") - (dun-mprincl (cadr (nth (abs room) dun-rooms))) - (if (and (and (or (member room dun-visited) - (string= dun-mode "dun-superb")) (> room 0)) - (not (string= dun-mode "long"))) - nil - (dun-mprinc (car (nth (abs room) dun-rooms))) - (dun-mprinc "\n")) - (if (not (string= dun-mode "long")) - (if (not (member (abs room) dun-visited)) - (setq dun-visited (append (list (abs room)) dun-visited)))) - (dolist (xobjs (nth dun-current-room dun-room-objects)) - (if (= xobjs obj-special) - (dun-special-object) - (if (>= xobjs 0) - (dun-mprincl (car (nth xobjs dun-objects))) - (if (not (and (= xobjs obj-bus) dun-inbus)) - (progn - (dun-mprincl (car (nth (abs xobjs) dun-perm-objects))))))) - (if (and (= xobjs obj-jar) dun-jar) - (progn - (dun-mprincl "The jar contains:") - (dolist (x dun-jar) - (dun-mprinc " ") - (dun-mprincl (car (nth x dun-objects))))))) - (if (and (member obj-bus (nth dun-current-room dun-room-objects)) dun-inbus) - (dun-mprincl "You are on the bus.")))) - -;;; There is a special object in the room. This object's description, -;;; or lack thereof, depends on certain conditions. - -(defun dun-special-object () - (if (= dun-current-room computer-room) - (if dun-computer - (dun-mprincl -"The panel lights are flashing in a seemingly organized pattern.") - (dun-mprincl "The panel lights are steady and motionless."))) - - (if (and (= dun-current-room red-room) - (not (member obj-towel (nth red-room dun-room-objects)))) - (dun-mprincl "There is a hole in the floor here.")) - - (if (and (= dun-current-room marine-life-area) dun-black) - (dun-mprincl -"The room is lit by a black light, causing the fish, and some of -your objects, to give off an eerie glow.")) - (if (and (= dun-current-room fourth-vermont-intersection) dun-hole) - (progn - (if (not dun-inbus) - (progn - (dun-mprincl"You fall into a hole in the ground.") - (setq dun-current-room vermont-station) - (dun-describe-room vermont-station)) - (progn - (dun-mprincl -"The bus falls down a hole in the ground and explodes.") - (dun-die "burning"))))) - - (if (> dun-current-room endgame-computer-room) - (progn - (if (not dun-correct-answer) - (dun-endgame-question) - (dun-mprincl "Your question is:") - (dun-mprincl dun-endgame-question)))) - - (if (= dun-current-room sauna) - (progn - (dun-mprincl (nth dun-sauna-level '( -"It is normal room temperature in here." -"It is luke warm in here." -"It is comfortably hot in here." -"It is refreshingly hot in here." -"You are dead now."))) - (if (and (= dun-sauna-level 3) - (or (member obj-rms dun-inventory) - (member obj-rms (nth dun-current-room dun-room-objects)))) - (progn - (dun-mprincl -"You notice the wax on your statuette beginning to melt, until it completely -melts off. You are left with a beautiful diamond!") - (if (member obj-rms dun-inventory) - (progn - (dun-remove-obj-from-inven obj-rms) - (setq dun-inventory (append dun-inventory - (list obj-diamond)))) - (dun-remove-obj-from-room dun-current-room obj-rms) - (dun-replace dun-room-objects dun-current-room - (append (nth dun-current-room dun-room-objects) - (list obj-diamond)))) - (if (member obj-floppy dun-inventory) - (progn - (dun-mprincl -"You notice your floppy disk beginning to melt. As you grab for it, the -disk bursts into flames, and disintegrates.") - (dun-remove-obj-from-inven obj-floppy) - (dun-remove-obj-from-room dun-current-room obj-floppy))))) - ))) - -(defun dun-die (murderer) - (dun-mprinc "\n") - (if murderer - (dun-mprincl "You are dead.")) - (dun-do-logfile 'dun-die murderer) - (dun-score nil) - (setq dun-dead t)) - -(defun dun-quit (args) - (dun-die nil)) - -;;; Print every object in player's inventory. Special case for the jar, -;;; as we must also print what is in it. - -(defun dun-inven (args) - (dun-mprinc "You currently have:") - (dun-mprinc "\n") - (dolist (curobj dun-inventory) - (if curobj - (progn - (dun-mprincl (cadr (nth curobj dun-objects))) - (if (and (= curobj obj-jar) dun-jar) - (progn - (dun-mprincl "The jar contains:") - (dolist (x dun-jar) - (dun-mprinc " ") - (dun-mprincl (cadr (nth x dun-objects)))))))))) - -(defun dun-shake (obj) - (let (objnum) - (when (setq objnum (dun-objnum-from-args-std obj)) - (if (member objnum dun-inventory) - (progn -;;; If shaking anything will do anything, put here. - (dun-mprinc "Shaking ") - (dun-mprinc (downcase (cadr (nth objnum dun-objects)))) - (dun-mprinc " seems to have no effect.") - (dun-mprinc "\n") - ) - (if (and (not (member objnum (nth dun-current-room dun-room-silents))) - (not (member objnum (nth dun-current-room dun-room-objects)))) - (dun-mprincl "I don't see that here.") -;;; Shaking trees can be deadly - (if (= objnum obj-tree) - (progn - (dun-mprinc - "You begin to shake a tree, and notice a coconut begin to fall from the air. -As you try to get your hand up to block it, you feel the impact as it lands -on your head.") - (dun-die "a coconut")) - (if (= objnum obj-bear) - (progn - (dun-mprinc -"As you go up to the bear, it removes your head and places it on the ground.") - (dun-die "a bear")) - (if (< objnum 0) - (dun-mprincl "You cannot shake that.") - (dun-mprincl "You don't have that."))))))))) - - -(defun dun-drop (obj) - (if dun-inbus - (dun-mprincl "You can't drop anything while on the bus.") - (let (objnum ptr) - (when (setq objnum (dun-objnum-from-args-std obj)) - (if (not (setq ptr (member objnum dun-inventory))) - (dun-mprincl "You don't have that.") - (progn - (dun-remove-obj-from-inven objnum) - (dun-replace dun-room-objects dun-current-room - (append (nth dun-current-room dun-room-objects) - (list objnum))) - (dun-mprincl "Done.") - (if (member objnum (list obj-food obj-weight obj-jar)) - (dun-drop-check objnum)))))))) - -;;; Dropping certain things causes things to happen. - -(defun dun-drop-check (objnum) - (if (and (= objnum obj-food) (= room bear-hangout) - (member obj-bear (nth bear-hangout dun-room-objects))) - (progn - (dun-mprincl -"The bear takes the food and runs away with it. He left something behind.") - (dun-remove-obj-from-room dun-current-room obj-bear) - (dun-remove-obj-from-room dun-current-room obj-food) - (dun-replace dun-room-objects dun-current-room - (append (nth dun-current-room dun-room-objects) - (list obj-key))))) - - (if (and (= objnum obj-jar) (member obj-nitric dun-jar) - (member obj-glycerine dun-jar)) - (progn - (dun-mprincl - "As the jar impacts the ground it explodes into many pieces.") - (setq dun-jar nil) - (dun-remove-obj-from-room dun-current-room obj-jar) - (if (= dun-current-room fourth-vermont-intersection) - (progn - (setq dun-hole t) - (setq dun-current-room vermont-station) - (dun-mprincl -"The explosion causes a hole to open up in the ground, which you fall -through."))))) - - (if (and (= objnum obj-weight) (= dun-current-room maze-button-room)) - (dun-mprincl "A passageway opens."))) - -;;; Give long description of current room, or an object. - -(defun dun-examine (obj) - (let (objnum) - (setq objnum (dun-objnum-from-args obj)) - (if (eq objnum obj-special) - (dun-describe-room (* dun-current-room -1)) - (if (and (eq objnum obj-computer) - (member obj-pc (nth dun-current-room dun-room-silents))) - (dun-examine '("pc")) - (if (eq objnum nil) - (dun-mprincl "I don't know what that is.") - (if (and (not (member objnum - (nth dun-current-room dun-room-objects))) - (not (member objnum - (nth dun-current-room dun-room-silents))) - (not (member objnum dun-inventory))) - (dun-mprincl "I don't see that here.") - (if (>= objnum 0) - (if (and (= objnum obj-bone) - (= dun-current-room marine-life-area) dun-black) - (dun-mprincl -"In this light you can see some writing on the bone. It says: -For an explosive time, go to Fourth St. and Vermont.") - (if (nth objnum dun-physobj-desc) - (dun-mprincl (nth objnum dun-physobj-desc)) - (dun-mprincl "I see nothing special about that."))) - (if (nth (abs objnum) dun-permobj-desc) - (progn - (dun-mprincl (nth (abs objnum) dun-permobj-desc))) - (dun-mprincl "I see nothing special about that."))))))))) - -(defun dun-take (obj) - (if dun-inbus - (dun-mprincl "You can't take anything while on the bus.") - (setq obj (dun-firstword obj)) - (if (not obj) - (dun-mprincl "You must supply an object.") - (if (string= obj "all") - (let (gotsome) - (setq gotsome nil) - (dolist (x (nth dun-current-room dun-room-objects)) - (if (and (>= x 0) (not (= x obj-special))) - (progn - (setq gotsome t) - (dun-mprinc (cadr (nth x dun-objects))) - (dun-mprinc ": ") - (dun-take-object x)))) - (if (not gotsome) - (dun-mprincl "Nothing to take."))) - (let (objnum) - (setq objnum (cdr (assq (intern obj) dun-objnames))) - (if (eq objnum nil) - (progn - (dun-mprinc "I don't know what that is.") - (dun-mprinc "\n")) - (dun-take-object objnum))))))) - -(defun dun-take-object (objnum) - (if (and (member objnum dun-jar) (member obj-jar dun-inventory)) - (let (newjar) - (dun-mprincl "You remove it from the jar.") - (setq newjar nil) - (dolist (x dun-jar) - (if (not (= x objnum)) - (setq newjar (append newjar (list x))))) - (setq dun-jar newjar) - (setq dun-inventory (append dun-inventory (list objnum)))) - (if (not (member objnum (nth dun-current-room dun-room-objects))) - (if (not (member objnum (nth dun-current-room dun-room-silents))) - (dun-mprinc "I do not see that here.") - (dun-try-take objnum)) - (if (>= objnum 0) - (progn - (if (and (car dun-inventory) - (> (+ (dun-inven-weight) (nth objnum dun-object-lbs)) 11)) - (dun-mprinc "Your load would be too heavy.") - (setq dun-inventory (append dun-inventory (list objnum))) - (dun-remove-obj-from-room dun-current-room objnum) - (dun-mprinc "Taken. ") - (if (and (= objnum obj-towel) (= dun-current-room red-room)) - (dun-mprinc - "Taking the towel reveals a hole in the floor.")))) - (dun-try-take objnum))) - (dun-mprinc "\n"))) - -(defun dun-inven-weight () - (let (total) - (setq total 0) - (dolist (x dun-jar) - (setq total (+ total (nth x dun-object-lbs)))) - (dolist (x dun-inventory) - (setq total (+ total (nth x dun-object-lbs)))) total)) - -;;; We try to take an object that is untakable. Print a message -;;; depending on what it is. - -(defun dun-try-take (obj) - (dun-mprinc "You cannot take that.")) - -(defun dun-dig (args) - (if dun-inbus - (dun-mprincl "You can't dig while on the bus.") - (if (not (member 0 dun-inventory)) - (dun-mprincl "You have nothing with which to dig.") - (if (not (nth dun-current-room dun-diggables)) - (dun-mprincl "Digging here reveals nothing.") - (dun-mprincl "I think you found something.") - (dun-replace dun-room-objects dun-current-room - (append (nth dun-current-room dun-room-objects) - (nth dun-current-room dun-diggables))) - (dun-replace dun-diggables dun-current-room nil))))) - -(defun dun-climb (obj) - (let (objnum) - (setq objnum (dun-objnum-from-args obj)) - (cond ((null objnum) - (dun-mprincl "I don't know that name.")) - ((and (not (eq objnum obj-special)) - (not (member objnum (nth dun-current-room dun-room-objects))) - (not (member objnum (nth dun-current-room dun-room-silents))) - (not (member objnum dun-inventory))) - (dun-mprincl "I don't see that here.")) - ((and (eq objnum obj-special) - (not (member obj-tree (nth dun-current-room dun-room-silents)))) - (dun-mprincl "There is nothing here to climb.")) - ((and (not (eq objnum obj-tree)) (not (eq objnum obj-special))) - (dun-mprincl "You can't climb that.")) - (t - (dun-mprincl - "You manage to get about two feet up the tree and fall back down. You -notice that the tree is very unsteady."))))) - -(defun dun-eat (obj) - (let (objnum) - (when (setq objnum (dun-objnum-from-args-std obj)) - (if (not (member objnum dun-inventory)) - (dun-mprincl "You don't have that.") - (if (not (= objnum obj-food)) - (progn - (dun-mprinc "You forcefully shove ") - (dun-mprinc (downcase (cadr (nth objnum dun-objects)))) - (dun-mprincl " down your throat, and start choking.") - (dun-die "choking")) - (dun-mprincl "That tasted horrible.") - (dun-remove-obj-from-inven obj-food)))))) - -(defun dun-put (args) - (if dun-inbus - (dun-mprincl "You can't do that while on the bus") - (let (newargs objnum objnum2 obj) - (setq newargs (dun-firstwordl args)) - (if (not newargs) - (dun-mprincl "You must supply an object") - (setq obj (intern (car newargs))) - (setq objnum (cdr (assq obj dun-objnames))) - (if (not objnum) - (dun-mprincl "I don't know what that object is.") - (if (not (member objnum dun-inventory)) - (dun-mprincl "You don't have that.") - (setq newargs (dun-firstwordl (cdr newargs))) - (setq newargs (dun-firstwordl (cdr newargs))) - (if (not newargs) - (dun-mprincl "You must supply an indirect object.") - (setq objnum2 (cdr (assq (intern (car newargs)) dun-objnames))) - (if (and (eq objnum2 obj-computer) (= dun-current-room pc-area)) - (setq objnum2 obj-pc)) - (if (not objnum2) - (dun-mprincl "I don't know what that indirect object is.") - (if (and (not (member objnum2 - (nth dun-current-room dun-room-objects))) - (not (member objnum2 - (nth dun-current-room dun-room-silents))) - (not (member objnum2 dun-inventory))) - (dun-mprincl "That indirect object is not here.") - (dun-put-objs objnum objnum2)))))))))) - -(defun dun-put-objs (obj1 obj2) - (if (and (= obj2 obj-drop) (not dun-nomail)) - (setq obj2 obj-chute)) - - (if (= obj2 obj-disposal) (setq obj2 obj-chute)) - - (if (and (= obj1 obj-cpu) (= obj2 obj-computer)) - (progn - (dun-remove-obj-from-inven obj-cpu) - (setq dun-computer t) - (dun-mprincl -"As you put the CPU board in the computer, it immediately springs to life. -The lights start flashing, and the fans seem to startup.")) - (if (and (= obj1 obj-weight) (= obj2 obj-button)) - (dun-drop '("weight")) - (if (= obj2 obj-jar) ;; Put something in jar - (if (not (member obj1 (list obj-paper obj-diamond obj-emerald - obj-license obj-coins obj-egg - obj-nitric obj-glycerine))) - (dun-mprincl "That will not fit in the jar.") - (dun-remove-obj-from-inven obj1) - (setq dun-jar (append dun-jar (list obj1))) - (dun-mprincl "Done.")) - (if (= obj2 obj-chute) ;; Put something in chute - (progn - (dun-remove-obj-from-inven obj1) - (dun-mprincl -"You hear it slide down the chute and off into the distance.") - (dun-put-objs-in-treas (list obj1))) - (if (= obj2 obj-box) ;; Put key in key box - (if (= obj1 obj-key) - (progn - (dun-mprincl -"As you drop the key, the box begins to shake. Finally it explodes -with a bang. The key seems to have vanished!") - (dun-remove-obj-from-inven obj1) - (dun-replace dun-room-objects computer-room (append - (nth computer-room - dun-room-objects) - (list obj1))) - (dun-remove-obj-from-room dun-current-room obj-box) - (setq dun-key-level (1+ dun-key-level))) - (dun-mprincl "You can't put that in the key box!")) - - (if (and (= obj1 obj-floppy) (= obj2 obj-pc)) - (progn - (setq dun-floppy t) - (dun-remove-obj-from-inven obj1) - (dun-mprincl "Done.")) - - (if (= obj2 obj-urinal) ;; Put object in urinal - (progn - (dun-remove-obj-from-inven obj1) - (dun-replace dun-room-objects urinal (append - (nth urinal dun-room-objects) - (list obj1))) - (dun-mprincl - "You hear it plop down in some water below.")) - (if (= obj2 obj-mail) - (dun-mprincl "The mail chute is locked.") - (if (member obj1 dun-inventory) - (dun-mprincl -"I don't know how to combine those objects. Perhaps you should -just try dropping it.") - (dun-mprincl"You can't put that there."))))))))))) - -(defun dun-type (args) - (if (not (= dun-current-room computer-room)) - (dun-mprincl "There is nothing here on which you could type.") - (if (not dun-computer) - (dun-mprincl -"You type on the keyboard, but your characters do not even echo.") - (dun-unix-interface)))) - -;;; Various movement directions - -(defun dun-n (args) - (dun-move north)) - -(defun dun-s (args) - (dun-move south)) - -(defun dun-e (args) - (dun-move east)) - -(defun dun-w (args) - (dun-move west)) - -(defun dun-ne (args) - (dun-move northeast)) - -(defun dun-se (args) - (dun-move southeast)) - -(defun dun-nw (args) - (dun-move northwest)) - -(defun dun-sw (args) - (dun-move southwest)) - -(defun dun-up (args) - (dun-move up)) - -(defun dun-down (args) - (dun-move down)) - -(defun dun-in (args) - (dun-move in)) - -(defun dun-out (args) - (dun-move out)) - -(defun dun-go (args) - (if (or (not (car args)) - (eq (dun-doverb dun-ignore dun-verblist (car args) - (cdr (cdr args))) -1)) - (dun-mprinc "I don't understand where you want me to go.\n"))) - -;;; Uses the dungeon-map to figure out where we are going. If the -;;; requested direction yields 255, we know something special is -;;; supposed to happen, or perhaps you can't go that way unless -;;; certain conditions are met. - -(defun dun-move (dir) - (if (and (not (member dun-current-room dun-light-rooms)) - (not (member obj-lamp dun-inventory))) - (progn - (dun-mprinc -"You trip over a grue and fall into a pit and break every bone in your -body.") - (dun-die "a grue")) - (let (newroom) - (setq newroom (nth dir (nth dun-current-room dungeon-map))) - (if (eq newroom -1) - (dun-mprinc "You can't go that way.\n") - (if (eq newroom 255) - (dun-special-move dir) - (setq room -1) - (setq dun-lastdir dir) - (if dun-inbus - (progn - (if (or (< newroom 58) (> newroom 83)) - (dun-mprincl "The bus cannot go this way.") - (dun-mprincl - "The bus lurches ahead and comes to a screeching halt.") - (dun-remove-obj-from-room dun-current-room obj-bus) - (setq dun-current-room newroom) - (dun-replace dun-room-objects newroom - (append (nth newroom dun-room-objects) - (list obj-bus))))) - (setq dun-current-room newroom))))))) - -;;; Movement in this direction causes something special to happen if the -;;; right conditions exist. It may be that you can't go this way unless -;;; you have a key, or a passage has been opened. - -;;; coding note: Each check of the current room is on the same 'if' level, -;;; i.e. there aren't else's. If two rooms next to each other have -;;; specials, and they are connected by specials, this could cause -;;; a problem. Be careful when adding them to consider this, and -;;; perhaps use else's. - -(defun dun-special-move (dir) - (if (= dun-current-room building-front) - (if (not (member obj-key dun-inventory)) - (dun-mprincl "You don't have a key that can open this door.") - (setq dun-current-room old-building-hallway)) - (if (= dun-current-room north-end-of-cave-passage) - (let (combo) - (dun-mprincl -"You must type a 3 digit combination code to enter this room.") - (dun-mprinc "Enter it here: ") - (setq combo (dun-read-line)) - (if (not dun-batch-mode) - (dun-mprinc "\n")) - (if (string= combo dun-combination) - (setq dun-current-room gamma-computing-center) - (dun-mprincl "Sorry, that combination is incorrect.")))) - - (if (= dun-current-room bear-hangout) - (if (member obj-bear (nth bear-hangout dun-room-objects)) - (progn - (dun-mprinc -"The bear is very annoyed that you would be so presumptuous as to try -and walk right by it. He tells you so by tearing your head off. -") - (dun-die "a bear")) - (dun-mprincl "You can't go that way."))) - - (if (= dun-current-room vermont-station) - (progn - (dun-mprincl -"As you board the train it immediately leaves the station. It is a very -bumpy ride. It is shaking from side to side, and up and down. You -sit down in one of the chairs in order to be more comfortable.") - (dun-mprincl -"\nFinally the train comes to a sudden stop, and the doors open, and some -force throws you out. The train speeds away.\n") - (setq dun-current-room museum-station))) - - (if (= dun-current-room old-building-hallway) - (if (and (member obj-key dun-inventory) - (> dun-key-level 0)) - (setq dun-current-room meadow) - (dun-mprincl "You don't have a key that can open this door."))) - - (if (and (= dun-current-room maze-button-room) (= dir northwest)) - (if (member obj-weight (nth maze-button-room dun-room-objects)) - (setq dun-current-room 18) - (dun-mprincl "You can't go that way."))) - - (if (and (= dun-current-room maze-button-room) (= dir up)) - (if (member obj-weight (nth maze-button-room dun-room-objects)) - (dun-mprincl "You can't go that way.") - (setq dun-current-room weight-room))) - - (if (= dun-current-room classroom) - (dun-mprincl "The door is locked.")) - - (if (or (= dun-current-room lakefront-north) - (= dun-current-room lakefront-south)) - (dun-swim nil)) - - (if (= dun-current-room reception-area) - (if (not (= dun-sauna-level 3)) - (setq dun-current-room health-club-front) - (dun-mprincl -"As you exit the building, you notice some flames coming out of one of the -windows. Suddenly, the building explodes in a huge ball of fire. The flames -engulf you, and you burn to death.") - (dun-die "burning"))) - - (if (= dun-current-room red-room) - (if (not (member obj-towel (nth red-room dun-room-objects))) - (setq dun-current-room long-n-s-hallway) - (dun-mprincl "You can't go that way."))) - - (if (and (> dir down) (> dun-current-room gamma-computing-center) - (< dun-current-room museum-lobby)) - (if (not (member obj-bus (nth dun-current-room dun-room-objects))) - (dun-mprincl "You can't go that way.") - (if (= dir in) - (if (member obj-license dun-inventory) - (progn - (dun-mprincl - "You board the bus and get in the driver's seat.") - (setq dun-nomail t) - (setq dun-inbus t)) - (dun-mprincl "You are not licensed for this type of vehicle.")) - (dun-mprincl "You hop off the bus.") - (setq dun-inbus nil))) - (if (= dun-current-room fifth-oaktree-intersection) - (if (not dun-inbus) - (progn - (dun-mprincl "You fall down the cliff and land on your head.") - (dun-die "a cliff")) - (dun-mprincl -"The bus flies off the cliff, and plunges to the bottom, where it explodes.") - (dun-die "a bus accident"))) - (if (= dun-current-room main-maple-intersection) - (progn - (if (not dun-inbus) - (dun-mprincl "The gate will not open.") - (dun-mprincl -"As the bus approaches, the gate opens and you drive through.") - (dun-remove-obj-from-room main-maple-intersection obj-bus) - (dun-replace dun-room-objects museum-entrance - (append (nth museum-entrance dun-room-objects) - (list obj-bus))) - (setq dun-current-room museum-entrance))))) - (if (= dun-current-room cave-entrance) - (progn - (dun-mprincl -"As you enter the room you hear a rumbling noise. You look back to see -huge rocks sliding down from the ceiling, and blocking your way out.\n") - (setq dun-current-room misty-room))))) - -(defun dun-long (args) - (setq dun-mode "long")) - -(defun dun-turn (obj) - (let (objnum direction) - (when (setq objnum (dun-objnum-from-args-std obj)) - (if (not (or (member objnum (nth dun-current-room dun-room-objects)) - (member objnum (nth dun-current-room dun-room-silents)))) - (dun-mprincl "I don't see that here.") - (if (not (= objnum obj-dial)) - (dun-mprincl "You can't turn that.") - (setq direction (dun-firstword (cdr obj))) - (if (or (not direction) - (not (or (string= direction "clockwise") - (string= direction "counterclockwise")))) - (dun-mprincl "You must indicate clockwise or counterclockwise.") - (if (string= direction "clockwise") - (setq dun-sauna-level (+ dun-sauna-level 1)) - (setq dun-sauna-level (- dun-sauna-level 1))) - - (if (< dun-sauna-level 0) - (progn - (dun-mprincl - "The dial will not turn further in that direction.") - (setq dun-sauna-level 0)) - (dun-sauna-heat)))))))) - -(defun dun-sauna-heat () - (if (= dun-sauna-level 0) - (dun-mprincl - "The temperature has returned to normal room temperature.")) - (if (= dun-sauna-level 1) - (dun-mprincl "It is now luke warm in here. You begin to sweat.")) - (if (= dun-sauna-level 2) - (dun-mprincl "It is pretty hot in here. It is still very comfortable.")) - (if (= dun-sauna-level 3) - (progn - (dun-mprincl -"It is now very hot. There is something very refreshing about this.") - (if (or (member obj-rms dun-inventory) - (member obj-rms (nth dun-current-room dun-room-objects))) - (progn - (dun-mprincl -"You notice the wax on your statuette beginning to melt, until it completely -melts off. You are left with a beautiful diamond!") - (if (member obj-rms dun-inventory) - (progn - (dun-remove-obj-from-inven obj-rms) - (setq dun-inventory (append dun-inventory - (list obj-diamond)))) - (dun-remove-obj-from-room dun-current-room obj-rms) - (dun-replace dun-room-objects dun-current-room - (append (nth dun-current-room dun-room-objects) - (list obj-diamond)))))) - (if (or (member obj-floppy dun-inventory) - (member obj-floppy (nth dun-current-room dun-room-objects))) - (progn - (dun-mprincl -"You notice your floppy disk beginning to melt. As you grab for it, the -disk bursts into flames, and disintegrates.") - (if (member obj-floppy dun-inventory) - (dun-remove-obj-from-inven obj-floppy) - (dun-remove-obj-from-room dun-current-room obj-floppy)))))) - - (if (= dun-sauna-level 4) - (progn - (dun-mprincl -"As the dial clicks into place, you immediately burst into flames.") - (dun-die "burning")))) - -(defun dun-press (obj) - (let (objnum) - (when (setq objnum (dun-objnum-from-args-std obj)) - (if (not (or (member objnum (nth dun-current-room dun-room-objects)) - (member objnum (nth dun-current-room dun-room-silents)))) - (dun-mprincl "I don't see that here.") - (if (not (member objnum (list obj-button obj-switch))) - (progn - (dun-mprinc "You can't ") - (dun-mprinc (car line-list)) - (dun-mprincl " that.")) - (if (= objnum obj-button) - (dun-mprincl -"As you press the button, you notice a passageway open up, but -as you release it, the passageway closes.")) - (if (= objnum obj-switch) - (if dun-black - (progn - (dun-mprincl "The button is now in the off position.") - (setq dun-black nil)) - (dun-mprincl "The button is now in the on position.") - (setq dun-black t)))))))) - -(defun dun-swim (args) - (if (not (member dun-current-room (list lakefront-north lakefront-south))) - (dun-mprincl "I see no water!") - (if (not (member obj-life dun-inventory)) - (progn - (dun-mprincl -"You dive in the water, and at first notice it is quite cold. You then -start to get used to it as you realize that you never really learned how -to swim.") - (dun-die "drowning")) - (if (= dun-current-room lakefront-north) - (setq dun-current-room lakefront-south) - (setq dun-current-room lakefront-north))))) - - -(defun dun-score (args) - (if (not dun-endgame) - (let (total) - (setq total (dun-reg-score)) - (dun-mprinc "You have scored ") - (dun-mprinc total) - (dun-mprincl " out of a possible 90 points.") total) - (dun-mprinc "You have scored ") - (dun-mprinc (dun-endgame-score)) - (dun-mprincl " endgame points out of a possible 110.") - (if (= (dun-endgame-score) 110) - (dun-mprincl -"\n\nCongratulations. You have won. The wizard password is 'moby'")))) - -(defun dun-help (args) - (dun-mprincl -"Welcome to dunnet (2.0), by Ron Schnell (ronnie@media.mit.edu). -Here is some useful information (read carefully because there are one -or more clues in here): -- If you have a key that can open a door, you do not need to explicitly - open it. You may just use 'in' or walk in the direction of the door. - -- If you have a lamp, it is always lit. - -- You will not get any points until you manage to get treasures to a certain - place. Simply finding the treasures is not good enough. There is more - than one way to get a treasure to the special place. It is also - important that the objects get to the special place *unharmed* and - *untarnished*. You can tell if you have successfully transported the - object by looking at your score, as it changes immediately. Note that - an object can become harmed even after you have received points for it. - If this happens, your score will decrease, and in many cases you can never - get credit for it again. - -- You can save your game with the 'save' command, and use restore it - with the 'restore' command. - -- There are no limits on lengths of object names. - -- Directions are: north,south,east,west,northeast,southeast,northwest, - southwest,up,down,in,out. - -- These can be abbreviated: n,s,e,w,ne,se,nw,sw,u,d,in,out. - -- If you go down a hole in the floor without an aid such as a ladder, - you probably won't be able to get back up the way you came, if at all. - -- To run this game in batch mode (no emacs window), use: - emacs -batch -l dunnet - -If you have questions or comments, please contact ronnie@media.mit.edu.")) - -(defun dun-flush (args) - (if (not (= dun-current-room bathroom)) - (dun-mprincl "I see nothing to flush.") - (dun-mprincl "Whoooosh!!") - (dun-put-objs-in-treas (nth urinal dun-room-objects)) - (dun-replace dun-room-objects urinal nil))) - -(defun dun-urinate (args) - (if (not (= dun-current-room bathroom)) - (dun-mprincl "You can't do that here, don't even bother trying.") - (if (not dun-gottago) - (dun-mprincl "I'm afraid you don't have to go now.") - (dun-mprincl "That was refreshing.") - (setq dun-gottago nil) - (dun-replace dun-room-objects urinal (append - (nth urinal dun-room-objects) - (list obj-URINE)))))) - - -(defun dun-sleep (args) - (if (not (= dun-current-room bedroom)) - (dun-mprincl -"You try to go to sleep while standing up here, but can't seem to do it.") - (setq dun-gottago t) - (dun-mprincl -"As soon as you start to doze off you begin dreaming. You see images of -workers digging caves, slaving in the humid heat. Then you see yourself -as one of these workers. While no one is looking, you leave the group -and walk into a room. The room is bare except for a horseshoe -shaped piece of stone in the center. You see yourself digging a hole in -the ground, then putting some kind of treasure in it, and filling the hole -with dirt again. After this, you immediately wake up."))) - -(defun dun-break (obj) - (let (objnum) - (if (not (member obj-axe dun-inventory)) - (dun-mprincl "You have nothing you can use to break things.") - (when (setq objnum (dun-objnum-from-args-std obj)) - (if (member objnum dun-inventory) - (progn - (dun-mprincl -"You take the object in your hands and swing the axe. Unfortunately, you miss -the object and slice off your hand. You bleed to death.") - (dun-die "an axe")) - (if (not (or (member objnum (nth dun-current-room dun-room-objects)) - (member objnum - (nth dun-current-room dun-room-silents)))) - (dun-mprincl "I don't see that here.") - (if (= objnum obj-cable) - (progn - (dun-mprincl -"As you break the ethernet cable, everything starts to blur. You collapse -for a moment, then straighten yourself up. -") - (dun-replace dun-room-objects gamma-computing-center - (append - (nth gamma-computing-center dun-room-objects) - dun-inventory)) - (if (member obj-key dun-inventory) - (progn - (setq dun-inventory (list obj-key)) - (dun-remove-obj-from-room - gamma-computing-center obj-key)) - (setq dun-inventory nil)) - (setq dun-current-room computer-room) - (setq dun-ethernet nil) - (dun-mprincl "Connection closed.") - (dun-unix-interface)) - (if (< objnum 0) - (progn - (dun-mprincl "Your axe shatters into a million pieces.") - (dun-remove-obj-from-inven obj-axe)) - (dun-mprincl "Your axe breaks it into a million pieces.") - (dun-remove-obj-from-room dun-current-room objnum))))))))) - -(defun dun-drive (args) - (if (not dun-inbus) - (dun-mprincl "You cannot drive when you aren't in a vehicle.") - (dun-mprincl "To drive while you are in the bus, just give a direction."))) - -(defun dun-superb (args) - (setq dun-mode 'dun-superb)) - -(defun dun-reg-score () - (let (total) - (setq total 0) - (dolist (x (nth treasure-room dun-room-objects)) - (setq total (+ total (nth x dun-object-pts)))) - (if (member obj-URINE (nth treasure-room dun-room-objects)) - (setq total 0)) total)) - -(defun dun-endgame-score () - (let (total) - (setq total 0) - (dolist (x (nth endgame-treasure-room dun-room-objects)) - (setq total (+ total (nth x dun-object-pts)))) total)) - -(defun dun-answer (args) - (if (not dun-correct-answer) - (dun-mprincl "I don't believe anyone asked you anything.") - (setq args (car args)) - (if (not args) - (dun-mprincl "You must give the answer on the same line.") - (if (dun-members args dun-correct-answer) - (progn - (dun-mprincl "Correct.") - (if (= dun-lastdir 0) - (setq dun-current-room (1+ dun-current-room)) - (setq dun-current-room (- dun-current-room 1))) - (setq dun-correct-answer nil)) - (dun-mprincl "That answer is incorrect."))))) - -(defun dun-endgame-question () -(if (not dun-endgame-questions) - (progn - (dun-mprincl "Your question is:") - (dun-mprincl "No more questions, just do 'answer foo'.") - (setq dun-correct-answer '("foo"))) - (let (which i newques) - (setq i 0) - (setq newques nil) - (setq which (random (length dun-endgame-questions))) - (dun-mprincl "Your question is:") - (dun-mprincl (setq dun-endgame-question (car - (nth which - dun-endgame-questions)))) - (setq dun-correct-answer (cdr (nth which dun-endgame-questions))) - (while (< i which) - (setq newques (append newques (list (nth i dun-endgame-questions)))) - (setq i (1+ i))) - (setq i (1+ which)) - (while (< i (length dun-endgame-questions)) - (setq newques (append newques (list (nth i dun-endgame-questions)))) - (setq i (1+ i))) - (setq dun-endgame-questions newques)))) - -(defun dun-power (args) - (if (not (= dun-current-room pc-area)) - (dun-mprincl "That operation is not applicable here.") - (if (not dun-floppy) - (dun-dos-no-disk) - (dun-dos-interface)))) - -(defun dun-feed (args) - (let (objnum) - (when (setq objnum (dun-objnum-from-args-std args)) - (if (and (= objnum obj-bear) - (member obj-bear (nth dun-current-room dun-room-objects))) - (progn - (if (not (member obj-food dun-inventory)) - (dun-mprincl "You have nothing with which to feed it.") - (dun-drop '("food")))) - (if (not (or (member objnum (nth dun-current-room dun-room-objects)) - (member objnum dun-inventory) - (member objnum (nth dun-current-room dun-room-silents)))) - (dun-mprincl "I don't see that here.") - (dun-mprincl "You cannot feed that.")))))) - - -;;;; -;;;; This section defines various utility functions used -;;;; by dunnet. -;;;; - - -;;; Function which takes a verb and a list of other words. Calls proper -;;; function associated with the verb, and passes along the other words. - -(defun dun-doverb (dun-ignore dun-verblist verb rest) - (if (not verb) - nil - (if (member (intern verb) dun-ignore) - (if (not (car rest)) -1 - (dun-doverb dun-ignore dun-verblist (car rest) (cdr rest))) - (if (not (cdr (assq (intern verb) dun-verblist))) -1 - (setq dun-numcmds (1+ dun-numcmds)) - (eval (list (cdr (assq (intern verb) dun-verblist)) (quote rest))))))) - - -;;; Function to take a string and change it into a list of lowercase words. - -(defun dun-listify-string (strin) - (let (pos ret-list end-pos) - (setq pos 0) - (setq ret-list nil) - (while (setq end-pos (string-match "[ ,:;]" (substring strin pos))) - (setq end-pos (+ end-pos pos)) - (if (not (= end-pos pos)) - (setq ret-list (append ret-list (list - (downcase - (substring strin pos end-pos)))))) - (setq pos (+ end-pos 1))) ret-list)) - -(defun dun-listify-string2 (strin) - (let (pos ret-list end-pos) - (setq pos 0) - (setq ret-list nil) - (while (setq end-pos (string-match " " (substring strin pos))) - (setq end-pos (+ end-pos pos)) - (if (not (= end-pos pos)) - (setq ret-list (append ret-list (list - (downcase - (substring strin pos end-pos)))))) - (setq pos (+ end-pos 1))) ret-list)) - -(defun dun-replace (list n number) - (rplaca (nthcdr n list) number)) - - -;;; Get the first non-ignored word from a list. - -(defun dun-firstword (list) - (if (not (car list)) - nil - (while (and list (member (intern (car list)) dun-ignore)) - (setq list (cdr list))) - (car list))) - -(defun dun-firstwordl (list) - (if (not (car list)) - nil - (while (and list (member (intern (car list)) dun-ignore)) - (setq list (cdr list))) - list)) - -;;; parse a line passed in as a string Call the proper verb with the -;;; rest of the line passed in as a list. - -(defun dun-vparse (dun-ignore dun-verblist line) - (dun-mprinc "\n") - (setq line-list (dun-listify-string (concat line " "))) - (dun-doverb dun-ignore dun-verblist (car line-list) (cdr line-list))) - -(defun dun-parse2 (dun-ignore dun-verblist line) - (dun-mprinc "\n") - (setq line-list (dun-listify-string2 (concat line " "))) - (dun-doverb dun-ignore dun-verblist (car line-list) (cdr line-list))) - -;;; Read a line, in window mode - -(defun dun-read-line () - (let (line) - (setq line (read-string "")) - (dun-mprinc line) line)) - -;;; Insert something into the window buffer - -(defun dun-minsert (string) - (if (stringp string) - (insert string) - (insert (prin1-to-string string)))) - -;;; Print something out, in window mode - -(defun dun-mprinc (string) - (if (stringp string) - (insert string) - (insert (prin1-to-string string)))) - -;;; In window mode, keep screen from jumping by keeping last line at -;;; the bottom of the screen. - -(defun dun-fix-screen () - (interactive) - (forward-line (- 0 (- (window-height) 2 ))) - (set-window-start (selected-window) (point)) - (end-of-buffer)) - -;;; Insert something into the buffer, followed by newline. - -(defun dun-minsertl (string) - (dun-minsert string) - (dun-minsert "\n")) - -;;; Print something, followed by a newline. - -(defun dun-mprincl (string) - (dun-mprinc string) - (dun-mprinc "\n")) - -;;; Function which will get an object number given the list of -;;; words in the command, except for the verb. - -(defun dun-objnum-from-args (obj) - (let (objnum) - (setq obj (dun-firstword obj)) - (if (not obj) - obj-special - (setq objnum (cdr (assq (intern obj) dun-objnames)))))) - -(defun dun-objnum-from-args-std (obj) - (let (result) - (if (eq (setq result (dun-objnum-from-args obj)) obj-special) - (dun-mprincl "You must supply an object.")) - (if (eq result nil) - (dun-mprincl "I don't know what that is.")) - (if (eq result obj-special) - nil - result))) - -;;; Take a short room description, and change spaces and slashes to dashes. - -(defun dun-space-to-hyphen (string) - (let (space) - (if (setq space (string-match "[ /]" string)) - (progn - (setq string (concat (substring string 0 space) "-" - (substring string (1+ space)))) - (dun-space-to-hyphen string)) - string))) - -;;; Given a unix style pathname, build a list of path components (recursive) - -(defun dun-get-path (dirstring startlist) - (let (slash pos) - (if (= (length dirstring) 0) - startlist - (if (string= (substring dirstring 0 1) "/") - (dun-get-path (substring dirstring 1) (append startlist (list "/"))) - (if (not (setq slash (string-match "/" dirstring))) - (append startlist (list dirstring)) - (dun-get-path (substring dirstring (1+ slash)) - (append startlist - (list (substring dirstring 0 slash))))))))) - - -;;; Is a string a member of a string list? - -(defun dun-members (string string-list) - (let (found) - (setq found nil) - (dolist (x string-list) - (if (string= x string) - (setq found t))) found)) - -;;; Function to put objects in the treasure room. Also prints current -;;; score to let user know he has scored. - -(defun dun-put-objs-in-treas (objlist) - (let (oscore newscore) - (setq oscore (dun-reg-score)) - (dun-replace dun-room-objects 0 (append (nth 0 dun-room-objects) objlist)) - (setq newscore (dun-reg-score)) - (if (not (= oscore newscore)) - (dun-score nil)))) - -;;; Load an encrypted file, and eval it. - -(defun dun-load-d (filename) - (let (old-buffer result) - (setq result t) - (setq old-buffer (current-buffer)) - (switch-to-buffer (get-buffer-create "*loadc*")) - (erase-buffer) - (condition-case nil - (insert-file-contents filename) - (error (setq result nil))) - (unless (not result) - (condition-case nil - (dun-rot13) - (error (yank))) - (eval-current-buffer) - (kill-buffer (current-buffer)) - (switch-to-buffer old-buffer)) - result)) - -;;; Functions to remove an object either from a room, or from inventory. - -(defun dun-remove-obj-from-room (room objnum) - (let (newroom) - (setq newroom nil) - (dolist (x (nth room dun-room-objects)) - (if (not (= x objnum)) - (setq newroom (append newroom (list x))))) - (rplaca (nthcdr room dun-room-objects) newroom))) - -(defun dun-remove-obj-from-inven (objnum) - (let (new-inven) - (setq new-inven nil) - (dolist (x dun-inventory) - (if (not (= x objnum)) - (setq new-inven (append new-inven (list x))))) - (setq dun-inventory new-inven))) - - -(let ((i 0) (lower "abcdefghijklmnopqrstuvwxyz") upper) - (setq dun-translate-table (make-vector 256 0)) - (while (< i 256) - (aset dun-translate-table i i) - (setq i (1+ i))) - (setq lower (concat lower lower)) - (setq upper (upcase lower)) - (setq i 0) - (while (< i 26) - (aset dun-translate-table (+ ?a i) (aref lower (+ i 13))) - (aset dun-translate-table (+ ?A i) (aref upper (+ i 13))) - (setq i (1+ i)))) - -(defun dun-rot13 () - (let (str len (i 0)) - (setq str (buffer-substring (point-min) (point-max))) - (setq len (length str)) - (while (< i len) - (aset str i (aref dun-translate-table (aref str i))) - (setq i (1+ i))) - (erase-buffer) - (insert str))) - -;;;; -;;;; This section defines the globals that are used in dunnet. -;;;; -;;;; IMPORTANT -;;;; All globals which can change must be saved from 'save-game. Add -;;;; all new globals to bottom of file. - -(setq dun-visited '(27)) -(setq dun-current-room 1) -(setq dun-exitf nil) -(setq dun-badcd nil) -(defvar dungeon-mode-map nil) -(setq dungeon-mode-map (make-sparse-keymap)) -(define-key dungeon-mode-map "\r" 'dun-parse) -(defvar dungeon-batch-map (make-keymap)) -(if (string= (substring emacs-version 0 2) "18") - (let (n) - (setq n 32) - (while (< 0 (setq n (- n 1))) - (aset dungeon-batch-map n 'dungeon-nil))) - (let (n) - (setq n 32) - (while (< 0 (setq n (- n 1))) - (aset (car (cdr dungeon-batch-map)) n 'dungeon-nil)))) -(define-key dungeon-batch-map "\r" 'exit-minibuffer) -(define-key dungeon-batch-map "\n" 'exit-minibuffer) -(setq dun-computer nil) -(setq dun-floppy nil) -(setq dun-key-level 0) -(setq dun-hole nil) -(setq dun-correct-answer nil) -(setq dun-lastdir 0) -(setq dun-numsaves 0) -(setq dun-jar nil) -(setq dun-dead nil) -(setq room 0) -(setq dun-numcmds 0) -(setq dun-wizard nil) -(setq dun-endgame-question nil) -(setq dun-logged-in nil) -(setq dungeon-mode 'dungeon) -(setq dun-unix-verbs '((ls . dun-ls) (ftp . dun-ftp) (echo . dun-echo) - (exit . dun-uexit) (cd . dun-cd) (pwd . dun-pwd) - (rlogin . dun-rlogin) (uncompress . dun-uncompress) - (cat . dun-cat) (zippy . dun-zippy))) - -(setq dun-dos-verbs '((dir . dun-dos-dir) (type . dun-dos-type) - (exit . dun-dos-exit) (command . dun-dos-spawn) - (b: . dun-dos-invd) (c: . dun-dos-invd) - (a: . dun-dos-nil))) - - -(setq dun-batch-mode nil) - -(setq dun-cdpath "/usr/toukmond") -(setq dun-cdroom -10) -(setq dun-uncompressed nil) -(setq dun-ethernet t) -(setq dun-restricted - '(dun-room-objects dungeon-map dun-rooms - dun-room-silents dun-combination)) -(setq dun-ftptype 'ascii) -(setq dun-endgame nil) -(setq dun-gottago t) -(setq dun-black nil) - -(setq dun-rooms '( - ( -"You are in the treasure room. A door leads out to the north." - "Treasure room" - ) - ( -"You are at a dead end of a dirt road. The road goes to the east. -In the distance you can see that it will eventually fork off. The -trees here are very tall royal palms, and they are spaced equidistant -from each other." - "Dead end" - ) - ( -"You are on the continuation of a dirt road. There are more trees on -both sides of you. The road continues to the east and west." - "E/W Dirt road" - ) - ( -"You are at a fork of two passages, one to the northeast, and one to the -southeast. The ground here seems very soft. You can also go back west." - "Fork" - ) - ( -"You are on a northeast/southwest road." - "NE/SW road" - ) - ( -"You are at the end of the road. There is a building in front of you -to the northeast, and the road leads back to the southwest." - "Building front" - ) - ( -"You are on a southeast/northwest road." - "SE/NW road" - ) - ( -"You are standing at the end of a road. A passage leads back to the -northwest." - "Bear hangout" - ) - ( -"You are in the hallway of an old building. There are rooms to the east -and west, and doors leading out to the north and south." - "Old Building hallway" - ) - ( -"You are in a mailroom. There are many bins where the mail is usually -kept. The exit is to the west." - "Mailroom" - ) - ( -"You are in a computer room. It seems like most of the equipment has -been removed. There is a VAX 11/780 in front of you, however, with -one of the cabinets wide open. A sign on the front of the machine -says: This VAX is named 'pokey'. To type on the console, use the -'type' command. The exit is to the east." - "Computer room" - ) - ( -"You are in a meadow in the back of an old building. A small path leads -to the west, and a door leads to the south." - "Meadow" - ) - ( -"You are in a round, stone room with a door to the east. There -is a sign on the wall that reads: 'receiving room'." - "Receiving room" - ) - ( -"You are at the south end of a hallway that leads to the north. There -are rooms to the east and west." - "Northbound Hallway" - ) - ( -"You are in a sauna. There is nothing in the room except for a dial -on the wall. A door leads out to west." - "Sauna" - ) - ( -"You are at the end of a north/south hallway. You can go back to the south, -or off to a room to the east." - "End of N/S Hallway" - ) - ( -"You are in an old weight room. All of the equipment is either destroyed -or completely broken. There is a door out to the west, and there is a ladder -leading down a hole in the floor." - "Weight room" ;16 - ) - ( -"You are in a maze of twisty little passages, all alike. -There is a button on the ground here." - "Maze button room" - ) - ( -"You are in a maze of little twisty passages, all alike." - "Maze" - ) - ( -"You are in a maze of thirsty little passages, all alike." - "Maze" ;19 - ) - ( -"You are in a maze of twenty little passages, all alike." - "Maze" - ) - ( -"You are in a daze of twisty little passages, all alike." - "Maze" ;21 - ) - ( -"You are in a maze of twisty little cabbages, all alike." - "Maze" ;22 - ) - ( -"You are in a reception area for a health and fitness center. The place -appears to have been recently ransacked, and nothing is left. There is -a door out to the south, and a crawlspace to the southeast." - "Reception area" - ) - ( -"You are outside a large building to the north which used to be a health -and fitness center. A road leads to the south." - "Health Club front" - ) - ( -"You are at the north side of a lake. On the other side you can see -a road which leads to a cave. The water appears very deep." - "Lakefront North" - ) - ( -"You are at the south side of a lake. A road goes to the south." - "Lakefront South" - ) - ( -"You are in a well-hidden area off to the side of a road. Back to the -northeast through the brush you can see the bear hangout." - "Hidden area" - ) - ( -"The entrance to a cave is to the south. To the north, a road leads -towards a deep lake. On the ground nearby there is a chute, with a sign -that says 'put treasures here for points'." - "Cave Entrance" ;28 - ) - ( -"You are in a misty, humid room carved into a mountain. -To the north is the remains of a rockslide. To the east, a small -passage leads away into the darkness." ;29 - "Misty Room" - ) - ( -"You are in an east/west passageway. The walls here are made of -multicolored rock and are quite beautiful." - "Cave E/W passage" ;30 - ) - ( -"You are at the junction of two passages. One goes north/south, and -the other goes west." - "N/S/W Junction" ;31 - ) - ( -"You are at the north end of a north/south passageway. There are stairs -leading down from here. There is also a door leading west." - "North end of cave passage" ;32 - ) - ( -"You are at the south end of a north/south passageway. There is a hole -in the floor here, into which you could probably fit." - "South end of cave passage" ;33 - ) - ( -"You are in what appears to be a worker's bedroom. There is a queen- -sized bed in the middle of the room, and a painting hanging on the -wall. A door leads to another room to the south, and stairways -lead up and down." - "Bedroom" ;34 - ) - ( -"You are in a bathroom built for workers in the cave. There is a -urinal hanging on the wall, and some exposed pipes on the opposite -wall where a sink used to be. To the north is a bedroom." - "Bathroom" ;35 - ) - ( -"This is a marker for the urinal. User will not see this, but it -is a room that can contain objects." - "Urinal" ;36 - ) - ( -"You are at the northeast end of a northeast/southwest passageway. -Stairs lead up out of sight." - "Ne end of ne/sw cave passage" ;37 - ) - ( -"You are at the junction of northeast/southwest and east/west passages." - "Ne/sw-e/w junction" ;38 - ) - ( -"You are at the southwest end of a northeast/southwest passageway." - "Sw end of ne/sw cave passage" ;39 - ) - ( -"You are at the east end of an e/w passage. There are stairs leading up -to a room above." - "East end of e/w cave passage" ;40 - ) - ( -"You are at the west end of an e/w passage. There is a hole on the ground -which leads down out of sight." - "West end of e/w cave passage" ;41 - ) - ( -"You are in a room which is bare, except for a horseshoe shaped boulder -in the center. Stairs lead down from here." ;42 - "Horseshoe boulder room" - ) - ( -"You are in a room which is completely empty. Doors lead out to the north -and east." - "Empty room" ;43 - ) - ( -"You are in an empty room. Interestingly enough, the stones in this -room are painted blue. Doors lead out to the east and south." ;44 - "Blue room" - ) - ( -"You are in an empty room. Interestingly enough, the stones in this -room are painted yellow. Doors lead out to the south and west." ;45 - "Yellow room" - ) - ( -"You are in an empty room. Interestingly enough, the stones in this room -are painted red. Doors lead out to the west and north." - "Red room" ;46 - ) - ( -"You are in the middle of a long north/south hallway." ;47 - "Long n/s hallway" - ) - ( -"You are 3/4 of the way towards the north end of a long north/south hallway." - "3/4 north" ;48 - ) - ( -"You are at the north end of a long north/south hallway. There are stairs -leading upwards." - "North end of long hallway" ;49 - ) - ( -"You are 3/4 of the way towards the south end of a long north/south hallway." - "3/4 south" ;50 - ) - ( -"You are at the south end of a long north/south hallway. There is a hole -to the south." - "South end of long hallway" ;51 - ) - ( -"You are at a landing in a stairwell which continues up and down." - "Stair landing" ;52 - ) - ( -"You are at the continuation of an up/down staircase." - "Up/down staircase" ;53 - ) - ( -"You are at the top of a staircase leading down. A crawlway leads off -to the northeast." - "Top of staircase." ;54 - ) - ( -"You are in a crawlway that leads northeast or southwest." - "Ne crawlway" ;55 - ) - ( -"You are in a small crawlspace. There is a hole in the ground here, and -a small passage back to the southwest." - "Small crawlspace" ;56 - ) - ( -"You are in the Gamma Computing Center. An IBM 3090/600s is whirring -away in here. There is an ethernet cable coming out of one of the units, -and going through the ceiling. There is no console here on which you -could type." - "Gamma computing center" ;57 - ) - ( -"You are near the remains of a post office. There is a mail drop on the -face of the building, but you cannot see where it leads. A path leads -back to the east, and a road leads to the north." - "Post office" ;58 - ) - ( -"You are at the intersection of Main Street and Maple Ave. Main street -runs north and south, and Maple Ave runs east off into the distance. -If you look north and east you can see many intersections, but all of -the buildings that used to stand here are gone. Nothing remains except -street signs. -There is a road to the northwest leading to a gate that guards a building." - "Main-Maple intersection" ;59 - ) - ( -"You are at the intersection of Main Street and the west end of Oaktree Ave." - "Main-Oaktree intersection" ;60 - ) - ( -"You are at the intersection of Main Street and the west end of Vermont Ave." - "Main-Vermont intersection" ;61 - ) - ( -"You are at the north end of Main Street at the west end of Sycamore Ave." ;62 - "Main-Sycamore intersection" - ) - ( -"You are at the south end of First Street at Maple Ave." ;63 - "First-Maple intersection" - ) - ( -"You are at the intersection of First Street and Oaktree Ave." ;64 - "First-Oaktree intersection" - ) - ( -"You are at the intersection of First Street and Vermont Ave." ;65 - "First-Vermont intersection" - ) - ( -"You are at the north end of First Street at Sycamore Ave." ;66 - "First-Sycamore intersection" - ) - ( -"You are at the south end of Second Street at Maple Ave." ;67 - "Second-Maple intersection" - ) - ( -"You are at the intersection of Second Street and Oaktree Ave." ;68 - "Second-Oaktree intersection" - ) - ( -"You are at the intersection of Second Street and Vermont Ave." ;69 - "Second-Vermont intersection" - ) - ( -"You are at the north end of Second Street at Sycamore Ave." ;70 - "Second-Sycamore intersection" - ) - ( -"You are at the south end of Third Street at Maple Ave." ;71 - "Third-Maple intersection" - ) - ( -"You are at the intersection of Third Street and Oaktree Ave." ;72 - "Third-Oaktree intersection" - ) - ( -"You are at the intersection of Third Street and Vermont Ave." ;73 - "Third-Vermont intersection" - ) - ( -"You are at the north end of Third Street at Sycamore Ave." ;74 - "Third-Sycamore intersection" - ) - ( -"You are at the south end of Fourth Street at Maple Ave." ;75 - "Fourth-Maple intersection" - ) - ( -"You are at the intersection of Fourth Street and Oaktree Ave." ;76 - "Fourth-Oaktree intersection" - ) - ( -"You are at the intersection of Fourth Street and Vermont Ave." ;77 - "Fourth-Vermont intersection" - ) - ( -"You are at the north end of Fourth Street at Sycamore Ave." ;78 - "Fourth-Sycamore intersection" - ) - ( -"You are at the south end of Fifth Street at the east end of Maple Ave." ;79 - "Fifth-Maple intersection" - ) - ( -"You are at the intersection of Fifth Street and the east end of Oaktree Ave. -There is a cliff off to the east." - "Fifth-Oaktree intersection" ;80 - ) - ( -"You are at the intersection of Fifth Street and the east end of Vermont Ave." - "Fifth-Vermont intersection" ;81 - ) - ( -"You are at the north end of Fifth Street and the east end of Sycamore Ave." - "Fifth-Sycamore intersection" ;82 - ) - ( -"You are in front of the Museum of Natural History. A door leads into -the building to the north, and a road leads to the southeast." - "Museum entrance" ;83 - ) - ( -"You are in the main lobby for the Museum of Natural History. In the center -of the room is the huge skeleton of a dinosaur. Doors lead out to the -south and east." - "Museum lobby" ;84 - ) - ( -"You are in the geological display. All of the objects that used to -be on display are missing. There are rooms to the east, west, and -north." - "Geological display" ;85 - ) - ( -"You are in the marine life area. The room is filled with fish tanks, -which are filled with dead fish that have apparently died due to -starvation. Doors lead out to the south and east." - "Marine life area" ;86 - ) - ( -"You are in some sort of maintenance room for the museum. There is a -switch on the wall labeled 'BL'. There are doors to the west and north." - "Maintenance room" ;87 - ) - ( -"You are in a classroom where school children were taught about natural -history. On the blackboard is written, 'No children allowed downstairs.' -There is a door to the east with an 'exit' sign on it. There is another -door to the west." - "Classroom" ;88 - ) - ( -"You are at the Vermont St. subway station. A train is sitting here waiting." - "Vermont station" ;89 - ) - ( -"You are at the Museum subway stop. A passage leads off to the north." - "Museum station" ;90 - ) - ( -"You are in a north/south tunnel." - "N/S tunnel" ;91 - ) - ( -"You are at the north end of a north/south tunnel. Stairs lead up and -down from here. There is a garbage disposal here." - "North end of n/s tunnel" ;92 - ) - ( -"You are at the top of some stairs near the subway station. There is -a door to the west." - "Top of subway stairs" ;93 - ) - ( -"You are at the bottom of some stairs near the subway station. There is -a room to the northeast." - "Bottom of subway stairs" ;94 - ) - ( -"You are in another computer room. There is a computer in here larger -than you have ever seen. It has no manufacturers name on it, but it -does have a sign that says: This machine's name is 'endgame'. The -exit is to the southwest. There is no console here on which you could -type." - "Endgame computer room" ;95 - ) - ( -"You are in a north/south hallway." - "Endgame n/s hallway" ;96 - ) - ( -"You have reached a question room. You must answer a question correctly in -order to get by. Use the 'answer' command to answer the question." - "Question room 1" ;97 - ) - ( -"You are in a north/south hallway." - "Endgame n/s hallway" ;98 - ) - ( -"You are in a second question room." - "Question room 2" ;99 - ) - ( -"You are in a north/south hallway." - "Endgame n/s hallway" ;100 - ) - ( -"You are in a third question room." - "Question room 3" ;101 - ) - ( -"You are in the endgame treasure room. A door leads out to the north, and -a hallway leads to the south." - "Endgame treasure room" ;102 - ) - ( -"You are in the winner's room. A door leads back to the south." - "Winner's room" ;103 - ) - ( -"You have reached a dead end. There is a PC on the floor here. Above -it is a sign that reads: - Type the 'reset' command to type on the PC. -A hole leads north." - "PC area" ;104 - ) -)) - -(setq dun-light-rooms '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 24 25 26 27 28 58 59 - 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 - 77 78 79 80 81 82 83)) - -(setq dun-verblist '((die . dun-die) (ne . dun-ne) (north . dun-n) - (south . dun-s) (east . dun-e) (west . dun-w) - (u . dun-up) (d . dun-down) (i . dun-inven) - (inventory . dun-inven) (look . dun-examine) (n . dun-n) - (s . dun-s) (e . dun-e) (w . dun-w) (se . dun-se) - (nw . dun-nw) (sw . dun-sw) (up . dun-up) - (down . dun-down) (in . dun-in) (out . dun-out) - (go . dun-go) (drop . dun-drop) (southeast . dun-se) - (southwest . dun-sw) (northeast . dun-ne) - (northwest . dun-nw) (save . dun-save-game) - (restore . dun-restore) (long . dun-long) (dig . dun-dig) - (shake . dun-shake) (wave . dun-shake) - (examine . dun-examine) (describe . dun-examine) - (climb . dun-climb) (eat . dun-eat) (put . dun-put) - (type . dun-type) (insert . dun-put) - (score . dun-score) (help . dun-help) (quit . dun-quit) - (read . dun-examine) (verbose . dun-long) - (urinate . dun-urinate) - (flush . dun-flush) (sleep . dun-sleep) (lie . dun-sleep) - (x . dun-examine) (break . dun-break) (drive . dun-drive) - (board . dun-in) (enter . dun-in) (turn . dun-turn) - (press . dun-press) (push . dun-press) (swim . dun-swim) - (on . dun-in) (off . dun-out) (chop . dun-break) - (switch . dun-press) (cut . dun-break) (exit . dun-out) - (leave . dun-out) (reset . dun-power) (flick . dun-press) - (superb . dun-superb) (answer . dun-answer) - (throw . dun-drop) (l . dun-examine) (take . dun-take) - (get . dun-take) (feed . dun-feed))) - -(setq dun-inbus nil) -(setq dun-nomail nil) -(setq dun-ignore '(the to at)) -(setq dun-mode 'moby) -(setq dun-sauna-level 0) - -(defconst north 0) -(defconst south 1) -(defconst east 2) -(defconst west 3) -(defconst northeast 4) -(defconst southeast 5) -(defconst northwest 6) -(defconst southwest 7) -(defconst up 8) -(defconst down 9) -(defconst in 10) -(defconst out 11) - -(setq dungeon-map '( -; no so ea we ne se nw sw up do in ot - ( 96 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;0 - ( -1 -1 2 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;1 - ( -1 -1 3 1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;2 - ( -1 -1 -1 2 4 6 -1 -1 -1 -1 -1 -1 ) ;3 - ( -1 -1 -1 -1 5 -1 -1 3 -1 -1 -1 -1 ) ;4 - ( -1 -1 -1 -1 255 -1 -1 4 -1 -1 255 -1 ) ;5 - ( -1 -1 -1 -1 -1 7 3 -1 -1 -1 -1 -1 ) ;6 - ( -1 -1 -1 -1 -1 255 6 27 -1 -1 -1 -1 ) ;7 - ( 255 5 9 10 -1 -1 -1 5 -1 -1 -1 5 ) ;8 - ( -1 -1 -1 8 -1 -1 -1 -1 -1 -1 -1 -1 ) ;9 - ( -1 -1 8 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;10 - ( -1 8 -1 58 -1 -1 -1 -1 -1 -1 -1 -1 ) ;11 - ( -1 -1 13 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;12 - ( 15 -1 14 12 -1 -1 -1 -1 -1 -1 -1 -1 ) ;13 - ( -1 -1 -1 13 -1 -1 -1 -1 -1 -1 -1 -1 ) ;14 - ( -1 13 16 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;15 - ( -1 -1 -1 15 -1 -1 -1 -1 -1 17 16 -1 ) ;16 - ( -1 -1 17 17 17 17 255 17 255 17 -1 -1 ) ;17 - ( 18 18 18 18 18 -1 18 18 19 18 -1 -1 ) ;18 - ( -1 18 18 19 19 20 19 19 -1 18 -1 -1 ) ;19 - ( -1 -1 -1 18 -1 -1 -1 -1 -1 21 -1 -1 ) ;20 - ( -1 -1 -1 -1 -1 20 22 -1 -1 -1 -1 -1 ) ;21 - ( 18 18 18 18 16 18 23 18 18 18 18 18 ) ;22 - ( -1 255 -1 -1 -1 19 -1 -1 -1 -1 -1 -1 ) ;23 - ( 23 25 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;24 - ( 24 255 -1 -1 -1 -1 -1 -1 -1 -1 255 -1 ) ;25 - (255 28 -1 -1 -1 -1 -1 -1 -1 -1 255 -1 ) ;26 - ( -1 -1 -1 -1 7 -1 -1 -1 -1 -1 -1 -1 ) ;27 - ( 26 255 -1 -1 -1 -1 -1 -1 -1 -1 255 -1 ) ;28 - ( -1 -1 30 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;29 - ( -1 -1 31 29 -1 -1 -1 -1 -1 -1 -1 -1 ) ;30 - ( 32 33 -1 30 -1 -1 -1 -1 -1 -1 -1 -1 ) ;31 - ( -1 31 -1 255 -1 -1 -1 -1 -1 34 -1 -1 ) ;32 - ( 31 -1 -1 -1 -1 -1 -1 -1 -1 35 -1 -1 ) ;33 - ( -1 35 -1 -1 -1 -1 -1 -1 32 37 -1 -1 ) ;34 - ( 34 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;35 - ( -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;36 - ( -1 -1 -1 -1 -1 -1 -1 38 34 -1 -1 -1 ) ;37 - ( -1 -1 40 41 37 -1 -1 39 -1 -1 -1 -1 ) ;38 - ( -1 -1 -1 -1 38 -1 -1 -1 -1 -1 -1 -1 ) ;39 - ( -1 -1 -1 38 -1 -1 -1 -1 42 -1 -1 -1 ) ;40 - ( -1 -1 38 -1 -1 -1 -1 -1 -1 43 -1 -1 ) ;41 - ( -1 -1 -1 -1 -1 -1 -1 -1 -1 40 -1 -1 ) ;42 - ( 44 -1 46 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;43 - ( -1 43 45 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;44 - ( -1 46 -1 44 -1 -1 -1 -1 -1 -1 -1 -1 ) ;45 - ( 45 -1 -1 43 -1 -1 -1 -1 -1 255 -1 -1 ) ;46 - ( 48 50 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;47 - ( 49 47 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;48 - ( -1 48 -1 -1 -1 -1 -1 -1 52 -1 -1 -1 ) ;49 - ( 47 51 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;50 - ( 50 104 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;51 - ( -1 -1 -1 -1 -1 -1 -1 -1 53 49 -1 -1 ) ;52 - ( -1 -1 -1 -1 -1 -1 -1 -1 54 52 -1 -1 ) ;53 - ( -1 -1 -1 -1 55 -1 -1 -1 -1 53 -1 -1 ) ;54 - ( -1 -1 -1 -1 56 -1 -1 54 -1 -1 -1 54 ) ;55 - ( -1 -1 -1 -1 -1 -1 -1 55 -1 31 -1 -1 ) ;56 - ( -1 -1 32 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;57 - ( 59 -1 11 -1 -1 -1 -1 -1 -1 -1 255 255) ;58 - ( 60 58 63 -1 -1 -1 255 -1 -1 -1 255 255) ;59 - ( 61 59 64 -1 -1 -1 -1 -1 -1 -1 255 255) ;60 - ( 62 60 65 -1 -1 -1 -1 -1 -1 -1 255 255) ;61 - ( -1 61 66 -1 -1 -1 -1 -1 -1 -1 255 255) ;62 - ( 64 -1 67 59 -1 -1 -1 -1 -1 -1 255 255) ;63 - ( 65 63 68 60 -1 -1 -1 -1 -1 -1 255 255) ;64 - ( 66 64 69 61 -1 -1 -1 -1 -1 -1 255 255) ;65 - ( -1 65 70 62 -1 -1 -1 -1 -1 -1 255 255) ;66 - ( 68 -1 71 63 -1 -1 -1 -1 -1 -1 255 255) ;67 - ( 69 67 72 64 -1 -1 -1 -1 -1 -1 255 255) ;68 - ( 70 68 73 65 -1 -1 -1 -1 -1 -1 255 255) ;69 - ( -1 69 74 66 -1 -1 -1 -1 -1 -1 255 255) ;70 - ( 72 -1 75 67 -1 -1 -1 -1 -1 -1 255 255) ;71 - ( 73 71 76 68 -1 -1 -1 -1 -1 -1 255 255) ;72 - ( 74 72 77 69 -1 -1 -1 -1 -1 -1 255 255) ;73 - ( -1 73 78 70 -1 -1 -1 -1 -1 -1 255 255) ;74 - ( 76 -1 79 71 -1 -1 -1 -1 -1 -1 255 255) ;75 - ( 77 75 80 72 -1 -1 -1 -1 -1 -1 255 255) ;76 - ( 78 76 81 73 -1 -1 -1 -1 -1 -1 255 255) ;77 - ( -1 77 82 74 -1 -1 -1 -1 -1 -1 255 255) ;78 - ( 80 -1 -1 75 -1 -1 -1 -1 -1 -1 255 255) ;79 - ( 81 79 255 76 -1 -1 -1 -1 -1 -1 255 255) ;80 - ( 82 80 -1 77 -1 -1 -1 -1 -1 -1 255 255) ;81 - ( -1 81 -1 78 -1 -1 -1 -1 -1 -1 255 255) ;82 - ( 84 -1 -1 -1 -1 59 -1 -1 -1 -1 255 255) ;83 - ( -1 83 85 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;84 - ( 86 -1 87 84 -1 -1 -1 -1 -1 -1 -1 -1 ) ;85 - ( -1 85 88 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;86 - ( 88 -1 -1 85 -1 -1 -1 -1 -1 -1 -1 -1 ) ;87 - ( -1 87 255 86 -1 -1 -1 -1 -1 -1 -1 -1 ) ;88 - ( -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 255 -1 ) ;89 - ( 91 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;90 - ( 92 90 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;91 - ( -1 91 -1 -1 -1 -1 -1 -1 93 94 -1 -1 ) ;92 - ( -1 -1 -1 88 -1 -1 -1 -1 -1 92 -1 -1 ) ;93 - ( -1 -1 -1 -1 95 -1 -1 -1 92 -1 -1 -1 ) ;94 - ( -1 -1 -1 -1 -1 -1 -1 94 -1 -1 -1 -1 ) ;95 - ( 97 0 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;96 - ( -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;97 - ( 99 97 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;98 - ( -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;99 - ( 101 99 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;100 - ( -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;101 - ( 103 101 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;102 - ( -1 102 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;103 - ( 51 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;104 - ) -; no so ea we ne se nw sw up do in ot -) - - -;;; How the user references *all* objects, permanent and regular. -(setq dun-objnames '( - (shovel . 0) - (lamp . 1) - (cpu . 2) (board . 2) (card . 2) - (food . 3) - (key . 4) - (paper . 5) - (rms . 6) (statue . 6) (statuette . 6) (stallman . 6) - (diamond . 7) - (weight . 8) - (life . 9) (preserver . 9) - (bracelet . 10) (emerald . 10) - (gold . 11) - (platinum . 12) - (towel . 13) (beach . 13) - (axe . 14) - (silver . 15) - (license . 16) - (coins . 17) - (egg . 18) - (jar . 19) - (bone . 20) - (acid . 21) (nitric . 21) - (glycerine . 22) - (ruby . 23) - (amethyst . 24) - (mona . 25) - (bill . 26) - (floppy . 27) (disk . 27) - - (boulder . -1) - (tree . -2) (trees . -2) (palm . -2) - (bear . -3) - (bin . -4) (bins . -4) - (cabinet . -5) (computer . -5) (vax . -5) (ibm . -5) - (protoplasm . -6) - (dial . -7) - (button . -8) - (chute . -9) - (painting . -10) - (bed . -11) - (urinal . -12) - (URINE . -13) - (pipes . -14) (pipe . -14) - (box . -15) (slit . -15) - (cable . -16) (ethernet . -16) - (mail . -17) (drop . -17) - (bus . -18) - (gate . -19) - (cliff . -20) - (skeleton . -21) (dinosaur . -21) - (fish . -22) - (tanks . -23) - (switch . -24) - (blackboard . -25) - (disposal . -26) (garbage . -26) - (ladder . -27) - (subway . -28) (train . -28) - (pc . -29) (drive . -29) -)) - -(dolist (x dun-objnames) - (let (name) - (setq name (concat "obj-" (prin1-to-string (car x)))) - (eval (list 'defconst (intern name) (cdr x))))) - -(defconst obj-special 255) - -;;; The initial setup of what objects are in each room. -;;; Regular objects have whole numbers lower than 255. -;;; Objects that cannot be taken but might move and are -;;; described during room description are negative. -;;; Stuff that is described and might change are 255, and are -;;; handled specially by 'dun-describe-room. - -(setq dun-room-objects (list nil - - (list obj-shovel) ;; treasure-room - (list obj-boulder) ;; dead-end - nil nil nil - (list obj-food) ;; se-nw-road - (list obj-bear) ;; bear-hangout - nil nil - (list obj-special) ;; computer-room - (list obj-lamp obj-license obj-silver);; meadow - nil nil - (list obj-special) ;; sauna - nil - (list obj-weight obj-life) ;; weight-room - nil nil - (list obj-rms obj-floppy) ;; thirsty-maze - nil nil nil nil nil nil nil - (list obj-emerald) ;; hidden-area - nil - (list obj-gold) ;; misty-room - nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil - (list obj-towel obj-special) ;; red-room - nil nil nil nil nil - (list obj-box) ;; stair-landing - nil nil nil - (list obj-axe) ;; smal-crawlspace - nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil - nil nil nil nil nil - (list obj-special) ;; fourth-vermont-intersection - nil nil - (list obj-coins) ;; fifth-oaktree-intersection - nil - (list obj-bus) ;; fifth-sycamore-intersection - nil - (list obj-bone) ;; museum-lobby - nil - (list obj-jar obj-special obj-ruby) ;; marine-life-area - (list obj-nitric) ;; maintenance-room - (list obj-glycerine) ;; classroom - nil nil nil nil nil - (list obj-amethyst) ;; bottom-of-subway-stairs - nil nil - (list obj-special) ;; question-room-1 - nil - (list obj-special) ;; question-room-2 - nil - (list obj-special) ;; question-room-three - nil - (list obj-mona) ;; winner's-room -nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil -nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil -nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil -nil)) - -;;; These are objects in a room that are only described in the -;;; room description. They are permanent. - -(setq dun-room-silents (list nil - (list obj-tree) ;; dead-end - (list obj-tree) ;; e-w-dirt-road - nil nil nil nil nil nil - (list obj-bin) ;; mailroom - (list obj-computer) ;; computer-room - nil nil nil - (list obj-dial) ;; sauna - nil - (list obj-ladder) ;; weight-room - (list obj-button obj-ladder) ;; maze-button-room - nil nil nil - nil nil nil nil nil nil nil - (list obj-chute) ;; cave-entrance - nil nil nil nil nil - (list obj-painting obj-bed) ;; bedroom - (list obj-urinal obj-pipes) ;; bathroom - nil nil nil nil nil nil - (list obj-boulder) ;; horseshoe-boulder-room - nil nil nil nil nil nil nil nil nil nil nil nil nil nil - (list obj-computer obj-cable) ;; gamma-computing-center - (list obj-mail) ;; post-office - (list obj-gate) ;; main-maple-intersection - nil nil nil nil nil nil nil nil nil nil nil nil nil - nil nil nil nil nil nil nil - (list obj-cliff) ;; fifth-oaktree-intersection - nil nil nil - (list obj-dinosaur) ;; museum-lobby - nil - (list obj-fish obj-tanks) ;; marine-life-area - (list obj-switch) ;; maintenance-room - (list obj-blackboard) ;; classroom - (list obj-train) ;; vermont-station - nil nil - (list obj-disposal) ;; north-end-of-n-s-tunnel - nil nil - (list obj-computer) ;; endgame-computer-room - nil nil nil nil nil nil nil nil - (list obj-pc) ;; pc-area - nil nil nil nil nil nil -)) -(setq dun-inventory '(1)) - -;;; Descriptions of objects, as they appear in the room description, and -;;; the inventory. - -(setq dun-objects '( - ("There is a shovel here." "A shovel") ;0 - ("There is a lamp nearby." "A lamp") ;1 - ("There is a CPU card here." "A computer board") ;2 - ("There is some food here." "Some food") ;3 - ("There is a shiny brass key here." "A brass key") ;4 - ("There is a slip of paper here." "A slip of paper") ;5 - ("There is a wax statuette of Richard Stallman here." ;6 - "An RMS statuette") - ("There is a shimmering diamond here." "A diamond") ;7 - ("There is a 10 pound weight here." "A weight") ;8 - ("There is a life preserver here." "A life preserver");9 - ("There is an emerald bracelet here." "A bracelet") ;10 - ("There is a gold bar here." "A gold bar") ;11 - ("There is a platinum bar here." "A platinum bar") ;12 - ("There is a beach towel on the ground here." "A beach towel") - ("There is an axe here." "An axe") ;14 - ("There is a silver bar here." "A silver bar") ;15 - ("There is a bus driver's license here." "A license") ;16 - ("There are some valuable coins here." "Some valuable coins") - ("There is a jewel-encrusted egg here." "A valuable egg") ;18 - ("There is a glass jar here." "A glass jar") ;19 - ("There is a dinosaur bone here." "A bone") ;20 - ("There is a packet of nitric acid here." "Some nitric acid") - ("There is a packet of glycerine here." "Some glycerine") ;22 - ("There is a valuable ruby here." "A ruby") ;23 - ("There is a valuable amethyst here." "An amethyst") ;24 - ("The Mona Lisa is here." "The Mona Lisa") ;25 - ("There is a 100 dollar bill here." "A $100 bill") ;26 - ("There is a floppy disk here." "A floppy disk") ;27 - ) -) - -;;; Weight of objects - -(setq dun-object-lbs - '(2 1 1 1 1 0 2 2 10 3 1 1 1 0 1 1 0 1 1 1 1 0 0 2 2 1 0 0)) -(setq dun-object-pts - '(0 0 0 0 0 0 0 10 0 0 10 10 10 0 0 10 0 10 10 0 0 0 0 10 10 10 10 0)) - - -;;; Unix representation of objects. -(setq dun-objfiles '( - "shovel.o" "lamp.o" "cpu.o" "food.o" "key.o" "paper.o" - "rms.o" "diamond.o" "weight.o" "preserver.o" "bracelet.o" - "gold.o" "platinum.o" "towel.o" "axe.o" "silver.o" "license.o" - "coins.o" "egg.o" "jar.o" "bone.o" "nitric.o" "glycerine.o" - "ruby.o" "amethyst.o" - )) - -;;; These are the descriptions for the negative numbered objects from -;;; dun-room-objects - -(setq dun-perm-objects '( - nil - ("There is a large boulder here.") - nil - ("There is a ferocious bear here!") - nil - nil - ("There is a worthless pile of protoplasm here.") - nil - nil - nil - nil - nil - nil - ("There is a strange smell in this room.") - nil - ( -"There is a box with a slit in it, bolted to the wall here." - ) - nil - nil - ("There is a bus here.") - nil - nil - nil -)) - - -;;; These are the descriptions the user gets when regular objects are -;;; examined. - -(setq dun-physobj-desc '( -"It is a normal shovel with a price tag attached that says $19.99." -"The lamp is hand-crafted by Geppetto." -"The CPU board has a VAX chip on it. It seems to have -2 Megabytes of RAM onboard." -"It looks like some kind of meat. Smells pretty bad." -nil -"The paper says: Don't forget to type 'help' for help. Also, remember -this word: 'worms'" -"The statuette is of the likeness of Richard Stallman, the author of the -famous EMACS editor. You notice that he is not wearing any shoes." -nil -"You observe that the weight is heavy." -"It says S. S. Minnow." -nil -nil -nil -"It has a picture of snoopy on it." -nil -nil -"It has your picture on it!" -"They are old coins from the 19th century." -"It is a valuable Fabrege egg." -"It is a a plain glass jar." -nil -nil -nil -nil -nil - ) -) - -;;; These are the descriptions the user gets when non-regular objects -;;; are examined. - -(setq dun-permobj-desc '( - nil -"It is just a boulder. It cannot be moved." -"They are palm trees with a bountiful supply of coconuts in them." -"It looks like a grizzly to me." -"All of the bins are empty. Looking closely you can see that there -are names written at the bottom of each bin, but most of them are -faded away so that you cannot read them. You can only make out three -names: - Jeffrey Collier - Robert Toukmond - Thomas Stock -" - nil -"It is just a garbled mess." -"The dial points to a temperature scale which has long since faded away." -nil -nil -"It is a velvet painting of Elvis Presly. It seems to be nailed to the -wall, and you cannot move it." -"It is a queen sized bed, with a very firm mattress." -"The urinal is very clean compared with everything else in the cave. There -isn't even any rust. Upon close examination you realize that the drain at the -bottom is missing, and there is just a large hole leading down the -pipes into nowhere. The hole is too small for a person to fit in. The -flush handle is so clean that you can see your reflection in it." -nil -nil -"The box has a slit in the top of it, and on it, in sloppy handwriting, is -written: 'For key upgrade, put key in here.'" -nil -"It says 'express mail' on it." -"It is a 35 passenger bus with the company name 'mobytours' on it." -"It is a large metal gate that is too big to climb over." -"It is a HIGH cliff." -"Unfortunately you do not know enough about dinosaurs to tell very much about -it. It is very big, though." -"The fish look like they were once quite beautiful." -nil -nil -nil -nil -"It is a normal ladder that is permanently attached to the hole." -"It is a passenger train that is ready to go." -"It is a personal computer that has only one floppy disk drive." - ) -) - -(setq dun-diggables - (list nil nil nil (list obj-cpu) nil nil nil nil nil nil nil - nil nil nil nil nil nil nil nil nil nil ;11-20 - nil nil nil nil nil nil nil nil nil nil ;21-30 - nil nil nil nil nil nil nil nil nil nil ;31-40 - nil (list obj-platinum) nil nil nil nil nil nil nil nil)) - -(setq dun-room-shorts nil) -(dolist (x dun-rooms) - (setq dun-room-shorts - (append dun-room-shorts (list (downcase - (dun-space-to-hyphen - (cadr x))))))) - -(setq dun-endgame-questions '( - ( -"What is your password on the machine called 'pokey'?" "robert") - ( -"What password did you use during anonymous ftp to gamma?" "foo") - ( -"Excluding the endgame, how many places are there where you can put -treasures for points?" "4" "four") - ( -"What is your login name on the 'endgame' machine?" "toukmond" -) - ( -"What is the nearest whole dollar to the price of the shovel?" "20" "twenty") - ( -"What is the name of the bus company serving the town?" "mobytours") - ( -"Give either of the two last names in the mailroom, other than your own." -"collier" "stock") - ( -"What cartoon character is on the towel?" "snoopy") - ( -"What is the last name of the author of EMACS?" "stallman") - ( -"How many megabytes of memory is on the CPU board for the Vax?" "2") - ( -"Which street in town is named after a U.S. state?" "vermont") - ( -"How many pounds did the weight weigh?" "ten" "10") - ( -"Name the STREET which runs right over the subway stop." "fourth" "4" "4th") - ( -"How many corners are there in town (excluding the one with the Post Office)?" - "24" "twentyfour" "twenty-four") - ( -"What type of bear was hiding your key?" "grizzly") - ( -"Name either of the two objects you found by digging." "cpu" "card" "vax" -"board" "platinum") - ( -"What network protocol is used between pokey and gamma?" "tcp/ip" "ip" "tcp") -)) - -(let (a) - (setq a 0) - (dolist (x dun-room-shorts) - (eval (list 'defconst (intern x) a)) - (setq a (+ a 1)))) - - - -;;;; -;;;; This section defines the UNIX emulation functions for dunnet. -;;;; - -(defun dun-unix-parse (args) - (interactive "*p") - (beginning-of-line) - (let (beg esign) - (setq beg (+ (point) 2)) - (end-of-line) - (if (and (not (= beg (point))) - (string= "$" (buffer-substring (- beg 2) (- beg 1)))) - (progn - (setq line (downcase (buffer-substring beg (point)))) - (princ line) - (if (eq (dun-parse2 nil dun-unix-verbs line) -1) - (progn - (if (setq esign (string-match "=" line)) - (dun-doassign line esign) - (dun-mprinc (car line-list)) - (dun-mprincl ": not found."))))) - (goto-char (point-max)) - (dun-mprinc "\n")) - (if (eq dungeon-mode 'unix) - (progn - (dun-fix-screen) - (dun-mprinc "$ "))))) - -(defun dun-doassign (line esign) - (if (not dun-wizard) - (let (passwd) - (dun-mprinc "Enter wizard password: ") - (setq passwd (dun-read-line)) - (if (not dun-batch-mode) - (dun-mprinc "\n")) - (if (string= passwd "moby") - (progn - (setq dun-wizard t) - (dun-doassign line esign)) - (dun-mprincl "Incorrect."))) - - (let (varname epoint afterq i value) - (setq varname (substring line 0 esign)) - (if (not (setq epoint (string-match ")" line))) - (if (string= (substring line (1+ esign) (+ esign 2)) - "\"") - (progn - (setq afterq (substring line (+ esign 2))) - (setq epoint (+ - (string-match "\"" afterq) - (+ esign 3)))) - - (if (not (setq epoint (string-match " " line))) - (setq epoint (length line)))) - (setq epoint (1+ epoint)) - (while (and - (not (= epoint (length line))) - (setq i (string-match ")" (substring line epoint)))) - (setq epoint (+ epoint i 1)))) - (setq value (substring line (1+ esign) epoint)) - (dun-eval varname value)))) - -(defun dun-eval (varname value) - (let (eval-error) - (switch-to-buffer (get-buffer-create "*dungeon-eval*")) - (erase-buffer) - (insert "(setq ") - (insert varname) - (insert " ") - (insert value) - (insert ")") - (setq eval-error nil) - (condition-case nil - (eval-current-buffer) - (error (setq eval-error t))) - (kill-buffer (current-buffer)) - (switch-to-buffer "*dungeon*") - (if eval-error - (dun-mprincl "Invalid syntax.")))) - - -(defun dun-unix-interface () - (dun-login) - (if dun-logged-in - (progn - (setq dungeon-mode 'unix) - (define-key dungeon-mode-map "\r" 'dun-unix-parse) - (dun-mprinc "$ ")))) - -(defun dun-login () - (let (tries username password) - (setq tries 4) - (while (and (not dun-logged-in) (> (setq tries (- tries 1)) 0)) - (dun-mprinc "\n\nUNIX System V, Release 2.2 (pokey)\n\nlogin: ") - (setq username (dun-read-line)) - (if (not dun-batch-mode) - (dun-mprinc "\n")) - (dun-mprinc "password: ") - (setq password (dun-read-line)) - (if (not dun-batch-mode) - (dun-mprinc "\n")) - (if (or (not (string= username "toukmond")) - (not (string= password "robert"))) - (dun-mprincl "login incorrect") - (setq dun-logged-in t) - (dun-mprincl " -Welcome to Unix\n -Please clean up your directories. The filesystem is getting full. -Our tcp/ip link to gamma is a little flaky, but seems to work. -The current version of ftp can only send files from the current -directory, and deletes them after they are sent! Be careful. - -Note: Restricted bourne shell in use.\n"))) - (setq dungeon-mode 'dungeon))) - -(defun dun-ls (args) - (if (car args) - (let (ocdpath ocdroom) - (setq ocdpath dun-cdpath) - (setq ocdroom dun-cdroom) - (if (not (eq (dun-cd args) -2)) - (dun-ls nil)) - (setq dun-cdpath ocdpath) - (setq dun-cdroom ocdroom)) - (if (= dun-cdroom -10) - (dun-ls-inven)) - (if (= dun-cdroom -2) - (dun-ls-rooms)) - (if (= dun-cdroom -3) - (dun-ls-root)) - (if (= dun-cdroom -4) - (dun-ls-usr)) - (if (> dun-cdroom 0) - (dun-ls-room)))) - -(defun dun-ls-root () - (dun-mprincl "total 4 -drwxr-xr-x 3 root staff 512 Jan 1 1970 . -drwxr-xr-x 3 root staff 2048 Jan 1 1970 .. -drwxr-xr-x 3 root staff 2048 Jan 1 1970 usr -drwxr-xr-x 3 root staff 2048 Jan 1 1970 rooms")) - -(defun dun-ls-usr () - (dun-mprincl "total 4 -drwxr-xr-x 3 root staff 512 Jan 1 1970 . -drwxr-xr-x 3 root staff 2048 Jan 1 1970 .. -drwxr-xr-x 3 toukmond restricted 512 Jan 1 1970 toukmond")) - -(defun dun-ls-rooms () - (dun-mprincl "total 16 -drwxr-xr-x 3 root staff 512 Jan 1 1970 . -drwxr-xr-x 3 root staff 2048 Jan 1 1970 ..") - (dolist (x dun-visited) - (dun-mprinc -"drwxr-xr-x 3 root staff 512 Jan 1 1970 ") - (dun-mprincl (nth x dun-room-shorts)))) - -(defun dun-ls-room () - (dun-mprincl "total 4 -drwxr-xr-x 3 root staff 512 Jan 1 1970 . -drwxr-xr-x 3 root staff 2048 Jan 1 1970 .. --rwxr-xr-x 3 root staff 2048 Jan 1 1970 description") - (dolist (x (nth dun-cdroom dun-room-objects)) - (if (and (>= x 0) (not (= x 255))) - (progn - (dun-mprinc "-rwxr-xr-x 1 toukmond restricted 0 Jan 1 1970 ") - (dun-mprincl (nth x dun-objfiles)))))) - -(defun dun-ls-inven () - (dun-mprinc "total 467 -drwxr-xr-x 3 toukmond restricted 512 Jan 1 1970 . -drwxr-xr-x 3 root staff 2048 Jan 1 1970 ..") - (dolist (x dun-unix-verbs) - (if (not (eq (car x) 'IMPOSSIBLE)) - (progn - (dun-mprinc" --rwxr-xr-x 1 toukmond restricted 10423 Jan 1 1970 ") - (dun-mprinc (car x))))) - (dun-mprinc "\n") - (if (not dun-uncompressed) - (dun-mprincl -"-rwxr-xr-x 1 toukmond restricted 0 Jan 1 1970 paper.o.Z")) - (dolist (x dun-inventory) - (dun-mprinc -"-rwxr-xr-x 1 toukmond restricted 0 Jan 1 1970 ") - (dun-mprincl (nth x dun-objfiles)))) - -(defun dun-echo (args) - (let (nomore var) - (setq nomore nil) - (dolist (x args) - (if (not nomore) - (progn - (if (not (string= (substring x 0 1) "$")) - (progn - (dun-mprinc x) - (dun-mprinc " ")) - (setq var (intern (substring x 1))) - (if (not (boundp var)) - (dun-mprinc " ") - (if (member var dun-restricted) - (progn - (dun-mprinc var) - (dun-mprinc ": Permission denied") - (setq nomore t)) - (eval (list 'dun-mprinc var)) - (dun-mprinc " "))))))) - (dun-mprinc "\n"))) - - -(defun dun-ftp (args) - (let (host username passwd ident newlist) - (if (not (car args)) - (dun-mprincl "ftp: hostname required on command line.") - (setq host (intern (car args))) - (if (not (member host '(gamma dun-endgame))) - (dun-mprincl "ftp: Unknown host.") - (if (eq host 'dun-endgame) - (dun-mprincl "ftp: connection to endgame not allowed") - (if (not dun-ethernet) - (dun-mprincl "ftp: host not responding.") - (dun-mprincl "Connected to gamma. FTP ver 0.9 00:00:00 01/01/70") - (dun-mprinc "Username: ") - (setq username (dun-read-line)) - (if (string= username "toukmond") - (if dun-batch-mode - (dun-mprincl "toukmond ftp access not allowed.") - (dun-mprincl "\ntoukmond ftp access not allowed.")) - (if (string= username "anonymous") - (if dun-batch-mode - (dun-mprincl - "Guest login okay, send your user ident as password.") - (dun-mprincl - "\nGuest login okay, send your user ident as password.")) - (if dun-batch-mode - (dun-mprinc "Password required for ") - (dun-mprinc "\nPassword required for ")) - (dun-mprincl username)) - (dun-mprinc "Password: ") - (setq ident (dun-read-line)) - (if (not (string= username "anonymous")) - (if dun-batch-mode - (dun-mprincl "Login failed.") - (dun-mprincl "\nLogin failed.")) - (if dun-batch-mode - (dun-mprincl - "Guest login okay, user access restrictions apply.") - (dun-mprincl - "\nGuest login okay, user access restrictions apply.")) - (dun-ftp-commands) - (setq newlist -'("What password did you use during anonymous ftp to gamma?")) - (setq newlist (append newlist (list ident))) - (rplaca (nthcdr 1 dun-endgame-questions) newlist))))))))) - -(defun dun-ftp-commands () - (setq dun-exitf nil) - (let (line) - (while (not dun-exitf) - (dun-mprinc "ftp> ") - (setq line (dun-read-line)) - (if - (eq - (dun-parse2 nil - '((type . dun-ftptype) (binary . dun-bin) (bin . dun-bin) - (send . dun-send) (put . dun-send) (quit . dun-ftpquit) - (help . dun-ftphelp)(ascii . dun-fascii) - ) line) - -1) - (dun-mprincl "No such command. Try help."))) - (setq dun-ftptype 'ascii))) - -(defun dun-ftptype (args) - (if (not (car args)) - (dun-mprincl "Usage: type [binary | ascii]") - (setq args (intern (car args))) - (if (eq args 'binary) - (dun-bin nil) - (if (eq args 'ascii) - (dun-fascii 'nil) - (dun-mprincl "Unknown type."))))) - -(defun dun-bin (args) - (dun-mprincl "Type set to binary.") - (setq dun-ftptype 'binary)) - -(defun dun-fascii (args) - (dun-mprincl "Type set to ascii.") - (setq dun-ftptype 'ascii)) - -(defun dun-ftpquit (args) - (setq dun-exitf t)) - -(defun dun-send (args) - (if (not (car args)) - (dun-mprincl "Usage: send <filename>") - (setq args (car args)) - (let (counter foo) - (setq foo nil) - (setq counter 0) - -;;; User can send commands! Stupid user. - - - (if (assq (intern args) dun-unix-verbs) - (progn - (rplaca (assq (intern args) dun-unix-verbs) 'IMPOSSIBLE) - (dun-mprinc "Sending ") - (dun-mprinc dun-ftptype) - (dun-mprinc " file for ") - (dun-mprincl args) - (dun-mprincl "Transfer complete.")) - - (dolist (x dun-objfiles) - (if (string= args x) - (progn - (if (not (member counter dun-inventory)) - (progn - (dun-mprincl "No such file.") - (setq foo t)) - (dun-mprinc "Sending ") - (dun-mprinc dun-ftptype) - (dun-mprinc " file for ") - (dun-mprinc (downcase (cadr (nth counter dun-objects)))) - (dun-mprincl ", (0 bytes)") - (if (not (eq dun-ftptype 'binary)) - (progn - (if (not (member obj-protoplasm - (nth receiving-room - dun-room-objects))) - (dun-replace dun-room-objects receiving-room - (append (nth receiving-room - dun-room-objects) - (list obj-protoplasm)))) - (dun-remove-obj-from-inven counter)) - (dun-remove-obj-from-inven counter) - (dun-replace dun-room-objects receiving-room - (append (nth receiving-room dun-room-objects) - (list counter)))) - (setq foo t) - (dun-mprincl "Transfer complete.")))) - (setq counter (+ 1 counter))) - (if (not foo) - (dun-mprincl "No such file.")))))) - -(defun dun-ftphelp (args) - (dun-mprincl - "Possible commands are:\nsend quit type ascii binary help")) - -(defun dun-uexit (args) - (setq dungeon-mode 'dungeon) - (dun-mprincl "\nYou step back from the console.") - (define-key dungeon-mode-map "\r" 'dun-parse) - (if (not dun-batch-mode) - (dun-messages))) - -(defun dun-pwd (args) - (dun-mprincl dun-cdpath)) - -(defun dun-uncompress (args) - (if (not (car args)) - (dun-mprincl "Usage: uncompress <filename>") - (setq args (car args)) - (if (or dun-uncompressed - (and (not (string= args "paper.o")) - (not (string= args "paper.o.z")))) - (dun-mprincl "Uncompress command failed.") - (setq dun-uncompressed t) - (setq dun-inventory (append dun-inventory (list obj-paper)))))) - -(defun dun-rlogin (args) - (let (passwd) - (if (not (car args)) - (dun-mprincl "Usage: rlogin <hostname>") - (setq args (car args)) - (if (string= args "endgame") - (dun-rlogin-endgame) - (if (not (string= args "gamma")) - (dun-mprincl "No such host.") - (if (not dun-ethernet) - (dun-mprincl "Host not responding.") - (dun-mprinc "Password: ") - (setq passwd (dun-read-line)) - (if (not (string= passwd "worms")) - (dun-mprincl "\nlogin incorrect") - (dun-mprinc -"\nYou begin to feel strange for a moment, and you lose your items." -) - (dun-replace dun-room-objects computer-room - (append (nth computer-room dun-room-objects) - dun-inventory)) - (setq dun-inventory nil) - (setq dun-current-room receiving-room) - (dun-uexit nil)))))))) - -(defun dun-cd (args) - (let (tcdpath tcdroom path-elements room-check) - (if (not (car args)) - (dun-mprincl "Usage: cd <path>") - (setq tcdpath dun-cdpath) - (setq tcdroom dun-cdroom) - (setq dun-badcd nil) - (condition-case nil - (setq path-elements (dun-get-path (car args) nil)) - (error (dun-mprincl "Invalid path.") - (setq dun-badcd t))) - (dolist (pe path-elements) - (unless dun-badcd - (if (not (string= pe ".")) - (if (string= pe "..") - (progn - (if (> tcdroom 0) ;In a room - (progn - (setq tcdpath "/rooms") - (setq tcdroom -2)) - ;In /rooms,/usr,root - (if (or - (= tcdroom -2) (= tcdroom -4) - (= tcdroom -3)) - (progn - (setq tcdpath "/") - (setq tcdroom -3)) - (if (= tcdroom -10) ;In /usr/toukmond - (progn - (setq tcdpath "/usr") - (setq tcdroom -4)))))) - (if (string= pe "/") - (progn - (setq tcdpath "/") - (setq tcdroom -3)) - (if (= tcdroom -4) - (if (string= pe "toukmond") - (progn - (setq tcdpath "/usr/toukmond") - (setq tcdroom -10)) - (dun-nosuchdir)) - (if (= tcdroom -10) - (dun-nosuchdir) - (if (> tcdroom 0) - (dun-nosuchdir) - (if (= tcdroom -3) - (progn - (if (string= pe "rooms") - (progn - (setq tcdpath "/rooms") - (setq tcdroom -2)) - (if (string= pe "usr") - (progn - (setq tcdpath "/usr") - (setq tcdroom -4)) - (dun-nosuchdir)))) - (if (= tcdroom -2) - (progn - (dolist (x dun-visited) - (setq room-check - (nth x - dun-room-shorts)) - (if (string= room-check pe) - (progn - (setq tcdpath - (concat "/rooms/" room-check)) - (setq tcdroom x)))) - (if (= tcdroom -2) - (dun-nosuchdir))))))))))))) - (if (not dun-badcd) - (progn - (setq dun-cdpath tcdpath) - (setq dun-cdroom tcdroom) - 0) - -2)))) - -(defun dun-nosuchdir () - (dun-mprincl "No such directory.") - (setq dun-badcd t)) - -(defun dun-cat (args) - (let (doto checklist) - (if (not (setq args (car args))) - (dun-mprincl "Usage: cat <ascii-file-name>") - (if (string-match "/" args) - (dun-mprincl "cat: only files in current directory allowed.") - (if (and (> dun-cdroom 0) (string= args "description")) - (dun-mprincl (car (nth dun-cdroom dun-rooms))) - (if (setq doto (string-match "\\.o" args)) - (progn - (if (= dun-cdroom -10) - (setq checklist dun-inventory) - (setq checklist (nth dun-cdroom dun-room-objects))) - (if (not (member (cdr - (assq (intern - (substring args 0 doto)) - dun-objnames)) - checklist)) - (dun-mprincl "File not found.") - (dun-mprincl "Ascii files only."))) - (if (assq (intern args) dun-unix-verbs) - (dun-mprincl "Ascii files only.") - (dun-mprincl "File not found.")))))))) - -(defun dun-zippy (args) - (dun-mprincl (yow))) - -(defun dun-rlogin-endgame () - (if (not (= (dun-score nil) 90)) - (dun-mprincl - "You have not achieved enough points to connect to endgame.") - (dun-mprincl"\nWelcome to the endgame. You are a truly noble adventurer.") - (setq dun-current-room treasure-room) - (setq dun-endgame t) - (dun-replace dun-room-objects endgame-treasure-room (list obj-bill)) - (dun-uexit nil))) - - -(random t) -(setq tloc (+ 60 (random 18))) -(dun-replace dun-room-objects tloc - (append (nth tloc dun-room-objects) (list 18))) - -(setq tcomb (+ 100 (random 899))) -(setq dun-combination (prin1-to-string tcomb)) - -;;;; -;;;; This section defines the DOS emulation functions for dunnet -;;;; - -(defun dun-dos-parse (args) - (interactive "*p") - (beginning-of-line) - (let (beg) - (setq beg (+ (point) 3)) - (end-of-line) - (if (not (= beg (point))) - (let (line) - (setq line (downcase (buffer-substring beg (point)))) - (princ line) - (if (eq (dun-parse2 nil dun-dos-verbs line) -1) - (progn - (sleep-for 1) - (dun-mprincl "Bad command or file name")))) - (goto-char (point-max)) - (dun-mprinc "\n")) - (if (eq dungeon-mode 'dos) - (progn - (dun-fix-screen) - (dun-dos-prompt))))) - -(defun dun-dos-interface () - (dun-dos-boot-msg) - (setq dungeon-mode 'dos) - (define-key dungeon-mode-map "\r" 'dun-dos-parse) - (dun-dos-prompt)) - -(defun dun-dos-type (args) - (sleep-for 2) - (if (setq args (car args)) - (if (string= args "foo.txt") - (dun-dos-show-combination) - (if (string= args "command.com") - (dun-mprincl "Cannot type binary files") - (dun-mprinc "File not found - ") - (dun-mprincl (upcase args)))) - (dun-mprincl "Must supply file name"))) - -(defun dun-dos-invd (args) - (sleep-for 1) - (dun-mprincl "Invalid drive specification")) - -(defun dun-dos-dir (args) - (sleep-for 1) - (if (or (not (setq args (car args))) (string= args "\\")) - (dun-mprincl " - Volume in drive A is FOO - Volume Serial Number is 1A16-08C9 - Directory of A:\\ - -COMMAND COM 47845 04-09-91 2:00a -FOO TXT 40 01-20-93 1:01a - 2 file(s) 47845 bytes - 1065280 bytes free -") - (dun-mprincl " - Volume in drive A is FOO - Volume Serial Number is 1A16-08C9 - Directory of A:\\ - -File not found"))) - - -(defun dun-dos-prompt () - (dun-mprinc "A> ")) - -(defun dun-dos-boot-msg () - (sleep-for 3) - (dun-mprinc "Current time is ") - (dun-mprincl (substring (current-time-string) 12 20)) - (dun-mprinc "Enter new time: ") - (dun-read-line) - (if (not dun-batch-mode) - (dun-mprinc "\n"))) - -(defun dun-dos-spawn (args) - (sleep-for 1) - (dun-mprincl "Cannot spawn subshell")) - -(defun dun-dos-exit (args) - (setq dungeon-mode 'dungeon) - (dun-mprincl "\nYou power down the machine and step back.") - (define-key dungeon-mode-map "\r" 'dun-parse) - (if (not dun-batch-mode) - (dun-messages))) - -(defun dun-dos-no-disk () - (sleep-for 3) - (dun-mprincl "Boot sector not found")) - - -(defun dun-dos-show-combination () - (sleep-for 2) - (dun-mprinc "\nThe combination is ") - (dun-mprinc dun-combination) - (dun-mprinc ".\n")) - -(defun dun-dos-nil (args)) - - -;;;; -;;;; This section defines the save and restore game functions for dunnet. -;;;; - -(defun dun-save-game (filename) - (if (not (setq filename (car filename))) - (dun-mprincl "You must supply a filename for the save.") - (if (file-exists-p filename) - (delete-file filename)) - (setq dun-numsaves (1+ dun-numsaves)) - (dun-make-save-buffer) - (dun-save-val "dun-current-room") - (dun-save-val "dun-computer") - (dun-save-val "dun-combination") - (dun-save-val "dun-visited") - (dun-save-val "dun-diggables") - (dun-save-val "dun-key-level") - (dun-save-val "dun-floppy") - (dun-save-val "dun-numsaves") - (dun-save-val "dun-numcmds") - (dun-save-val "dun-logged-in") - (dun-save-val "dungeon-mode") - (dun-save-val "dun-jar") - (dun-save-val "dun-lastdir") - (dun-save-val "dun-black") - (dun-save-val "dun-nomail") - (dun-save-val "dun-unix-verbs") - (dun-save-val "dun-hole") - (dun-save-val "dun-uncompressed") - (dun-save-val "dun-ethernet") - (dun-save-val "dun-sauna-level") - (dun-save-val "dun-room-objects") - (dun-save-val "dun-room-silents") - (dun-save-val "dun-inventory") - (dun-save-val "dun-endgame-questions") - (dun-save-val "dun-endgame") - (dun-save-val "dun-cdroom") - (dun-save-val "dun-cdpath") - (dun-save-val "dun-correct-answer") - (dun-save-val "dun-inbus") - (if (dun-compile-save-out filename) - (dun-mprincl "Error saving to file.") - (dun-do-logfile 'save nil) - (switch-to-buffer "*dungeon*") - (princ "") - (dun-mprincl "Done.")))) - -(defun dun-make-save-buffer () - (switch-to-buffer (get-buffer-create "*save-dungeon*")) - (erase-buffer)) - -(defun dun-compile-save-out (filename) - (let (ferror) - (setq ferror nil) - (condition-case nil - (dun-rot13) - (error (setq ferror t))) - (if (not ferror) - (progn - (goto-char (point-min)))) - (condition-case nil - (write-region 1 (point-max) filename nil 1) - (error (setq ferror t))) - (kill-buffer (current-buffer)) - ferror)) - - -(defun dun-save-val (varname) - (let (value) - (setq varname (intern varname)) - (setq value (eval varname)) - (dun-minsert "(setq ") - (dun-minsert varname) - (dun-minsert " ") - (if (or (listp value) - (symbolp value)) - (dun-minsert "'")) - (if (stringp value) - (dun-minsert "\"")) - (dun-minsert value) - (if (stringp value) - (dun-minsert "\"")) - (dun-minsertl ")"))) - - -(defun dun-restore (args) - (let (file) - (if (not (setq file (car args))) - (dun-mprincl "You must supply a filename.") - (if (not (dun-load-d file)) - (dun-mprincl "Could not load restore file.") - (dun-mprincl "Done.") - (setq room 0))))) - - -(defun dun-do-logfile (type how) - (let (ferror newscore) - (setq ferror nil) - (switch-to-buffer (get-buffer-create "*score*")) - (erase-buffer) - (condition-case nil - (insert-file-contents dun-log-file) - (error (setq ferror t))) - (unless ferror - (goto-char (point-max)) - (dun-minsert (current-time-string)) - (dun-minsert " ") - (dun-minsert (user-login-name)) - (dun-minsert " ") - (if (eq type 'save) - (dun-minsert "saved ") - (if (= (dun-endgame-score) 110) - (dun-minsert "won ") - (if (not how) - (dun-minsert "quit ") - (dun-minsert "killed by ") - (dun-minsert how) - (dun-minsert " ")))) - (dun-minsert "at ") - (dun-minsert (cadr (nth (abs room) dun-rooms))) - (dun-minsert ". score: ") - (if (> (dun-endgame-score) 0) - (dun-minsert (setq newscore (+ 90 (dun-endgame-score)))) - (dun-minsert (setq newscore (dun-reg-score)))) - (dun-minsert " saves: ") - (dun-minsert dun-numsaves) - (dun-minsert " commands: ") - (dun-minsert dun-numcmds) - (dun-minsert "\n") - (write-region 1 (point-max) dun-log-file nil 1)) - (kill-buffer (current-buffer)))) - - -;;;; -;;;; These are functions, and function re-definitions so that dungeon can -;;;; be run in batch mode. - - -(defun dun-batch-mprinc (arg) - (if (stringp arg) - (send-string-to-terminal arg) - (send-string-to-terminal (prin1-to-string arg)))) - - -(defun dun-batch-mprincl (arg) - (if (stringp arg) - (progn - (send-string-to-terminal arg) - (send-string-to-terminal "\n")) - (send-string-to-terminal (prin1-to-string arg)) - (send-string-to-terminal "\n"))) - -(defun dun-batch-parse (dun-ignore dun-verblist line) - (setq line-list (dun-listify-string (concat line " "))) - (dun-doverb dun-ignore dun-verblist (car line-list) (cdr line-list))) - -(defun dun-batch-parse2 (dun-ignore dun-verblist line) - (setq line-list (dun-listify-string2 (concat line " "))) - (dun-doverb dun-ignore dun-verblist (car line-list) (cdr line-list))) - -(defun dun-batch-read-line () - (read-from-minibuffer "" nil dungeon-batch-map)) - - -(defun dun-batch-loop () - (setq dun-dead nil) - (setq room 0) - (while (not dun-dead) - (if (eq dungeon-mode 'dungeon) - (progn - (if (not (= room dun-current-room)) - (progn - (dun-describe-room dun-current-room) - (setq room dun-current-room))) - (dun-mprinc ">") - (setq line (downcase (dun-read-line))) - (if (eq (dun-vparse dun-ignore dun-verblist line) -1) - (dun-mprinc "I don't understand that.\n")))))) - -(defun dun-batch-dos-interface () - (dun-dos-boot-msg) - (setq dungeon-mode 'dos) - (while (eq dungeon-mode 'dos) - (dun-dos-prompt) - (setq line (downcase (dun-read-line))) - (if (eq (dun-parse2 nil dun-dos-verbs line) -1) - (progn - (sleep-for 1) - (dun-mprincl "Bad command or file name")))) - (goto-char (point-max)) - (dun-mprinc "\n")) - -(defun dun-batch-unix-interface () - (dun-login) - (if dun-logged-in - (progn - (setq dungeon-mode 'unix) - (while (eq dungeon-mode 'unix) - (dun-mprinc "$ ") - (setq line (downcase (dun-read-line))) - (if (eq (dun-parse2 nil dun-unix-verbs line) -1) - (let (esign) - (if (setq esign (string-match "=" line)) - (dun-doassign line esign) - (dun-mprinc (car line-list)) - (dun-mprincl ": not found."))))) - (goto-char (point-max)) - (dun-mprinc "\n")))) - -(defun dungeon-nil (arg) - "noop" - (interactive "*p")) - -(defun dun-batch-dungeon () - (load "dun-batch") - (setq dun-visited '(27)) - (dun-mprinc "\n") - (dun-batch-loop)) - -(unless (not noninteractive) - (fset 'dun-mprinc 'dun-batch-mprinc) - (fset 'dun-mprincl 'dun-batch-mprincl) - (fset 'dun-vparse 'dun-batch-parse) - (fset 'dun-parse2 'dun-batch-parse2) - (fset 'dun-read-line 'dun-batch-read-line) - (fset 'dun-dos-interface 'dun-batch-dos-interface) - (fset 'dun-unix-interface 'dun-batch-unix-interface) - (dun-mprinc "\n") - (setq dun-batch-mode t) - (dun-batch-loop)) - - diff --git a/lisp/play/gomoku.el b/lisp/play/gomoku.el deleted file mode 100644 index 332d1cedd9c..00000000000 --- a/lisp/play/gomoku.el +++ /dev/null @@ -1,1182 +0,0 @@ -;;; gomoku.el --- Gomoku game between you and Emacs - -;; Copyright (C) 1988, 1994, 1996 Free Software Foundation, Inc. - -;; Author: Philippe Schnoebelen <phs@lifia.imag.fr> -;; Adapted-By: ESR, Daniel.Pfeiffer@Informatik.START.dbp.de -;; Keywords: games - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; 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 :-). - - -;; 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: -;; -;; The command "M-x gomoku" displays 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. - -;;; Code: - -;;; -;;; 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. - (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" 'backward-char) ; h - (define-key gomoku-mode-map "l" 'forward-char) ; 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 [kp-7] 'gomoku-move-nw) - (define-key gomoku-mode-map [kp-9] 'gomoku-move-ne) - (define-key gomoku-mode-map [kp-1] 'gomoku-move-sw) - (define-key gomoku-mode-map [kp-3] 'gomoku-move-se) - (define-key gomoku-mode-map [kp-4] 'backward-char) - (define-key gomoku-mode-map [kp-6] 'forward-char) - (define-key gomoku-mode-map [kp-2] 'gomoku-move-down) - (define-key gomoku-mode-map [kp-8] 'gomoku-move-up) - - (define-key gomoku-mode-map "\C-n" 'gomoku-move-down) ; C-n - (define-key gomoku-mode-map "\C-p" 'gomoku-move-up) ; C-p - - ;; Key bindings for entering Human moves. - (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 " " 'gomoku-human-plays) ; SPC - (define-key gomoku-mode-map "\C-m" 'gomoku-human-plays) ; RET - (define-key gomoku-mode-map "\C-c\C-p" 'gomoku-human-plays) ; C-c C-p - (define-key gomoku-mode-map "\C-c\C-b" 'gomoku-human-takes-back) ; C-c C-b - (define-key gomoku-mode-map "\C-c\C-r" 'gomoku-human-resigns) ; C-c C-r - (define-key gomoku-mode-map "\C-c\C-e" 'gomoku-emacs-plays) ; C-c C-e - - (define-key gomoku-mode-map [kp-enter] 'gomoku-human-plays) - (define-key gomoku-mode-map [insert] 'gomoku-human-plays) - (define-key gomoku-mode-map [down-mouse-1] 'gomoku-click) - (define-key gomoku-mode-map [drag-mouse-1] 'gomoku-click) - (define-key gomoku-mode-map [mouse-1] 'gomoku-click) - (define-key gomoku-mode-map [down-mouse-2] 'gomoku-click) - (define-key gomoku-mode-map [mouse-2] 'gomoku-mouse-play) - (define-key gomoku-mode-map [drag-mouse-2] 'gomoku-mouse-play) - - (substitute-key-definition 'previous-line 'gomoku-move-up - gomoku-mode-map (current-global-map)) - (substitute-key-definition 'next-line 'gomoku-move-down - gomoku-mode-map (current-global-map)) - (substitute-key-definition 'beginning-of-line 'gomoku-beginning-of-line - gomoku-mode-map (current-global-map)) - (substitute-key-definition 'end-of-line 'gomoku-end-of-line - gomoku-mode-map (current-global-map)) - (substitute-key-definition 'undo 'gomoku-human-takes-back - gomoku-mode-map (current-global-map)) - (substitute-key-definition 'advertised-undo 'gomoku-human-takes-back - gomoku-mode-map (current-global-map))) - -(defvar gomoku-emacs-won () - "*For making font-lock use the winner's face for the line.") - -(defvar gomoku-font-lock-O-face - (if window-system - (list (facemenu-get-face 'fg:red) 'bold)) - "*Face to use for Emacs' O.") - -(defvar gomoku-font-lock-X-face - (if window-system - (list (facemenu-get-face 'fg:green) 'bold)) - "*Face to use for your X.") - -(defvar gomoku-font-lock-keywords - '(("O" . gomoku-font-lock-O-face) - ("X" . gomoku-font-lock-X-face) - ("[-|/\\]" 0 (if gomoku-emacs-won - gomoku-font-lock-O-face - gomoku-font-lock-X-face))) - "*Font lock rules for Gomoku.") - -(put 'gomoku-mode 'front-sticky - (put 'gomoku-mode 'rear-nonsticky '(intangible))) -(put 'gomoku-mode 'intangible 1) - -(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 \\[gomoku-human-plays]. - -Other useful commands: -\\{gomoku-mode-map} -Entry to this mode calls the value of `gomoku-mode-hook' if that value -is non-nil. One interesting value is `turn-on-font-lock'." - (interactive) - (setq major-mode 'gomoku-mode - mode-name "Gomoku") - (gomoku-display-statistics) - (use-local-map gomoku-mode-map) - (make-local-variable 'font-lock-defaults) - (setq font-lock-defaults '(gomoku-font-lock-keywords t)) - (toggle-read-only t) - (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 chose values 0, 1 and 6 to denote empty, X and O squares, the -;; contents of a qtuple are 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)) - ((zerop (random (setq count (1+ count)))) - (setq best-square square - score-max score))) - (setq square (1+ square))) ; try next square - best-square)) - -;;; -;;; 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 function 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-emacs-won nil - 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-emacs-wins 0 - "Number of games Emacs won in this session.") - -(defvar gomoku-number-of-human-wins 0 - "Number of games you won 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." - (message - (cond - ((eq result 'emacs-won) - (setq gomoku-number-of-emacs-wins (1+ gomoku-number-of-emacs-wins)) - (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-human-wins) - (zerop gomoku-number-of-draws) - (> gomoku-number-of-emacs-wins 1)) - "I'm becoming tired of winning...") - ("I won."))) - ((eq result 'human-won) - (setq gomoku-number-of-human-wins (1+ gomoku-number-of-human-wins)) - (concat "OK, you won this one." - (cond - (gomoku-human-took-back - " I, for one, never take my moves back...") - (gomoku-emacs-played-first - ".. so what ?") - (" Now, let me play first just once.")))) - ((eq result 'human-resigned) - (setq gomoku-number-of-emacs-wins (1+ gomoku-number-of-emacs-wins)) - "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)) - (concat "This is a draw. " - (cond - (gomoku-human-took-back - "I, for one, never take my moves back...") - (gomoku-emacs-played-first - "Just chance, I guess.") - ("Now, let me play first just once.")))) - ((eq result 'draw-agreed) - (setq gomoku-number-of-draws (1+ gomoku-number-of-draws)) - (concat "Draw agreed. " - (cond - (gomoku-human-took-back - "I, for one, never take my moves back...") - (gomoku-emacs-played-first - "You were lucky.") - ("Now, let me play first just once.")))) - ((eq result 'crash-game) - "Sorry, I have been interrupted and cannot resume that game..."))) - (gomoku-display-statistics) - ;;(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. -;;; - -;;;###autoload -(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. -If prefix arg is given for N, M is prompted for. - -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 -\\<gomoku-mode-map>\\[gomoku-human-plays]. -Use \\[describe-mode] for more info." - (interactive (if current-prefix-arg - (list (prefix-numeric-value current-prefix-arg) - (eval (read-minibuffer "Height: "))))) - (gomoku-switch-to-window) - (cond - (gomoku-emacs-is-computing - (gomoku-crash-game)) - ((or (not gomoku-game-in-progress) - (<= gomoku-number-of-moves 2)) - (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 (eq m gomoku-saved-board-height)) - ;; Use EQ 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) - (setq gomoku-emacs-won t) ; for font-lock - (gomoku-find-filled-qtuple square 6) - (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))))))))) - -;; For small square dimensions this is approximate, since though measured in -;; pixels, event's (X . Y) is a character's top-left corner. -(defun gomoku-click (click) - "Position at the square where you click." - (interactive "e") - (and (windowp (posn-window (setq click (event-end click)))) - (numberp (posn-point click)) - (select-window (posn-window click)) - (setq click (posn-col-row click)) - (gomoku-goto-xy - (min (max (/ (+ (- (car click) - gomoku-x-offset - 1) - (window-hscroll) - gomoku-square-width - (% gomoku-square-width 2) - (/ gomoku-square-width 2)) - gomoku-square-width) - 1) - gomoku-board-width) - (min (max (/ (+ (- (cdr click) - gomoku-y-offset - 1) - (let ((inhibit-point-motion-hooks t)) - (count-lines 1 (window-start))) - gomoku-square-height - (% gomoku-square-height 2) - (/ gomoku-square-height 2)) - gomoku-square-height) - 1) - gomoku-board-height)))) - -(defun gomoku-mouse-play (click) - "Play at the square where you click." - (interactive "e") - (if (gomoku-click click) - (gomoku-human-plays))) - -(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-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 ") - (not (setq gomoku-human-refused-draw t)))) - -;;; -;;; 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-y () - "Return the board row where point is." - (let ((inhibit-point-motion-hooks t)) - (1+ (/ (- (count-lines 1 (point)) gomoku-y-offset (if (bolp) 0 1)) - gomoku-square-height)))) - -(defun gomoku-point-square () - "Return the index of the square point is on." - (let ((inhibit-point-motion-hooks t)) - (gomoku-xy-to-index (1+ (/ (- (current-column) gomoku-x-offset) - gomoku-square-width)) - (gomoku-point-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." - (let ((inhibit-point-motion-hooks t)) - (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." - (or (= value 1) - (gomoku-goto-square square)) - (let ((inhibit-read-only t) - (inhibit-point-motion-hooks t)) - (insert-and-inherit (cond ((= value 1) ?X) - ((= value 6) ?O) - (?.))) - (and window-system - (zerop value) - (put-text-property (1- (point)) (point) 'mouse-face 'highlight)) - (delete-char 1) - (backward-char 1)) - (sit-for 0)) ; Display NOW - -(defun gomoku-init-display (n m) - "Display an N by M Gomoku board." - (buffer-disable-undo (current-buffer)) - (let ((inhibit-read-only t) - (point 1) opoint - (intangible t) - (i m) j x) - ;; Try to minimize number of chars (because of text properties) - (setq tab-width - (if (zerop (% gomoku-x-offset gomoku-square-width)) - gomoku-square-width - (max (/ (+ (% gomoku-x-offset gomoku-square-width) - gomoku-square-width 1) 2) 2))) - (erase-buffer) - (newline gomoku-y-offset) - (while (progn - (setq j n - x (- gomoku-x-offset gomoku-square-width)) - (while (>= (setq j (1- j)) 0) - (insert-char ?\t (/ (- (setq x (+ x gomoku-square-width)) - (current-column)) - tab-width)) - (insert-char ? (- x (current-column))) - (if (setq intangible (not intangible)) - (put-text-property point (point) 'intangible 2)) - (and (zerop j) - (= i (- m 2)) - (progn - (while (>= i 3) - (append-to-buffer (current-buffer) opoint (point)) - (setq i (- i 2))) - (goto-char (point-max)))) - (setq point (point)) - (insert ?.) - (if window-system - (put-text-property point (point) - 'mouse-face 'highlight))) - (> (setq i (1- i)) 0)) - (if (= i (1- m)) - (setq opoint point)) - (insert-char ?\n gomoku-square-height)) - (or (eq (char-after 1) ?.) - (put-text-property 1 2 'point-entered - (lambda (x x) (if (bobp) (forward-char))))) - (or intangible - (put-text-property point (point) 'intangible 2)) - (put-text-property point (point) 'point-entered - (lambda (x x) (if (eobp) (backward-char)))) - (put-text-property (point-min) (point) 'category 'gomoku-mode)) - (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 - (format ": Won %d, lost %d%s" - gomoku-number-of-human-wins - gomoku-number-of-emacs-wins - (if (zerop gomoku-number-of-draws) - "" - (format ", drew %d" gomoku-number-of-draws)))) - (force-mode-line-update)) - -(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. - -(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." - (let ((a 0) (b 0) - (left square) (right square) - (depl (gomoku-xy-to-index dx dy))) - (while (and (> a -4) ; stretch tuple left - (= value (aref gomoku-board (setq left (- left depl))))) - (setq a (1- a))) - (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 ? - (gomoku-cross-qtuple (+ square (* a depl)) (+ square (* b depl)) - dx dy) - t)))) - -(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)) - (inhibit-read-only t) - (inhibit-point-motion-hooks t)) - ;; WARNING: this function assumes DEPL > 0 and SQUARE2 > SQUARE1 - (while (/= square1 square2) - (gomoku-goto-square square1) - (setq square1 (+ square1 depl)) - (cond - ((= dy 0) ; Horizontal - (forward-char 1) - (insert-char ?- (1- gomoku-square-width) t) - (delete-region (point) (progn - (skip-chars-forward " \t") - (point)))) - ((= dx 0) ; Vertical - (let ((n 1) - (column (current-column))) - (while (< n gomoku-square-height) - (setq n (1+ n)) - (forward-line 1) - (indent-to column) - (insert-and-inherit ?|)))) - ((= dx -1) ; 1st Diagonal - (indent-to (prog1 (- (current-column) (/ gomoku-square-width 2)) - (forward-line (/ gomoku-square-height 2)))) - (insert-and-inherit ?/)) - (t ; 2nd Diagonal - (indent-to (prog1 (+ (current-column) (/ gomoku-square-width 2)) - (forward-line (/ gomoku-square-height 2)))) - (insert-and-inherit ?\\)))))) - (sit-for 0)) ; Display NOW - -;;; -;;; CURSOR MOTION. -;;; -;; previous-line and next-line don't work right with intangible newlines -(defun gomoku-move-down () - "Move point down one row on the Gomoku board." - (interactive) - (if (< (gomoku-point-y) gomoku-board-height) - (next-line gomoku-square-height))) - -(defun gomoku-move-up () - "Move point up one row on the Gomoku board." - (interactive) - (if (> (gomoku-point-y) 1) - (previous-line gomoku-square-height))) - -(defun gomoku-move-ne () - "Move point North East on the Gomoku board." - (interactive) - (gomoku-move-up) - (forward-char)) - -(defun gomoku-move-se () - "Move point South East on the Gomoku board." - (interactive) - (gomoku-move-down) - (forward-char)) - -(defun gomoku-move-nw () - "Move point North West on the Gomoku board." - (interactive) - (gomoku-move-up) - (backward-char)) - -(defun gomoku-move-sw () - "Move point South West on the Gomoku board." - (interactive) - (gomoku-move-down) - (backward-char)) - -(defun gomoku-beginning-of-line () - "Move point to first square on the Gomoku board row." - (interactive) - (move-to-column gomoku-x-offset)) - -(defun gomoku-end-of-line () - "Move point to last square on the Gomoku board row." - (interactive) - (move-to-column (+ gomoku-x-offset - (* gomoku-square-width (1- gomoku-board-width))))) - -(provide 'gomoku) - -;;; gomoku.el ends here diff --git a/lisp/play/handwrite.el b/lisp/play/handwrite.el deleted file mode 100644 index 766ba6a02c6..00000000000 --- a/lisp/play/handwrite.el +++ /dev/null @@ -1,1376 +0,0 @@ -;;; handwrite.el --- turns your emacs buffer into a handwritten document. -;; -;; (C) Copyright 1996 Free Software Foundation, Inc. -;; -;; Author: Danny Roozendaal (danny@tvs.kun.nl) -;; Created: October 21 1996 -;; Keywords: cursive writing -;; -;; This file is part of GNU Emacs. -;; -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. -;; -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to -;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -;; -;;; Commentary: -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; The function handwrite creates PostScript output containing a -;; handwritten version of the current buffer.. -;; Other functions that may be useful are -;; -;; handwrite-10pt: sets the font size to 10 and finds corresponding -;; values for the line spacing and the number of lines -;; on a page. -;; handwrite-11pt: which is similar -;; handwrite-12pt: which is also similar -;; handwrite-13pt: which is similar, too -;; -;; handwrite-set-pagenumber: set and unset page numbering -;; -;; -;; If you are not satisfied with the type page there are a number of -;; variables you may want to set. -;; -;; -;; Installation -;; -;; type at your prompt "emacs -l handwrite.el" or put this file on your -;; Emacs-Lisp load path, add the following into your ~/.emacs startup file -;; -;; (require 'handwrite) -;; -;; "M-x handwrite" or "Write by hand" in the edit menu should work now. -;; -;; -;; I tried to make it `iso_8859_1'-friendly, but there are some exotic -;; characters missing. -;; -;; -;; Known bugs: -Page feeds do not do their work, but are ignored instead. -;; -Tabs are not always properly displayed. -;; -Handwrite may create corrupt PostScript if it encounters -;; unknown characters. -;; -;; Thanks to anyone who emailed me suggestions! -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - -;;; Code: - - -;; Variables - -(defvar handwrite-psindex 0 - "The index of the PostScript buffer") -(defvar menu-bar-handwrite-map (make-sparse-keymap "Handwrite functions.")) -(fset 'menu-bar-handwrite-map (symbol-value 'menu-bar-handwrite-map)) - - -;; User definable variables - -(defvar handwrite-numlines 60 - "*The number of lines on a page of the PostScript output") -(defvar handwrite-fontsize 11 - "*The size of the font for the PostScript output") -(defvar handwrite-linespace 12 - "*The spacing for the PostScript output") -(defvar handwrite-xstart 30 - "*Translation in the x-direction of the origin in the PostScript output") -(defvar handwrite-ystart 810 - "*Translation in the y-direction of the origin in the PostScript output") -(defvar handwrite-pagenumbering nil - "*If t then number each page of the PostScript output") -(defvar handwrite-10pt-numlines 65 - "*The number of lines on a page for the function handwrite-10pt") -(defvar handwrite-11pt-numlines 60 - "*The number of lines on a page for the function handwrite-11pt") -(defvar handwrite-12pt-numlines 55 - "*The number of lines on a page for the function handwrite-12pt") -(defvar handwrite-13pt-numlines 50 - "*The number of lines on a page for the function handwrite-13pt") - - -;; Interactive functions - -(defun handwrite () - "Turns the buffer into a handwritten document. -Variables: handwrite-linespace (default 12) - handwrite-fontsize (default 11) - handwrite-numlines (default 60) - handwrite-pagenumbering (default nil)" - (interactive) - (let - ((pmin) ; thanks, Havard - (lastp) - (cur-buf (current-buffer)) - (tpoint (point)) - (ps-ypos 63) - (lcount 0) - (ipage 1) - (nlan next-line-add-newlines) ;remember the old value - (buf-name (buffer-name) ) - (textp) - (ps-buf-name) ;name of the PostScript buffer - ) - (goto-char (point-min)) ;start at beginning - (setq handwrite-psindex (1+ handwrite-psindex)) - (setq ps-buf-name - (format "*handwritten%d.ps*" handwrite-psindex)) - (setq next-line-add-newlines t) - (switch-to-buffer ps-buf-name) - (handwrite-insert-header buf-name) - (insert "\n(\\nCreated by Gnu Emacs' handwrite version " - emacs-version "\\n\\n)=print flush\n") - (handwrite-insert-preamble) - (handwrite-insert-info) - (handwrite-insert-font) - (setq textp (point)) - (insert "%%Page: 1 1\n") - (insert "Hwjst\n") - (insert "/Hwsave save def\n") - (if handwrite-pagenumbering (insert "20 30 m\nxym(page 1)a\n")) - (insert "44 63 m\n") - (insert "xym( )a") - (backward-char 3) - (switch-to-buffer cur-buf) - (goto-char (point-min)) ;start at beginning - (save-excursion - ;;as long as we see a newline the document is not ended. - (while (re-search-forward "\n" nil t) - (previous-line 1) - (beginning-of-line) - (setq pmin (point)) - (search-forward "\n" nil t) - (backward-char 1) - (copy-region-as-kill (point) pmin) - (forward-char 1) - (switch-to-buffer ps-buf-name) - (yank) - (message "write write write...") - (search-forward ")a" nil t) - (backward-char 2) - (setq lastp (point)) - (beginning-of-line) - (search-forward "(" nil t) - (while (re-search-forward "[()\\]" lastp t) - (save-excursion - (setq lastp (+ lastp 1)) - (forward-char -1) - (insert "\\"))) - (setq ps-ypos (+ ps-ypos handwrite-linespace)) - (end-of-line) - (insert "\n") - (setq lcount (+ lcount 1)) - (cond ( (eq lcount handwrite-numlines) - (setq ipage (+ ipage 1)) - (insert "0 0 m\n") - (insert "showpage exec Hwsave restore\n") - (insert "%%Page: " (number-to-string ipage) " " - (number-to-string ipage) "\n") - (insert "Hwjst\n") - (insert "/Hwsave save def\n") - (if handwrite-pagenumbering - (insert "20 30 m\nxym(page " - (number-to-string ipage) ")a\n")) - (setq ps-ypos 63) - (setq lcount 0) - )) - (insert "44 "(number-to-string ps-ypos) " m\n") - (insert "xym( )a") - (backward-char 3) - (switch-to-buffer cur-buf) - )) - (switch-to-buffer ps-buf-name) - (next-line 1) - (insert "showpage exec Hwsave restore\n\n") - (insert "%%Pages " (number-to-string ipage) " 0\n") - (insert "%%EOF\n") - (goto-char textp) ;start where the inserted text begins - (while (search-forward "ÿ" nil t) - (replace-match "\\" nil t) (insert "264")) - (goto-char textp) - (while (search-forward "á" nil t) - (replace-match "\\" nil t) (insert "207")) - (goto-char textp) - (while (search-forward "à" nil t) - (replace-match "\\" nil t) (insert "210")) - (goto-char textp) - (while (search-forward "â" nil t) - (replace-match "\\" nil t) (insert "211")) - (goto-char textp) - (while (search-forward "ä" nil t) - (replace-match "\\" nil t) (insert "212")) - (goto-char textp) - (while (search-forward "ã" nil t) - (replace-match "\\" nil t) (insert "213")) - (goto-char textp) - (while (search-forward "å" nil t) - (replace-match "\\" nil t) (insert "214")) - (goto-char textp) - (while (search-forward "é" nil t) - (replace-match "\\" nil t) (insert "216")) - (goto-char textp) - (while (search-forward "è" nil t) - (replace-match "\\" nil t) (insert "217")) - (goto-char textp) - (while (search-forward "ê" nil t) - (replace-match "\\" nil t) (insert "220")) - (goto-char textp) - (while (search-forward "ë" nil t) - (replace-match "\\" nil t) (insert "221")) - (goto-char textp) - (while (search-forward "í" nil t) - (replace-match "\\" nil t) (insert "222")) - (goto-char textp) - (while (search-forward "ì" nil t) - (replace-match "\\" nil t) (insert "223")) - (goto-char textp) - (while (search-forward "î" nil t) - (replace-match "\\" nil t) (insert "224")) - (goto-char textp) - (while (search-forward "ï" nil t) - (replace-match "\\" nil t) (insert "225")) - (goto-char textp) - (while (search-forward "ó" nil t) - (replace-match "\\" nil t) (insert "227")) - (goto-char textp) - (while (search-forward "ò" nil t) - (replace-match "\\" nil t) (insert "230")) - (goto-char textp) - (while (search-forward "ô" nil t) - (replace-match "\\" nil t) (insert "231")) - (goto-char textp) - (while (search-forward "ö" nil t) - (replace-match "\\" nil t) (insert "232")) - (goto-char textp) - (while (search-forward "õ" nil t) - (replace-match "\\" nil t) (insert "233")) - (goto-char textp) - (while (search-forward "ú" nil t) - (replace-match "\\" nil t) (insert "234")) - (goto-char textp) - (while (search-forward "ù" nil t) - (replace-match "\\" nil t) (insert "235")) - (goto-char textp) - (while (search-forward "û" nil t) - (replace-match "\\" nil t) (insert "236")) - (goto-char textp) - (while (search-forward "ü" nil t) - (replace-match "\\" nil t) (insert "237")) - (goto-char textp) - (while (search-forward "ß" nil t) - (replace-match "\\" nil t) (insert "247")) - (goto-char textp) - (while (search-forward "°" nil t) - (replace-match "\\" nil t) (insert "241")) - (goto-char textp) - (while (search-forward "®" nil t) - (replace-match "\\" nil t) (insert "250")) - (goto-char textp) - (while (search-forward "©" nil t) - (replace-match "\\" nil t) (insert "251")) - (goto-char textp) - (while (search-forward "ij" nil t) - (replace-match "\\" nil t) (insert "264")) - (goto-char textp) - (while (search-forward "ç" nil t) - (replace-match "\\" nil t) (insert "215")) - (goto-char textp) - (while (search-forward "§" nil t) - (replace-match "\\" nil t) (insert "244")) - (goto-char textp) - (while (search-forward "ñ" nil t) - (replace-match "\\" nil t) (insert "226")) - (goto-char textp) - (while (search-forward "£" nil t) - (replace-match "\\" nil t) (insert "243")) - ;;To avoid cumbersome code we simply ignore pagefeeds - (goto-char textp) - (while (search-forward "\f" nil t) - (replace-match "" nil t) ) - (untabify textp (point-max)) ; this may result in strange tabs - (if (y-or-n-p "Send this to the printer? ") - (call-process-region (point-min) - (point-max) lpr-command nil nil nil)) - (message "") - (bury-buffer ()) - (switch-to-buffer cur-buf) - (goto-char tpoint) - (setq next-line-add-newlines nlan) - )) - - -(defun handwrite-set-pagenumber () - "Toggle the value of handwrite-pagenumbering" - (interactive) - (if handwrite-pagenumbering - (handwrite-set-pagenumber-off)(handwrite-set-pagenumber-on))) - -(defun handwrite-10pt () - "Sets the variable `handwrite-fontsize' to 10 and finds correct -values for `handwrite-linespace' and `handwrite-numlines'" - (interactive) - (setq handwrite-fontsize 10) - (setq handwrite-linespace 11) - (setq handwrite-numlines handwrite-10pt-numlines) - (define-key menu-bar-handwrite-map [10pt] - '("10 pt *" . handwrite-10pt)) - (define-key menu-bar-handwrite-map [11pt] - '("11 pt" . handwrite-11pt)) - (define-key menu-bar-handwrite-map [12pt] - '("12 pt" . handwrite-12pt)) - (define-key menu-bar-handwrite-map [13pt] - '("13 pt" . handwrite-13pt)) - (message "Joepie set to 10 points")) - - -(defun handwrite-11pt () - "Sets the variable `handwrite-fontsize' to 11 and finds correct -values for `handwrite-linespace' and `handwrite-numlines'" - (interactive) - (setq handwrite-fontsize 11) - (setq handwrite-linespace 12) - (setq handwrite-numlines handwrite-11pt-numlines ) - (define-key menu-bar-handwrite-map [10pt] - '("10 pt" . handwrite-10pt)) - (define-key menu-bar-handwrite-map [11pt] - '("11 pt *" . handwrite-11pt)) - (define-key menu-bar-handwrite-map [12pt] - '("12 pt" . handwrite-12pt)) - (define-key menu-bar-handwrite-map [13pt] - '("13 pt" . handwrite-13pt)) - (message "Joepie set to 11 points")) - -(defun handwrite-12pt () - "Sets the variable `handwrite-fontsize' to 12 and finds correct -values for `handwrite-linespace' and `handwrite-numlines'" - (interactive) - (setq handwrite-fontsize 12) - (setq handwrite-linespace 13) - (setq handwrite-numlines handwrite-12pt-numlines) - (define-key menu-bar-handwrite-map [10pt] - '("10 pt" . handwrite-10pt)) - (define-key menu-bar-handwrite-map [11pt] - '("11 pt" . handwrite-11pt)) - (define-key menu-bar-handwrite-map [12pt] - '("12 pt *" . handwrite-12pt)) - (define-key menu-bar-handwrite-map [13pt] - '("13 pt" . handwrite-13pt)) - (message "Joepie set to 12 points")) - -(defun handwrite-13pt () - "Sets the variable `handwrite-fontsize' to 13 and finds correct -values for `handwrite-linespace' and `handwrite-numlines'" - (interactive) - (setq handwrite-fontsize 13) - (setq handwrite-linespace 14) - (setq handwrite-numlines handwrite-13pt-numlines) - (define-key menu-bar-handwrite-map [10pt] - '("10 pt" . handwrite-10pt)) - (define-key menu-bar-handwrite-map [11pt] - '("11 pt" . handwrite-11pt)) - (define-key menu-bar-handwrite-map [12pt] - '("12 pt" . handwrite-12pt)) - (define-key menu-bar-handwrite-map [13pt] - '("13 pt *" . handwrite-13pt)) - (message "Joepie set to 13 points")) - - -;; Internal Functions - -;;The header for the PostScript output. The argument is the name of -;;the original buffer -(defun handwrite-insert-header (buf-name) - (insert "%!PS-Adobe-2.0\n") - (insert "%%Title: " buf-name "\n") - (insert "%%CreationDate: " (current-time-string) "\n" ) - (insert "%%Pages: (atend)\n") - (insert "%%For: " user-mail-address "\n") - (insert "%%EndComments\n")) - -;;Some PostScript definitions for using our font. -(defun handwrite-insert-preamble () - (insert "\n%%BeginPreamble -/m {moveto} def -/r {roll} def -/e {exch} def -/a {awidthshow} def -/xym {0.52490 0. 32 0.05249 0.} def -/HwJdict 80 dict def -/Hwfdict 80 dict def -/getsymb {Hwfdict /Jsymb get 3 1 r put} def -/Chread{ - { e begin - HwJdict begin %read in character specifications - /jnum e def - /jnum1 jnum 6 mul def - save symbstr jnum1 6 getinterval{ - }forall - /pixvol e def - /pixwid e def - /charwidth e def - /trx e def - /try e def - /pixf e def - .02666667 .02666667 scale - /pixwid pixwid 1.042 mul def - /pixwidn pixwid trx add def - /pixvoln pixvol try add def - charwidth 0 trx try pixwidn pixvoln setcachedevice - newpath 0 0 m - pixf 0 gt{ - pixf 3 bitshift - trx try translate - pixwid pixvol scale - /pixvol1 {pixvol 4 add true} def - /pixvol2 pixvol neg def - /pixvol3 pixvol 2 add def - pixvol1 pixwid 0 0 pixvol2 0 pixvol3 6 array astore - Jsymb jnum get - imagemask - }if - restore - end - end - }def -}def -/Hwjst{ - /Joepie findfont [Hws 0 Hws pop 0 Hws neg 0 0] makefont setfont -}def -%%EndPreamble\n")) - -;;The the font size for the PostScript output. -;;Also the x-y-translations of the PostScript stuff. -(defun handwrite-insert-info () - (insert "\n%%BeginSizeTranslate\n") - (insert "/Hws " (number-to-string handwrite-fontsize) " def") - (insert " %The size of the font\n") - (insert (number-to-string handwrite-xstart)" " - (number-to-string handwrite-ystart)) - (insert " translate %Translate the origin to the current location\n") - (insert "1 -1 scale %Flip the y coordinate\n") - (insert "%%EndSizeTranslate\n\n")) - - -;;Bitmap PostScript font for pseudo handwritten documents. -;;Two years ago, I created the 36 points font for my -;;Apple Macintosh Classic II resulting in unusual ascii numbers. -(defun handwrite-insert-font () - (insert "\n%%BeginFont Joepie -Hwfdict begin - /Jsymb 256 array def - /FontType 3 def - /FontBBox [0 0 1 1] def - /FontMatrix [1 0 0 1 0 0] def - /Encoding 256 array def -end -<002809000000 FF28FFFF0000 FF28FFFF0000 FF28FFFF0000 FF28FFFF0000 -FF28FFFF0000 FF28FFFF0000 FF28FFFF0000 FF28FFFF0000 002809080000 -FF28FFFF0000 FF28FFFF0000 FF28FFFF0000 002809000000 FF28FFFF0000 -FF28FFFF0000 FF28FFFF0000 FF28FFFF0000 FF28FFFF0000 FF28FFFF0000 -FF28FFFF0000 FF28FFFF0000 FF28FFFF0000 FF28FFFF0000 FF28FFFF0000 -FF28FFFF0000 FF28FFFF0000 FF28FFFF0000 FF28FFFF0000 FF28FFFF0000 -FF28FFFF0000 FF28FFFF0000 002809080000 020A0E08031E 021C0B0E0A0A -040C09161418 04050A121323 040D0F1C141B 040C141C0F19 021B0B08060D -02080B0C091E 0208080C0B20 041A0B100F0C 040E09141314 02060B08060B -0219090C0C03 020C0B080304 04090C120F1F 04080A121017 020C10120514 -040A09121216 040C09121216 02090B120D15 040C0B121015 040A0A12121B -020209120D1D 040A09121018 04040A12101C 020C0D080412 020408080717 -040B0B141116 040C0B16140B 040B0B141018 020A0D120C1C 04090B1C191F -040A091A1C1C 0408071A1E20 040A0B1A1A1E 040E0D201E1A 040C0916181C -040E0916171A 04010B1C1C27 060A0C20201E 040E060E141A 0401070E1327 -040E0A1C1D1A 040C0916181C 060C07262B1C 060C0520261C 04080D1E1C20 -040A05161C1C 040A0B1E1E1E 040A091A1D1E 040C0914171C 040E07161A1A -060E091E1F1A 040E071A1D1A 060A0B2C2C1E 040808181B20 040409161722 -040C08181A1C 020A080A0A1D 040A0610121E 0208090A0A1F 041C0714160A -040505161903 021B0C0C060D 040C08141713 040C0916181C 040C08121412 -040D0916181B 040C09141615 0202090C0D26 04040814171B 040A0916181E -020C090A0D1B 0202090A0C23 040A0814171E 020C080A0D1C 060C09222412 -040C08161910 040C08141611 04000816191C 04020914171B 040A090E1014 -040A09101213 040C090C0F1B 040C09161812 040A09121412 040C09181A10 -040C08121511 04020812151C 040C08101312 040A050A0F1E 020A1114031C -0208070A0E20 04140A141409 FF28FFFF0000 040A071A1B1C 040A091A181C -040A0B1A171E 020F0F160E16 040A0F201A1E 04080D1E1A20 040E0B1E1D1A -040C0814171B 040D0714171B 040D0714171A 040D0814171A 040D0814171B -040D0814171B 04000912141C 040C0914151C 040C0914161C 040C0914151C -040C0914151B 020B070A0D1C 020B070A0D1C 020B080A0D1C 020B070A0D1A -040C0616191A 040B0714171D 040B08141719 040B0814171A 040B08141718 -040B08141718 040B0716191B 040B0716191B 040B0716191C 040B08161919 -040A0912111C 02180C0E090C 04050712141F 040A0816151C 04080A121220 -020F0A120E10 040408181522 04040816191D 040A0D201A1E 040A09201C1C -06190B24210E 021C0B0C0708 0221090E0D03 040809141415 040C121E1619 -04080F1E1920 04130F1A1309 040C0B141216 04090914141E 040A0914131B -040209161823 04030A161519 020B0B120E19 0407091A1921 040A0B1E141E -040C0914140F 0401090C0F25 FF28FFFF0000 FF28FFFF0000 FF28FFFF0000 -FF28FFFF0000 040A0B14121A 04010910101B FF28FFFF0000 040A0614181C -040A09141618 0407090E1221 040D0A141510 002800160000 04080A141119 -04080614151A 040A0B1E1804 FF28FFFF0000 040A071A1B1D 040A071A191D -FF28FFFF0000 FF28FFFF0000 FF28FFFF0000 041408141303 061409262404 -041A0B120F0B 021D0B120D0A 021E0E0A050A 021E0B0A060A FF28FFFF0000 -FF28FFFF0000 FF28FFFF0000 FF28FFFF0000 040600060F1C FF28FFFF0000 -020C0A0C0B16 020D080C0C17 FF28FFFF0000 FF28FFFF0000 FF28FFFF0000 -02140B0A0506 02040908060E FF28FFFF0000 0608092A291E FF28FFFF0000 -FF28FFFF0000 FF28FFFF0000 FF28FFFF0000 FF28FFFF0000 FF28FFFF0000 -FF28FFFF0000 FF28FFFF0000 FF28FFFF0000 FF28FFFF0000 FF28FFFF0000 -040A0B1C181B 060C071E221C FF28FFFF0000 FF28FFFF0000 FF28FFFF0000 -FF28FFFF0000 021D0C0E0C08 021E090E0C06 0421060E1105 FF28FFFF0000 -021F0A0A0506 FF28FFFF0000 FF28FFFF0000 FF28FFFF0000 FF28FFFF0000 -041E09101107> -Hwfdict begin /symbstr e def end -255< 00000000 00000000 80018000 60030000 38060000 0E1C0000 03F00000 -01C00000 01800000 00000000 00000000>getsymb -250< 0000 0000 6000 7800 7800 F800 F800 7000 0000 0000>getsymb -248< 00000000 00000000 F8000000 3F800000 03F80000 007E0000 00038000 -00000000 00000000 >getsymb -247< 0000 0000 0030 0060 38E0 7FC0 C300 8000 0000 0000 >getsymb -246< 0000 0000 0C00 1E00 3F00 3380 60C0 4040 C020 0010 0000 0000 ->getsymb -241< 000000000000 000000000000 008000000000 00C000000000 03C000000000 -038000000000 000000000000 000000000000 000000000000 000000000000 -010000000000 010000000000 010007C00000 03001FE00000 070038700000 -070030300000 0F0060300000 1B00C0700000 3300C0600000 6300C0C0C000 -C300C3818000 030046030000 03007C020000 0300F0060000 0180F00C0000 -018198180000 01C30C300000 00CE06300000 00FC03E00000 007801C00000 -000000000000 000000000000 >getsymb -240< 00000000 00000000 00004000 0003C000 00038000 000E0000 000C0000 -00080000 00180000 0E187C00 1F98FC00 3FDCFF00 3FFFFF00 7FFFFE00 -7FFFFC00 FFFFF800 FFFFF000 FFFFF000 FFFFF000 FFFFF000 FFFFF000 -FFFFFC00 7FFFFC00 7FFFFF00 3FFFFF00 1FFFFE00 0FFFFE00 07FFF800 -03F3F000 00000000 00000000 >getsymb -228< 000000000000 000000000000 03C010000000 07C0F0000000 1C7330000000 -383F20000000 303040000000 2030C0000000 6030C0000000 C01080000000 -C01180000000 C03100000000 406300000000 604200000000 60C40E000080 -71843F01E080 3F0CE183B180 1E0880CE1F00 001180FA0600 003100460600 -0023004C0200 0047004C0300 004B004C0300 00B300CC0300 00E300CC0200 -01C1818C0200 03C1830C0600 0380830C0C00 0600FE061800 1C007C03F000 -180000000000 300000000000 000000000000 000000000000 >getsymb -226< 0000 0000 2000 1800 1800 0C00 0C00 0C00 0C00 0C00 0C00 1800 1000 -3000 6000 8000 0000 0000 >getsymb -225< 0000 0000 7000 E800 F800 F800 F000 F000 0000 0000 >getsymb -221< 0000 0000 8000 E000 3000 1C00 0E00 0700 0380 01C0 01C0 00E0 0030 -0030 0030 0060 00C0 0180 0300 0200 0600 0C00 1800 3000 4000 0000 0000 ->getsymb -220< 0000 0000 0060 0040 00C0 0180 0300 0600 0C00 1C00 3000 7000 6000 -C000 4000 6000 3000 3000 1800 1C00 0E00 0600 0300 0100 0000 0000 ->getsymb -218< 00000000 00000000 00020000 00060000 000E0000 000C0000 000C0000 -00180000 00180000 00100000 00300000 00200000 00200000 00400000 -00C00000 00C00000 01800000 01800000 03000000 03000000 06000000 -06000000 0C000000 1C000000 18000000 38000000 30000000 70000000 -60000000 C0000000 00000000 00000000 >getsymb -213< 0000 0000 2000 1800 0C00 0400 0400 0C00 1800 3000 6000 8000 0000 -0000 >getsymb -212< 0000 0000 0800 3000 6000 C000 C000 C000 6000 3000 1000 0800 0000 -0000 >getsymb -211< 0000 0000 0040 1020 0810 0C18 0C18 1818 3010 4030 8060 0040 0000 -0000 >getsymb -210< 00000000 00000000 00060000 04180000 18300000 30600000 60C00000 -C0C00000 C0C00000 C0C00000 C0400000 40200000 20000000 00000000 -00000000 >getsymb -209< 000000000000 000000000000 FFF000000000 0FFFC0000000 000FFFFE0000 -000007FFF000 000000000000 000000000000 >getsymb -208< 00000000 00000000 FFC00000 7FFF8000 007FE000 00000000 00000000 ->getsymb -204< 00000000 00000000 00000200 00038C00 0007F800 001CF000 00380000 -00200000 00000000 00000000 00080000 00060000 00030000 00078000 -0007C000 000CE000 001CF000 00303000 00303E00 003FF800 00FF1800 -00400C00 00C00C00 01800600 01800600 03000300 06000300 1C000380 -30000380 60000380 E0000700 00000000 00000000 >getsymb -203< 00000000 00000000 00300000 00180000 000E0000 00038000 0003C000 -0000E000 0000F000 00001800 00060800 00030000 00038000 00078000 -000EC000 000C6000 00182000 00302000 00703000 01FC3000 00FFF800 -01807F80 03800E00 07000200 06000200 0E000300 1C000100 38000180 -600000C0 C0000060 C0000060 00000000 00000000 >getsymb -201< 00000000 00000000 80180600 E03C0700 E07C0700 703C0E00 00000000 -00000000 >getsymb -200< 00000000 00000000 00100000 00180000 E00C0000 30060000 18060000 -0C070000 0E018000 0E01C000 0780C000 03806000 00E07000 00E03000 -00703800 00303800 00607000 00606000 01C0C000 0180C000 03018000 -06070000 0C060000 380C0000 30080000 00100000 00200000 00600000 -00000000 00000000 >getsymb -199< 00000000 00000000 00010000 00620000 00C60000 018C0000 03180000 -06180000 0C300000 18600000 10600000 70C00000 60C00000 E1C00000 -61C00000 30E00000 38600000 18300000 1C100000 0E080000 070C0000 -03060000 01C30000 00C30000 00438000 00418000 00008000 00000000 -00000000 >getsymb -197< 00000000 00000000 00003800 0000F000 0C038000 3F870000 70FE0000 -603C0000 C0000800 80001000 00003000 03802000 0FE06000 38F06000 -701CC000 600F8000 60078000 00030000 00000000 00000000 >getsymb -196< 00000000 00000000 0001C000 001F8000 00380000 00600000 00600000 -00400000 00400000 00C00000 00C00000 00C00000 00C00000 00CC0000 -00980000 01F00000 0F800000 0D800000 01800000 01800000 01800000 -01800000 01800000 01800000 01800000 01800000 01800000 01800000 -01800000 01800000 03000000 02000000 06000000 8C000000 78000000 -00000000 00000000 >getsymb -195< 00000000 00000000 00000400 00001800 0003F000 00078000 00060000 -00040000 000C0000 000C0000 600C0000 F00C0000 300C0000 18180000 -18180000 18180000 08100000 08300000 0C300000 0C600000 0C600000 -0C400000 0DC00000 07800000 07000000 02000000 00000000 00000000 ->getsymb -194< 00000000 00000000 03018000 0F07C000 188C6000 10C83000 20701800 -60300C00 40200600 C0200300 C0000300 C0000300 40000300 40000300 -60000300 60000600 20000C00 30000800 10001800 18003000 0C006000 -0C00C000 06018000 03070000 010C0000 00980000 00F00000 00600000 -00400000 00400000 00000000 00000000 >getsymb -192< 00000000 00000000 00C00000 00E00000 00C00000 00000000 00000000 -00000000 00C00000 00C00000 00600000 00600000 00C00000 01800000 -03000000 06000000 1C000000 38000000 60000000 60040000 C0060000 -C0020000 C0010000 E0030000 70060000 380C0000 1C3C0000 0FF80000 -07E00000 00000000 00000000 >getsymb -191< 00000000 00000000 06000000 1F000000 318C0000 609F0000 60B38000 -60E18000 40418000 C040C000 C000C000 C000C000 C000C000 C0018000 -40030000 60060000 600C0000 30180000 30100000 18300000 18600000 -08400000 0CC00000 0C800000 05800000 03000000 03000000 02000000 -00000000 00000000 >getsymb -186< 00000000 00000000 00060000 001C0000 00F80000 01F00000 01800000 -03800000 03800000 07000000 07000000 07000000 07000000 07000000 -07000000 07000000 07000000 07000000 07000000 07000000 07000000 -0F000000 0F000000 0F000000 0F000000 0F000000 0F000000 0F000000 -0E000000 0E000000 0E000000 0E000000 0E000000 0E000000 0E000000 -8C000000 FC000000 F8000000 30000000 00000000 00000000 >getsymb -185< 00000000 00000000 00004000 7C003000 FF003000 CF806000 CDC0C000 -0CFF0000 0C1F0000 0C030000 0C030000 0C030000 0C030000 0C010000 -0C018000 3800D000 30006000 00000000 00000000 >getsymb -184< 00000000 00000000 1FC00000 7FFC0000 EE0F0000 83038000 0301C000 -0180C000 01806000 01802000 01803000 01803000 01803000 01803000 -01803000 01803000 01806000 0180E000 0181C000 018F8000 03FC0000 -0FE00000 03000000 03000000 03000000 03000000 06000000 06000000 -06000000 06000000 06000000 06000000 00000000 00000000 >getsymb -183< 00000000 00000000 000FF800 003FFE00 00F00700 03C00180 0F000080 -07000000 03C00000 01E00000 00780000 001E0000 00070000 0001C000 -0000E000 00007000 0000F800 0001C000 00038000 00060000 000C0000 -00380000 00700000 00E00000 01C00000 03800080 0F000180 1C000180 -38000180 70000300 E0000300 FC000600 7FFC0C00 03FFF800 0003F000 -00000000 00000000 >getsymb -182< 0000 0000 0F00 3F80 40E0 8070 0038 0018 000C 000C 000C 000C 038C -0FEC 1C3C 301C 201C 600C 600C 600C 600C 6008 6018 6030 3060 1FC0 0F80 -0000 0000 >getsymb -181< 00000000 00000000 0600C000 0600C000 0600C000 0600C000 06008000 -06018000 06018000 0E018000 0E018000 0E018000 0E038000 0E038000 -0E038800 1E079800 1B0DF000 19F8E000 10F04000 30000000 30000000 -30000000 30000000 60000000 60000000 40000000 80000000 00000000 -00000000 >getsymb -180< 00000000 00000000 08000000 0C030000 0C038000 00000000 00000000 -00000000 00000000 04030000 0C030000 0C030000 18030000 38030000 -30030000 70060300 F0060600 301C0C00 301C0C00 303C1800 186C3000 -1C6C6000 0CCC6000 078CC000 030D8000 000F0000 000E0000 003C0000 -007C0000 00CC0000 018C0000 030C0000 030C0000 03180000 03300000 -01E00000 00C00000 00000000 00000000 >getsymb -179< 00000000 00000000 38000000 0E000000 03800000 00C00000 00600000 -00300000 001C0000 00070000 0003C000 00018000 00030000 00060000 -001C0000 00780000 00C00000 01800000 07000000 0E000000 18000000 -00000000 000FE000 1FFF0000 7FE00000 00000000 00000000 3FFFC000 -FFFF8000 00000000 00000000 >getsymb -178< 00000000 00000000 00018000 00070000 000C0000 00180000 00700000 -01C00000 07000000 0C000000 38000000 60000000 C0000000 E0000000 -30000000 18000000 0E000000 07000000 01C00000 00E00000 00380000 -001C0000 00070000 00000000 00000000 3FFFF000 0FFFE000 00000000 -00000000 0FE00000 07FF8000 001FE000 00000000 00000000 >getsymb -177< 00000000 00000000 01000000 03000000 03000000 03000000 03000000 -03000000 03000000 03000000 FFF80000 FFFF0000 03000000 03000000 -03000000 01800000 01800000 01800000 01800000 01800000 00000000 -00000000 FFFFC000 0FFFC000 00000000 00000000 >getsymb -176< 00000000 00000000 000F0000 003FC000 3C60E000 7EC06000 C1806000 -C180C000 61FF8000 7F1F0000 1E000000 00000000 00000000 >getsymb -175< 00000000 00000000 00000300 00000600 00000400 001FEC00 00783800 -00E03C00 03806600 06006200 0E004300 0C00C300 0C018180 0C018180 -18030180 18020180 18060180 180C0180 18080180 18180180 18300300 -18700300 18E00200 09800600 0D000C00 0F000800 07003800 0780F000 -0DFFC000 0C7F0000 18000000 30000000 60000000 C0000000 00000000 -00000000 >getsymb -174< 00000000 00000000 00FF0000 03C1C000 0700E000 1C003000 30001000 -70001800 60001800 60000C00 60000C00 C0000C00 C0000C00 C0000C00 -C0000C00 C0000C00 C0000C00 C0001800 C0001800 C0001000 40003000 -60006000 70004000 3801C000 1C078000 0FFE0000 03F80000 00000000 -00000000 >getsymb -173< 00000000 00000000 00040000 000C0000 000C0000 000C0000 00180000 -001FF000 07FFC000 3FF80000 78300000 00600000 00600000 00C00000 -00FFE000 3FFFC000 FFC00000 01800000 01800000 03000000 03000000 -06000000 04000000 00000000 00000000 >getsymb -172< 0000 0000 E038 6038 C030 0000 0000 >getsymb -171< 0000 0000 0600 1C00 3000 6000 4000 C000 C000 8000 0000 0000 ->getsymb -170< 000000000000 000000000000 000F20000000 01F82C700000 FF803EF80000 -FF00638C0000 6300630C0000 330063040000 130063060000 1B0063060000 -0B00C3060000 0B00C3060000 0B00C3068000 0E0183028000 060101038000 -000000030000 000000000000 000000000000 >getsymb -169< 00000000 00000000 0000F800 0003FC00 003F1E00 00F80700 03800180 -06000180 1C0000C0 300000C0 3007C0C0 601FF0E0 60301820 60200C30 -C0600430 C0C00030 C0C00030 C0C00030 C0C00030 C0C02030 C0402030 -C0606030 6030C020 603F8060 380E01C0 3C000300 03001E00 03C03C00 -00FFE000 00FF0000 00000000 00000000 >getsymb -168< 00000000 00000000 00078000 000FC000 000CE000 000C7000 007E1800 -00FC0C00 07C00E00 0F800700 0C060300 1C9F8300 30B0C180 30C0C180 -70C1C180 E0C38080 C0FF00C0 C0FC00C0 C1C800C0 C1CC00C0 C30E01C0 -C3030180 E2038300 6201C300 30000700 30000E00 38003C00 1C007800 -0E00E000 0F03C000 07FF8000 01FC0000 00000000 00000000 >getsymb -167< 00000000 00000000 00070000 003F8000 0C70C000 1EC04000 1E804000 -1700C000 37018000 36030000 360C0000 661F0000 66018180 C6008300 -0600C600 0600CC00 0600D800 0600F000 0600E000 0600C000 0E038000 -0E0E0000 0C180000 0C200000 0C000000 0C000000 08000000 08000000 -10000000 10000000 10000000 00000000 00000000 >getsymb -166< 00000000 00000000 00060000 00038000 01F0C000 07AFE000 3FBDF000 -5F5C3000 4FFC3000 5FFC3000 BFFC1000 FFFC1000 7FFC1000 7FFC1800 -7FF81800 7FF81800 FFF81800 FFF80800 7FF80800 7FF80800 3FF80800 -00580800 00180800 00180800 00181800 00181800 00181800 00181000 -00183000 00182000 00186000 00186000 0018C000 001CC000 000F8000 -00078000 00000000 00000000 >getsymb -165< 0000 0000 3000 4F00 9FC0 FFE0 FFF0 7FF8 FFF8 FFF8 FFF8 FFFC 9FE4 -AFE4 4FD8 7FF0 2700 1E00 0000 0000 >getsymb -164< 00000000 00000000 00F00000 01FC0000 03060000 06020000 06000000 -07000000 03200000 01C00000 07F00000 1C1C0000 30060000 60030000 -C0018000 C0018000 C0018000 E0070000 700C0000 1E780000 07E00000 -03F00000 06380000 081C0000 000C0000 00060000 00030000 00018000 -0400C000 0400C000 06018000 03038000 01FE0000 00F00000 00000000 -00000000 >getsymb -163< 00000000 00000000 00018000 0007C000 001C6000 00303000 00601800 -00600800 00400000 00C00000 00C00000 00C00000 00C00000 00C00000 -00C00000 00C00000 1FC00000 03FE0000 01FFC000 01C00000 01800000 -0180E000 03013000 07001800 06001800 0C001000 18002000 3FC0E000 -F07FC000 601F0000 00000000 00000000 >getsymb -162< 00000000 00000000 00180000 00300000 00200000 00600000 00600000 -00600000 00600000 01F00000 07F80000 0CCC0000 08C40000 18C00000 -30C00000 70800000 F1801000 31803000 31806000 31804000 3180C000 -31818000 19818000 19830000 0D8E0000 07980000 01F00000 01800000 -01000000 01000000 03000000 03000000 02000000 00000000 00000000 ->getsymb -161< 0000 0000 3C00 6600 6300 4180 C180 C080 C080 E180 FF00 4C00 6000 -3000 0000 0000 >getsymb -160< 00000000 00000000 00C00000 00C00000 00C00000 00C00000 00C00000 -00C00000 00C00000 00C00000 01C00000 E1C00000 FFE00000 07FC0000 -01CF8000 01800000 01800000 01800000 01800000 01800000 01800000 -01800000 01800000 01800000 01800000 01800000 01800000 01800000 -01800000 01000000 00000000 00000000 >getsymb -159< 00000000 00000000 01000000 0300C000 0300C000 00006000 00000000 -00000000 00000000 00000000 00008000 04008000 0E018000 3B018000 -63010000 43010180 C3030300 02030600 06030400 06030C00 06030C00 -06070800 06059800 060D9800 06189000 03F0F000 01E06000 00000000 -00000000 >getsymb -158< 00000000 00000000 00100000 00780000 01CE0000 03870000 06018000 -0400C000 08006000 00002000 00000000 00000000 00000000 00004000 -00004000 0C018000 1E018000 33030000 63030180 C3030300 03030600 -06030600 06030400 06070C00 06070C00 06051800 06091800 07191000 -03F1F000 01E0E000 00000000 00000000 >getsymb -157< 00000000 00000000 01800000 00C00000 00F00000 00300000 00180000 -000C0000 00060000 00000000 00000000 00000000 00008000 00018000 -00018000 3C018000 7E018000 43018180 C3010300 03030600 06030600 -06030C00 06070C00 06070C00 06059800 060D9800 07089000 03F8F000 -01F06000 00000000 00000000 >getsymb -156< 00000000 00000000 00007000 0001C000 00030000 000E0000 00380000 -00200000 00E00000 00000000 00000000 00004000 0E00C000 1E00C000 -13018000 33018000 63030000 43030180 C3030300 03030600 06030600 -06070C00 06070C00 060F0C00 06099800 06199800 07309000 03E0F000 -01C06000 00000000 00000000 >getsymb -155< 00000000 00000000 00C0C000 01E38000 11370000 0E1E0000 04000000 -00000000 00000000 00F00000 03FC0000 071E0000 0E070000 38018000 -7801C600 D801EC00 1801B800 18018000 18018000 0C018000 0C018000 -06010000 06030000 03060000 01FC0000 00F00000 00000000 00000000 ->getsymb -154< 00000000 00000000 0C040000 0C0E0000 100E0000 00000000 00000000 -00000000 00000000 00F00000 03FC0000 079E0000 0F070000 3F038000 -7203C600 C6017C00 06013000 06018000 0E018000 0C018000 0C010000 -06030000 06060000 030C0000 01F80000 00F00000 00000000 00000000 ->getsymb -153< 00000000 00000000 00C00000 00600000 00F00000 01BC0000 030E0000 -06070000 18018000 1000E000 00000000 00F00000 03FC0000 079E0000 -1F070000 3C038000 7803C600 D8016C00 18013800 18018000 18018000 -0C018000 0C010000 06030000 06060000 030C0000 01F80000 00F00000 -00000000 00000000 >getsymb -152< 00000000 00000000 06000000 07000000 01C00000 00780000 003C0000 -00070000 00000000 00000000 00F00000 03FC0000 071E0000 1C030000 -38038000 7801C600 D8016C00 18013800 18018000 18018000 08018000 -0C010000 0C030000 06060000 030C0000 01F80000 00F00000 00000000 -00000000 >getsymb -151< 00000000 00000000 00010000 00020000 000C0000 00180000 00300000 -00E00000 03800000 00000000 00000000 00000000 00000000 00000000 -00F00000 03FC0000 079C0000 1C060000 38030000 7801C600 D8016C00 -18013800 18018000 18018000 1C018000 0C030000 0C020000 0C060000 -060C0000 07F80000 01F00000 00000000 00000000 >getsymb -150< 00000000 00000000 00000600 00E00C00 01B83800 010E6000 0603C000 -0C000000 00000000 00000000 00000000 00000000 00000000 0F1C0000 -3FBF0000 31B38000 61E18000 C1C18180 81818180 01818300 01818300 -01818600 03018600 07018400 06018C00 0600CC00 06007800 06003000 -00000000 00000000 >getsymb -149< 0000 0000 1800 3830 3878 0070 0000 0000 0000 0000 0C00 1800 1800 -3000 3000 7008 F018 B030 3060 3060 30C0 30C0 3180 3180 1B00 1E00 1C00 -0800 0000 0000 >getsymb -148< 0000 0000 0300 0780 0D80 18C0 3040 2060 2030 4030 0018 0000 0C00 -1800 1800 3000 3000 7008 F018 B030 3060 3060 30C0 30C0 3180 3180 1B00 -1E00 1C00 0800 0000 0000 >getsymb -147< 0000 0000 8000 E000 7000 1800 0C00 0700 0780 0000 0000 0000 0C00 -1800 1800 3000 3000 7008 F018 B030 3060 3060 30C0 30C0 3180 3180 1B00 -1E00 1C00 0800 0000 0000 >getsymb -146< 0000 0000 0018 0030 0060 01C0 0300 0E00 1C00 0000 0000 0000 0C00 -1800 1800 3000 3000 7008 F018 B030 3060 3060 30C0 30C0 3180 3180 1B00 -1E00 1C00 0800 0000 0000 >getsymb -145< 00000000 00000000 301C0000 380C0000 30000000 00000000 00000000 -00000000 00000000 03E00000 0FF00000 1C180000 30180000 60180000 -40300000 C0600000 C0C00000 C7800000 FE001800 F0001000 60003000 -30006000 3000C000 18018000 0C030000 0C060000 061C0000 03F80000 -00E00000 00000000 00000000 >getsymb -144< 00000000 00000000 03E00000 0FF80000 300E0000 20030000 40010000 -C0000000 00000000 00000000 03E00000 07300000 0C180000 180C0000 -300C0000 200C0000 60380000 60E00000 67C00000 FE001800 60003000 -60006000 3000C000 30018000 10030000 18060000 0C0C0000 06380000 -03F00000 01C00000 00000000 00000000 >getsymb -143< 00000000 00000000 38000000 0C000000 07000000 01800000 00C00000 -00400000 00000000 00000000 01C00000 07E00000 0C300000 18180000 -30080000 30380000 60E00000 C3800000 CE000000 F8000C00 F0001800 -60003000 30006000 3000C000 18018000 08030000 0C060000 060C0000 -03F80000 01E00000 00000000 00000000 >getsymb -142< 00000000 00000000 001C0000 00780000 00C00000 00800000 03000000 -02000000 00000000 00000000 07800000 1FC00000 30600000 60300000 -60300000 40600000 C1C00000 C7800000 9E000000 F0000800 C0001800 -C0003000 60006000 2000C000 30018000 18030000 080E0000 0C180000 -07F00000 03C00000 00000000 00000000 >getsymb -141< 00000000 00000000 03E00000 0FF00000 18180000 30080000 60000000 -60003000 40006000 C000C000 C0008000 C0018000 C0018000 C0030000 -40030000 60020000 30060000 1F0C0000 07F80000 00E00000 00C00000 -00400000 00780000 001C0000 00040000 04060000 06060000 03060000 -030C0000 01F80000 00000000 00000000 >getsymb -140< 00000000 00000000 00F00000 01F80000 02880000 00880000 00D80000 -00700000 00000000 00000000 01E08000 03F98000 060D8000 0C070000 -18060000 10060000 30060000 70060000 E0060600 E00C0400 600C0C00 -600C1800 201C1000 30163000 30366000 18366000 18624000 0FC3C000 -07818000 00000000 00000000 >getsymb -139< 00000000 00000000 00004000 00008000 0E030000 339E0000 40F00000 -00000000 00000000 00000000 01E08000 03F98000 060D8000 0C070000 -18060000 10060000 30060000 70060000 E0060600 E00C0400 600C0C00 -600C1800 201C1000 30163000 30366000 18366000 18624000 0FC3C000 -07818000 00000000 00000000 >getsymb -138< 00000000 00000000 00080000 040C0000 1C0C0000 18000000 00000000 -00000000 00000000 01E08000 03F98000 060D8000 0C070000 18060000 -10060000 30060000 70060000 E0060600 E00C0400 600C0C00 600C1800 -201C1000 30163000 30366000 18366000 18624000 0FC3C000 07818000 -00000000 00000000 >getsymb -137< 00000000 00000000 00F00000 031C0000 0E060000 18038000 00008000 -00000000 00000000 01E08000 03F98000 060D8000 0C070000 18060000 -10060000 30060000 70060000 E0060600 E00C0400 600C0C00 600C1800 -201C1000 30163000 30366000 18366000 18624000 0FC3C000 07818000 -00000000 00000000 >getsymb -136< 00000000 00000000 10000000 0C000000 04000000 06000000 03000000 -01800000 00000000 00000000 01E08000 03F98000 060D8000 0C070000 -18060000 10060000 30060000 70060000 E0060600 E00C0400 600C0C00 -600C1800 201C1000 30163000 30366000 18366000 18624000 0FC3C000 -07818000 00000000 00000000 >getsymb -135< 00000000 00000000 00030000 000E0000 00180000 00300000 00400000 -00000000 00000000 00000000 01E08000 03F98000 060D8000 0C070000 -18060000 10060000 30060000 70060000 E0060600 E00C0400 600C0C00 -600C1800 201C1000 30163000 30366000 18366000 18624000 0FC3C000 -07818000 00000000 00000000 >getsymb -134< 00000000 00000000 38003800 38003800 30001800 00000000 00000000 -20000000 60001800 60001800 60001800 C0001800 C0001800 C0001800 -C0003000 C0003000 C0006000 C0006000 C000C000 C001C018 C001C030 -C003C060 6006C060 600C60C0 30186180 3C303300 0FE01E00 07C00C00 -00000000 00000000 >getsymb -133< 00000000 00000000 0F878000 1FCFC000 307CF800 303C3C00 30300C00 -30300600 30300300 30300300 30300300 30300300 30300700 60300E00 -C031FC00 C073F800 C0FF0000 C0FF0000 C0C30000 C0C30000 C0C18000 -C0C0C000 C0C0E000 C0C07000 E0C03000 E0C03800 70C00E00 30C00E00 -30C00300 30C00300 38C00380 1CC00180 0F8000C0 0F000040 00000000 -00000000 >getsymb -132< 00000000 00000000 0F000100 1F800100 30E00300 30700300 30700300 -30700300 20580300 204C0300 20CC0380 60CC01C0 E0CE00C0 E0C700C0 -C0C300C0 C0C300C0 C0C381C0 C0C1C380 C0C0C300 C0C0C300 C0C0C300 -C0C0C300 C0C06300 C0C06300 C0C03300 C0C03300 C0C03F00 C0C01F00 -C0C00F00 C1C00F00 FF800F00 3F000600 00000000 00000000 >getsymb -131< 0000 0000 000C 0018 0030 00E0 0380 0000 1FC0 09FC 181C 1000 3000 -2000 7F00 6FE0 E000 C000 C000 8000 C000 F000 3E00 07F0 0000 0000 ->getsymb -130< 00000000 00000000 003FC000 00FFE000 07F03000 0FC03800 1F000C00 -3B000E00 33000000 73000000 63000000 63000000 C3000000 C3000000 -C3000000 C3000000 C3000000 C3000000 C3000000 C3000000 C3000000 -C3000000 C3000000 C3000000 C6000000 CC000200 7C000C00 3C001C00 -07003000 03807000 01FFE000 00FF8000 00000000 00000000 >getsymb -129< 00000000 00000000 000F0000 001F8000 0030C000 0030C000 0010C000 -001F0000 00000000 00000000 000C0000 000E0000 000E0000 000F0000 -00338000 00338000 0040C000 00C0C000 00FFC000 00FFE000 0101E000 -03003000 04003800 0C003800 10000C00 30000C00 60000E00 60000E00 -C0000600 C0000700 00000000 00000000 >getsymb -128< 00000000 00000000 00C00000 00E0E000 00E0E000 0070F000 00000000 -00000000 00000000 00000000 00030000 00030000 00038000 0003C000 -000CE000 000CF000 00383000 00303800 0037FC00 003FBC00 00C00C00 -00C00E00 03000700 03000300 0C000380 0C000180 3C0000C0 380000C0 -E0000060 C0000060 00000000 00000000 >getsymb -126< 00000000 00000000 00001000 00003000 00004000 1C018000 3E030000 -63060000 819C0000 00F00000 00600000 00000000 00000000 >getsymb -125< 0000 0000 0780 1FE0 3870 0030 0030 0030 0030 0030 0030 0070 0060 -0040 0060 0030 0018 001C 0070 0060 0040 00C0 00C0 00C0 00C0 00C0 00C0 -0060 0020 0030 C030 7060 1DE0 0F80 0000 0000 >getsymb -124< 0000 0000 6000 6000 6000 6000 6000 6000 6000 6000 6000 6000 6000 -6000 6000 6000 6000 C000 C000 C000 C000 C000 C000 C000 C000 C000 C000 -C000 C000 4000 0000 0000 >getsymb -123< 00000000 00000000 00F80000 03FC0000 07020000 06000000 0C000000 -0C000000 0C000000 0C000000 0C000000 0C000000 18000000 18000000 -70000000 E0000000 38000000 0C000000 0C000000 0C000000 0C000000 -0C000000 0C000000 0C000000 18000000 18000000 30000000 30000000 -30040000 183C0000 1CF00000 07800000 00000000 00000000 >getsymb -122< 00000000 00000000 03020000 078E0000 0CFC0000 186C0000 30080000 -30180000 60300000 C0306000 0060C000 0040C000 00C18000 00818000 -01830000 01030000 03060000 078C0000 0CF80000 18300000 00000000 -00000000 >getsymb -121< 00000000 00000000 0600C000 0600C000 0C00C000 1C00C000 3C018000 -38038000 78038000 D8031800 18031000 18073000 180F2000 181B6000 -1C334000 0E62C000 07C78000 00070000 00060000 000E0000 001E0000 -00360000 00660000 00C60000 01860000 01860000 01840000 018C0000 -00F80000 00700000 00000000 00000000 >getsymb -120< 00000000 00000000 0C000000 1E030000 1B078000 330C8000 31180000 -61B00000 C1B01800 01A03000 01E02000 00C06000 00C04000 00C0C000 -01C08000 63418000 36670000 3C3E0000 18180000 00000000 00000000 ->getsymb -119< 00000000 00000000 18004000 38084000 6C186000 4C186000 CC186040 -08183980 18183F00 18183600 18183000 18383000 18683000 18682000 -0C4C2000 0ECC6000 0386C000 01838000 00000000 00000000 >getsymb -118< 00000000 00000000 18180000 3C1C0000 6C0C0000 4E0E0000 C6073000 -0607E000 0606C000 0C020000 0C030000 0C030000 0C030000 0C030000 -0C060000 040C0000 06180000 06300000 03E00000 01800000 00000000 -00000000 >getsymb -117< 00000000 00000000 00004000 0E00C000 1E00C000 13018000 33018000 -63030000 43030000 C3030300 03030600 06030600 06070C00 06070C00 -060F0C00 06099800 06199800 07309000 03E0F000 01C06000 00000000 -00000000 >getsymb -116< 00000000 00000000 00100000 00300000 00300000 00700000 00F00000 -01B00000 01300000 03300000 06200000 06200000 0C600000 18600000 -18400000 30400000 60400000 C6460000 0F4C0000 11580000 10F00000 -1FC00000 0CC00000 00800000 00800000 00800000 00800000 00800000 -00800000 00000000 00000000 >getsymb -115< 00000000 00000000 00C00000 01C00000 07600000 1C600000 30300000 -60304000 C010C000 00198000 00198000 001B0000 000F0000 000E0000 -000C0000 00180000 00300000 00600000 18C00000 0F800000 07000000 -00000000 00000000 >getsymb -114< 00000000 00000000 0C100000 1E300000 33F00000 31900000 60300000 -60600000 C0410000 80C20000 01860000 030C0000 03180000 03180000 -03300000 06300000 06200000 06600000 06400000 06C00000 07800000 -03000000 00000000 00000000 >getsymb -113< 00000000 00000000 00004000 00FCC000 03FEC000 0F06C000 3C03C200 -78018600 D8018400 10038C00 30078C00 30058800 300D9800 30099800 -30119800 38333000 18633000 0FC23000 07062000 00066000 00064000 -000CC000 000CC000 000D8000 000D0000 000D0000 000F0000 000E0000 -00060000 00000000 00000000 >getsymb -112< 00000000 00000000 00380000 0C7C0000 1EC60000 36C20000 67830000 -67030180 C6010300 06018600 06018400 0E018C00 0C008800 0C00D800 -0C007000 0C002000 0C000000 0C000000 0C000000 18000000 18000000 -18000000 18000000 18000000 18000000 18000000 18000000 18000000 -10000000 10000000 00000000 00000000 >getsymb -111< 00000000 00000000 00F00000 03FC0000 079E0000 1F070000 3C038000 -7803C000 D8016C00 18013800 18018000 18018000 0C018000 0C010000 -06030000 06060000 030C0000 01F80000 00F00000 00000000 00000000 ->getsymb -110< 00000000 00000000 0E0E0000 1F1F0000 33B30000 21A18000 61E18000 -C1C18180 81818180 01818300 03018300 03018600 07018600 06018400 -0E018C00 0C00CC00 0C007800 0C003000 00000000 00000000 >getsymb -109< 000000000000 000000000000 000000E00000 060001F00000 0F1E01300000 -19BF03180000 31E382180000 31C0C6180000 6180C4180000 C180CC183000 -8180C8186000 0180D8186000 0180F018C000 0180E0198000 0380C0190000 -0300C01B0000 0601800E0000 0601800E0000 060180040000 060180000000 -000000000000 000000000000 >getsymb -108< 0000 0000 0700 0F80 08C0 18C0 18C0 18C0 30C0 30C0 30C0 3080 3180 -3300 3600 3600 3C00 3800 3008 7018 F030 B020 3060 3040 30C0 30C0 3080 -1980 1F00 0E00 0000 0000 >getsymb -107< 00000000 00000000 00300000 00F80000 018C0000 018C0000 030C0000 -030C0000 03180000 03300000 03600000 03C00000 03800000 03000000 -07000000 0F000000 1B1E0000 323F0000 66618000 C6C18600 86C30C00 -078E1800 07383000 07E03000 07806000 06C06000 0C60C000 0C20C000 -0C318000 18330000 181E0000 180C0000 00000000 00000000 >getsymb -106< 0000 0000 0080 0300 0300 0000 0000 0600 0600 0600 0E00 1E00 1600 -3600 6610 C630 8660 06C0 0780 0700 0600 0E00 1E00 3600 6600 6600 C600 -C600 C600 C600 C600 C600 CC00 CC00 CC00 7800 3000 0000 0000 >getsymb -105< 0000 0000 0600 0600 0200 0000 0000 0000 0000 0000 0000 0C00 1800 -1800 3000 3000 7008 F018 B030 3060 3060 30C0 30C0 3180 3180 1B00 1E00 -1C00 0800 0000 0000 >getsymb -104< 00000000 00000000 01E00000 03300000 03180000 02180000 06180000 -06180000 06180000 06300000 06200000 06600000 06C00000 07800000 -07000000 0E000000 1E000000 36000000 66000000 C6000300 06380600 -067C0600 06C60C00 07830C00 07030C00 06031800 06031800 06031800 -0C033000 0C033000 1801E000 1800C000 00000000 00000000 >getsymb -103< 00000000 00000000 00300000 00F88000 038D8000 06070000 0C030000 -18070000 38070000 780F0000 D81B0600 98330C00 18331800 18633000 -0CC36000 0783C000 03078000 000F0000 003B0000 00630000 00C30000 -01830000 03060000 06060000 06060000 060C0000 06180000 03F00000 -01E00000 00000000 00000000 >getsymb -102< 0000 0000 0380 07C0 0CC0 08C0 18C0 18C0 1980 1980 1900 1B00 1A00 -1C00 1C00 1800 3800 3800 5800 D818 1C70 1FC0 1E00 1B00 1980 18C0 18C0 -1860 1860 1860 1860 1860 1860 1860 1860 18C0 18C0 0C80 0F80 0700 0000 -0000 >getsymb -101< 00000000 00000000 03E00000 0FF80000 1C1C0000 300C0000 200C0000 -600C0000 60380000 40E00000 C7800000 DE000400 F0000C00 E0001800 -60003000 30006000 3000C000 18018000 08030000 0C060000 079C0000 -03F80000 00E00000 00000000 00000000 >getsymb -100< 00000000 00000000 00004000 00004000 00004000 0000C000 0000C000 -0000C000 0000C000 00018000 00018000 00018000 01E18000 07F18000 -0C1B8000 181F0000 180F0000 30060000 70060000 F0020300 B0060600 -30060400 300E0C00 300B0C00 101B1800 18319800 0C61B000 07C1F000 -0380E000 00000000 00000000 >getsymb -99< 00000000 00000000 01F00000 07380000 0E0C0000 0C040000 18000000 -30000000 70000000 F0001000 30003000 30006000 30004000 3000C000 -30018000 18018000 18030000 0E0E0000 07380000 01F00000 00000000 -00000000 >getsymb -98< 00000000 00000000 00600000 00F00000 01980000 010C0000 030C0000 -030C0000 03180000 02100000 06300000 06600000 07C00000 07000000 -06000000 0E000000 1E000000 36000000 66008000 C600C300 0601FE00 -0601B800 02018000 03018000 03018000 01010000 01830000 00C60000 -007C0000 00380000 00000000 00000000 >getsymb -97< 00000000 00000000 01E08000 03F98000 060D8000 0C070000 18060000 -10060000 30060000 70060000 E0060600 E00C0400 600C0C00 600C1800 -201C1000 30163000 30366000 18366000 18624000 0FC3C000 07818000 -00000000 00000000 >getsymb -96< 0000 0000 1800 3000 3000 6000 6000 C000 C000 C000 C000 6000 3000 -1800 0400 0000 0000 >getsymb -95< 00000000 00000000 FF800000 3FFFFF00 00FFFF80 00000000 00000000 ->getsymb -94< 00000000 00000000 00700000 01F80000 038C0000 06060000 1C030000 -3001C000 6000E000 C0003000 00001800 00000C00 00000000 00000000 ->getsymb -93< 0000 0000 3FC0 FFC0 00C0 00C0 00C0 00C0 00C0 00C0 00C0 00C0 00C0 -00C0 00C0 00C0 00C0 00C0 00C0 00C0 00C0 00C0 00C0 00C0 00C0 00C0 00C0 -00C0 00C0 0180 0180 3F80 7F00 0000 0000 >getsymb -92< 00000000 00000000 E0000000 70000000 30000000 18000000 18000000 -0C000000 0C000000 0E000000 06000000 06000000 03000000 03000000 -01800000 01800000 00C00000 00C00000 00400000 00600000 00600000 -00200000 00300000 00180000 00180000 00180000 000C0000 000E0000 -00060000 00070000 00038000 0000C000 00000000 00000000 >getsymb -91< 0000 0000 7800 7F00 63C0 6000 6000 6000 6000 6000 6000 6000 6000 -6000 6000 6000 6000 6000 6000 6000 C000 C000 C000 C000 C000 C000 C000 -C000 E000 7C00 7F00 0000 0000 >getsymb -90< 00000000 00000000 0C01F000 3E07B000 630C2000 41F86000 8070C000 -00018000 00030000 00060000 00040000 000C0000 00180000 00180000 -00300000 07E00000 00FC0000 00C00000 00800000 01800040 030000C0 -03000180 06000180 06000300 0C780600 09F80600 1B0F0C00 1E039800 -3C00F000 70007000 00000000 00000000 >getsymb -89< 00000000 00000000 00002000 00002000 20002000 70006000 C8006000 -CC006000 CC00C000 8C00C000 0C00C000 0C00C000 0C00C000 0C00C000 -0C01C000 0C01C000 0403C000 0602C000 0602C600 0604CC00 021CD800 -03F0F000 01C0E000 0001C000 0003C000 0006C000 000CC000 0018C000 -0030C000 00608000 00418000 00C30000 00860000 008C0000 00D80000 -00700000 00000000 00000000 >getsymb -88< 00000000 00000000 1F000000 31C00C00 30601E00 30303300 30387100 -18186000 0C18C000 000CC000 000C8000 000D8000 000F8000 000F0000 -000F0000 00070000 00060000 00060000 00060000 00060000 00060060 -000600C0 00060080 000F0180 400F0180 C01F0180 C0198100 C0318300 -6030C300 20604200 30C06600 1C803C00 0F801800 03000000 00000000 -00000000 >getsymb -87< 000000000000 000000000000 100000000000 780000000000 4C0000000000 -8C0000000000 0C0030000000 0C00300000C0 0C00600001A0 0C0060000100 -0C0060000300 0C0060000300 0C00C0000300 0C00C0000300 1800C0000300 -1800C0000300 1001C0000600 3001C0000600 3003C0000C00 3003C0000C30 -3006C0001860 300CC00030C0 3018C00020C0 3018C0006180 3030C000C380 -1830C0018700 1860C0019C00 0CC0C003F800 0F80600FE000 0600703E0000 -00003FF00000 00000FC00000 000000000000 000000000000 >getsymb -86< 00000000 00000000 30000100 78000380 CC0003F0 8C000360 0C000300 -0C000300 0C000300 0C000300 0C000600 0C000600 0C000600 0C000600 -0C000C00 06000C00 06000C00 06000C00 06001800 06001818 06001070 -060011E0 06003F80 06007C00 0300F000 0187C000 01FF0000 00780000 -00000000 00000000 >getsymb -85< 000000000000 000000000000 300003000000 780003000000 CC0003000000 -8C0003000000 0C0003000000 0C0003000000 180006000000 180006000000 -180006000000 300006000000 300006000000 300006000000 30000C000000 -30000C000000 300018000000 300018000000 300030000000 300070060000 -3000700C0000 3000F0180000 1801B0180000 180318300000 0C0618600000 -0F0C0CC00000 03F807800000 01F003000000 000000000000 000000000000 ->getsymb -84< 00000000 00000000 0F800100 3FC00200 607E0C00 803FF800 000CE000 -000C0000 000C0000 000C0000 00060000 00060000 00030000 00030000 -00030000 00030000 00030000 00030000 000300C0 00030180 02030300 -02030300 02030600 03030C00 01833800 01C7F000 00FF8000 003C0000 -00000000 00000000 >getsymb -83< 00000000 00000000 00F00000 01FC0000 031E0000 02030000 06018000 -0600C000 06004000 06004000 06008000 03000000 03800000 00F00000 -003C0000 000F0000 00038000 00018000 0000C600 00006400 00006C00 -00003800 00003000 20007000 70006000 9C00C000 06038000 030F0000 -03FC0000 01F80000 00000000 00000000 >getsymb -82< 00000000 00000000 020FE000 033FF800 03F80C00 03C00600 07000300 -0F000300 1B000300 3B000300 33000600 33000C00 63003800 6300E000 -43038000 C30F0000 C3FC0000 C3FE0000 C3070018 C6070030 CC038060 -4C01C0C0 7C00C080 7C006180 38006180 38006100 38003300 38003300 -38001E00 38001E00 30000C00 10000000 00000000 00000000 >getsymb -81< 00000000 00000000 001FE000 007FF000 01C03800 03001C00 06000C00 -0C000C00 0C000C00 18000C00 18000600 10000600 30000300 30000300 -30000300 30000300 60000300 60000200 60000600 C0000600 C000060C -C000060C C0000C18 C0000C18 C0001830 603C3020 304E7060 3083C040 -1C01E0C0 0E037180 03FE1F00 00FC0E00 00000000 00000000 >getsymb -80< 00000000 00000000 03FC0000 0FFF0000 3C01C000 7C007000 4C003800 -8C001800 0C000C00 0C000C00 0C000C00 0C000C00 06000C00 06000800 -06001800 06003000 261FE000 1FFF8030 0F800060 060000C0 06000180 -06000300 06000E00 06003800 0600F000 0603C000 0C0F0000 0C3C0000 -0FF00000 1FC00000 00000000 00000000 >getsymb -79< 00000000 00000000 00FE0000 01FF8000 0700C000 0E00C000 0C006000 -18003000 30003000 30003000 70003000 60001800 40001C00 C0000C00 -C0000C00 C0000C00 C0000600 C0000600 C0000700 C0000730 C00006E0 -C0000600 60000600 60000600 30000400 30000C00 30001800 18003000 -0C006000 0C00C000 06018000 060F0000 03FC0000 00F00000 00000000 -00000000 >getsymb -78< 000000000000 000000000000 1E0380000000 3F07E0000000 631C38000000 -81B81C000000 00F00C000000 00E006000000 00C002000000 00C003000000 -00C003000000 01C003000000 018003000000 018003000000 030003000000 -030003000000 030003800000 030001800000 030001800400 030001800800 -030001801800 060001803000 060000806000 0C0000C0C000 0C0000C0C000 -0C0000C18000 0C0000C30000 0C0000C60000 0000007C0000 000000380000 -000000000000 000000000000 >getsymb -77< 000000000000 000000000000 070180000000 1F83C0000000 7186600F0000 -E0C6703F8000 00C43030C000 00CC1860C000 00CC18606000 00C808C06000 -00F80CC02000 00F006803000 00F007803000 00E007803000 00E003803000 -00E003003000 00E003003000 00E003006000 00E003006000 00E003006060 -00E0030060C0 00E0030060C0 00E003006180 00E003006180 00E003006100 -00E003006300 00C001006200 00C001006600 00C001003C00 00C001001800 -000000000000 000000000000 >getsymb -76< 00000000 00000000 00300000 00780000 004C0000 00CC0000 00CC0000 -00CC0000 00CC0000 00D80000 00F00000 00E00000 01C00000 03C00000 -0EC00000 38C00000 60C00000 C0C00000 00C00000 00C00300 00C00600 -00C00C00 00C00C00 00C01800 0FE01800 1FF03000 31B83000 331C6000 -1E07C000 0C038000 00000000 00000000 >getsymb -75< 00000000 00000000 18300060 3C7800C0 664C0300 43CC0600 838C1C00 -010C3800 000C6000 000CC000 000F8000 000F0000 00098000 0018C000 -00186000 00186000 00183000 00183000 00183018 00301830 00301830 -00201860 00600C60 20C00CC0 218004C0 330006C0 1E000380 0C000300 -00000000 00000000 >getsymb -74< 00000000 00000000 00040000 180E0000 3E1B0000 23198000 63318000 -C1B18000 C1E18000 80C18000 80018000 00030000 00030000 00060000 -00060000 00060000 00060000 00062000 00066000 0006C000 00078000 -00070000 00060000 000C0000 001C0000 003C0000 006C0000 00CC0000 -018C0000 030C0000 060C0000 0C0C0000 0C0C0000 0C0C0000 0C0C0000 -0C180000 0C180000 06180000 03980000 03F80000 00F00000 00000000 -00000000 >getsymb -73< 00000000 00000000 000C0000 1C3C0000 36660000 63C60000 41860000 -80060000 80060000 00060000 00060000 000C0000 000C0000 000C0000 -000C0000 000C0000 000C0000 00180000 00183000 00186000 00186000 -0018C000 80198000 801F0000 C03C0000 60700000 3FC00000 1F800000 -00000000 00000000 >getsymb -72< 000000000000 000000000000 000001800000 000007C00000 1C100C600000 -3E3808600000 67D818600000 439818600000 801818400000 801818C00000 -001818800000 001819800000 00181F000000 00181C000000 001878000000 -001BF0000000 007E30000000 00F830000000 019830000000 031860030000 -061860060000 0618600C0000 0C18600C0000 181860180000 181860180000 -181060300000 183030300000 186030600000 0FC018600000 070008C00000 -00000F800000 000007000000 000000000000 000000000000 >getsymb -71< 00000000 00000000 00180000 00FF0000 03C78000 0600E000 0C003000 -18001000 30000000 30000000 60000000 E0000000 C0000000 C0000000 -C0000000 C0000000 C0000000 60008000 60018000 30038030 30078060 -180F80C0 081D8380 0C310700 07E31C00 03C37000 0003C000 001F8000 -007F0000 01E30000 03830000 07030000 06060000 0C060000 0C040000 -0C0C0000 0C180000 0C100000 06300000 03E00000 01C00000 00000000 -00000000 >getsymb -70< 00000000 00000000 0801FC00 0C0FF800 3FFE0000 FFF00000 8C000000 -0C000000 0C000000 04000000 06000000 06000000 03000000 0303F000 -03FF8000 03FC0000 03000000 02000000 06000000 06000600 04000C00 -0C001800 0C003000 0C00E000 18078000 180F0000 1FF80000 3FE00000 -00000000 00000000 >getsymb -69< 00000000 00000000 03FC0000 07FF0000 1C038000 3C01C000 3000C000 -30004000 30000000 38000000 1E000000 0E000000 03F00000 01F80000 -03800000 0E000000 18000000 30000000 60000000 60000300 C0000600 -C0000600 C0000C00 C0000C00 C0001800 70003000 3800E000 1E01C000 -07FF0000 01FC0000 00000000 00000000 >getsymb -68< 00000000 00000000 07FE0000 1FFF8000 3060C000 30C06000 30C03000 -19801800 19800800 0D000C00 07000400 07000600 03000300 03800300 -06C00300 06600300 06300300 061C0300 0C06030C 0C038318 1C01C670 -18007FC0 30003F00 3E001800 3B803000 71F0E000 C03FC000 C01F8000 -00000000 00000000 >getsymb -67< 00000000 00000000 007F8000 01FFE000 07007000 0C003000 18001800 -38001800 30001800 60003000 60006000 6011C000 C01F0000 C0060000 -C0000000 C0000000 C0000000 C0000000 C0000000 C0000000 C00000C0 -C0000180 C0000180 60000300 60000300 60000600 30000C00 38003800 -1E00E000 0F03C000 01FF0000 00FE0000 00000000 00000000 >getsymb -66< 00000000 00000000 03FC0000 0FFF0000 1B818000 2300C000 0300C000 -0300C000 0300C000 06018000 06038000 060F0000 041C0000 04700000 -0CF00000 0C1C0000 0C0F0000 0C078000 0C00C000 0C00600C 0C003018 -0C003818 0C001C30 0C000C30 0C000CE0 0C000DC0 18001F00 18001E00 -30003800 30007000 F800C000 7F018000 47FF0000 00FE0000 00000000 -00000000 >getsymb -65< 00000000 00000000 001E0400 007F0C00 01C1C800 0300E800 06003800 -0C003000 18003000 10003000 30003000 60006000 60006000 60006000 -C0006000 C0006000 C000C000 C000C030 C000C060 C000C0C0 4000C180 -6000C300 2001C300 3001C600 3803C600 1802CC00 0C06CC00 06046C00 -039C7800 00F83000 00000000 00000000 >getsymb -64< 00000000 00000000 001F0000 00FFE000 07C0F000 0F001800 1C000C00 -18000C00 30000700 70000300 60000180 60000180 400E0180 401F8180 -C030C180 C070C180 C0C04180 C1C0C180 C180C180 8300C180 C301C180 -C3018100 43018300 61018300 2186EE00 30CE7C00 107C0000 18000000 -0C000000 06000000 0300E000 01FFC000 007E0000 00000000 00000000 ->getsymb -63< 0000 0000 1E00 3F00 6180 C0C0 8060 8020 C030 6030 1030 0020 0060 -00C0 0180 0300 0200 0400 0C00 0800 1800 1000 3000 3000 1800 0000 0000 -0000 1800 1C00 0000 0000 >getsymb -62< 00000000 00000000 C0000000 60000000 30000000 18000000 0C000000 -06000000 03000000 01800000 00C00000 00600000 00380000 001C0000 -00060000 00030000 00070000 001C0000 00700000 01C00000 07000000 -0E000000 38000000 60000000 C0000000 80000000 00000000 00000000 ->getsymb -61< 00000000 00000000 FFE00000 FFFFF000 001FF000 00000000 00000000 -00000000 00000000 00000000 00000000 FFFFC000 FFFFC000 00000000 -00000000 >getsymb -60< 00000000 00000000 00018000 000F0000 00380000 00E00000 03800000 -06000000 0C000000 10000000 30000000 E0000000 60000000 20000000 -30000000 18000000 0C000000 06000000 03000000 01800000 00E00000 -00380000 000E0000 00038000 00000000 00000000 >getsymb -59< 0000 0000 1800 3800 3000 2000 0000 0000 0000 0000 0000 0000 0000 -0000 0000 0000 0C00 0600 0600 0600 0600 1C00 3000 E000 8000 0000 0000 ->getsymb -58< 0000 0000 6000 F000 C000 C000 0000 0000 0000 0000 0000 0000 0000 -0000 0000 0000 0000 8000 F000 E000 0000 0000 >getsymb -57< 00000000 00000000 03F00000 0FFC0000 180E0000 38060000 60020000 -C0030000 C0030000 C0030000 C0030000 C0030000 C0020000 40060000 -60060000 601E0000 30340000 18640000 0FEC0000 078C0000 00080000 -00080000 00180000 00180000 00100000 80300000 C0300000 70600000 -1FC00000 0F000000 00000000 00000000 >getsymb -56< 00000000 00000000 007C0000 00C60000 01820000 03030000 03010000 -03010000 03010000 03030000 01030000 01030000 03860000 0F8E0000 -18F80000 30700000 60100000 60180000 60080000 C0080000 C0080000 -C0180000 40180000 60300000 3FE00000 0FC00000 00000000 00000000 ->getsymb -55< 0000 0000 0008 3078 78F8 CC98 8798 0710 0030 0030 0020 0060 0040 -00C0 0080 3980 0FE0 03F8 0300 0300 0600 0600 0600 0C00 0800 1800 3000 -6000 6000 4000 4000 0000 0000 >getsymb -54< 00000000 00000000 00040000 001C0000 00300000 00E00000 01800000 -03000000 06000000 0C000000 08000000 18F00000 33F80000 360E0000 -6C070000 78010000 60018000 60018000 C000C000 C000C000 C000C000 -C0008000 C0018000 60010000 30030000 18060000 1C0C0000 0F180000 -03F00000 00000000 00000000 >getsymb -53< 00000000 00000000 01FF0000 03FF0000 03000000 03000000 06000000 -06000000 06000000 06000000 06000000 03C00000 00F80000 001C0000 -000E0000 00030000 00030000 00030000 000E0000 E01C0000 70300000 -3FE00000 0F800000 00000000 00000000 >getsymb -52< 0000 0000 8018 8018 C018 C018 C018 C018 C018 FF18 3FF8 01F8 0030 -0030 0070 0060 0060 0060 00E0 00C0 00C0 0080 0080 0000 0000 >getsymb -51< 00000000 00000000 01E00000 07F00000 0E180000 0C0C0000 000C0000 -000C0000 00180000 00300000 00600000 00C00000 00780000 001E0000 -00070000 00018000 0001C000 0000C000 8000C000 C0018000 C0070000 -7C0E0000 3FF80000 03F00000 00000000 00000000 >getsymb -50< 00000000 00000000 07800000 1FC00000 38600000 70300000 C0300000 -80100000 00100000 00100000 00300000 00300000 00200000 00600000 -00C00000 01800000 01000000 03000000 06000000 06000000 0F004000 -1DC08000 307F8000 303E0000 00000000 00000000 >getsymb -49< 0000 0000 3000 7800 9800 1800 1800 1800 1800 1800 1800 1800 1800 -3000 3000 3000 3000 3000 3000 3000 3000 3000 0000 0000 >getsymb -48< 00000000 00000000 00E00000 03F80000 0E180000 180C0000 30060000 -30060000 60020000 E0030000 C0030000 C0030000 C0030000 C0030000 -C0030000 C0030000 C0020000 60060000 60060000 20040000 300C0000 -18180000 0C180000 07F00000 01E00000 00000000 00000000 >getsymb -47< 00000000 00000000 00040000 00060000 000C0000 000C0000 00180000 -00180000 00180000 00300000 00300000 00200000 00600000 00600000 -00C00000 00C00000 01800000 01800000 03000000 03000000 06000000 -06000000 0C000000 0C000000 18000000 18000000 38000000 30000000 -60000000 60000000 60000000 C0000000 80000000 00000000 00000000 ->getsymb -46< 0000 0000 8000 C000 E000 C000 0000 0000 >getsymb -45< 0000 0000 F000 7FF0 07F0 0000 0000 >getsymb -44< 0000 0000 1000 1800 0C00 0C00 0C00 0C00 0800 1800 3000 6000 8000 -0000 0000 >getsymb -43< 00000000 00000000 00100000 00100000 00300000 00300000 00300000 -00300000 00300000 0033E000 3FFFC000 FFFC0000 00300000 00300000 -00300000 00300000 00300000 00300000 00600000 00600000 00400000 -00400000 00000000 00000000 >getsymb -42< 00000000 00000000 30180000 18300000 0C600000 04C00000 0FFE0000 -3FF80000 EC600000 86200000 06300000 03180000 03000000 01000000 -00000000 00000000 >getsymb -41< 0000 0000 6000 F000 1C00 0E00 0300 0180 0080 00C0 00C0 00C0 00C0 -00C0 0060 0060 0060 0060 0060 0060 0060 00C0 00C0 00C0 00C0 00C0 0080 -0180 0380 0300 0600 0C00 1800 7000 0000 0000 >getsymb -40< 0000 0000 0700 0E00 1800 3000 2000 6000 6000 6000 6000 6000 C000 -C000 C000 C000 C000 C000 C000 C000 6000 6000 6000 6000 3000 3000 1800 -1800 0C00 0600 0700 0380 0000 0000 >getsymb -39< 0000 0000 2000 3000 1800 1800 0C00 0C00 0C00 1800 3000 3000 6000 -4000 8000 0000 0000 >getsymb -38< 00000000 00000000 0F000000 1F800000 30C00000 20600000 20300000 -30300000 18200000 18400000 0CC00000 05800000 0F000000 1F000000 -19820000 30C20000 60660000 602C0000 C0380000 C0300000 C0300000 -C0780000 60680000 61CC0000 3F0C0000 1E040000 00060000 00000000 -00000000 >getsymb -37< 00000000 00000000 0E03C000 3FDF8000 61F30000 60C70000 C0C60000 -C0CC0000 618C0000 630C0000 3E180000 0C300000 00300000 00600000 -00600000 00C00000 01C00000 03800000 0307C000 060FE000 0C3C2000 -18F03000 31E03000 37603000 6CC03000 78C06000 E0F0C000 C07FC000 -000F0000 00000000 00000000 >getsymb -36< 00000000 00000000 01040000 03040000 030C0000 030C0000 030C0000 -037C0000 03DE0000 0F0F0000 0E0D8000 1A0C8000 360C0000 260C0000 -260C0000 1E0C0000 1FCC0000 07FC0000 043C0000 040E0000 8C0F8000 -CC0FC000 7C0C4000 1C0C6000 0E0CE000 0FFFC000 0CFE0000 0C180000 -0C180000 0C180000 0C180000 0C180000 0C100000 08100000 08100000 -08100000 00100000 00000000 00000000 >getsymb -35< 00000000 00000000 00430000 00430000 00C30000 00C30000 00C30000 -00C30000 00C3F000 00FFF000 1FFF0000 3F870000 018C0000 018C0000 -018C0000 018C0000 030C0000 030FC000 7FFFC000 FFF80000 06180000 -06180000 06180000 0C180000 0C180000 0C100000 00000000 00000000 ->getsymb -34< 0000 0000 8300 6180 30C0 10C0 10C0 10C0 3180 6300 C000 8000 0000 -0000 >getsymb -33< 0000 0000 4000 6000 6000 6000 6000 6000 6000 6000 6000 6000 6000 -6000 6000 6000 6000 6000 E000 C000 C000 C000 C000 C000 C000 8000 0000 -0000 0000 C000 C000 4000 0000 0000 >getsymb -Hwfdict begin - /BuildChar - Chread -end -/Joepie Hwfdict definefont -%%EndFont Joepie\n\n")) - -;;Sets page numbering off -(defun handwrite-set-pagenumber-off () - (setq handwrite-pagenumbering nil) - (define-key menu-bar-handwrite-map - [numbering] - '("Page numbering Off" . handwrite-set-pagenumber)) - (message "page numbering off")) - -;;Sets page numbering on -(defun handwrite-set-pagenumber-on () - (setq handwrite-pagenumbering t) - (define-key menu-bar-handwrite-map - [numbering] - '("Page numbering On" . handwrite-set-pagenumber)) - (message "page numbering on" )) - - -;; Key bindings - - -(define-key-after - (lookup-key global-map [menu-bar edit]) - [handwrite] - '("Write by hand" . menu-bar-handwrite-map) - 'spell) - -(define-key menu-bar-handwrite-map [numbering] - '("Page numbering Off" . handwrite-set-pagenumber)) - -(define-key menu-bar-handwrite-map [10pt] - '("10 pt" . handwrite-10pt)) - -(define-key menu-bar-handwrite-map [11pt] - '("11 pt *" . handwrite-11pt)) - -(define-key menu-bar-handwrite-map [12pt] - '("12 pt" . handwrite-12pt)) - -(define-key menu-bar-handwrite-map [13pt] - '("13 pt" . handwrite-13pt)) - -(define-key menu-bar-handwrite-map [handwrite] - '("Write by hand" . handwrite)) - -(define-key-after - (lookup-key menu-bar-handwrite-map [ ]) - [handwrite-separator1] - '("----" . nil) - 'handwrite) - -(define-key-after - (lookup-key menu-bar-handwrite-map [ ]) - [handwrite-separator2] - '("----" . nil) - '10pt) - - -(provide 'handwrite) - - -;;; handwrite.el ends here diff --git a/lisp/play/hanoi.el b/lisp/play/hanoi.el deleted file mode 100644 index ba74a2ba645..00000000000 --- a/lisp/play/hanoi.el +++ /dev/null @@ -1,227 +0,0 @@ -;;; hanoi.el --- towers of hanoi in GNUmacs - -;; Author: Damon Anton Permezel -;; Maintainer: FSF -;; Keywords: games - -; Author (a) 1985, Damon Anton Permezel -; This is in the public domain -; since he distributed it without copyright notice in 1985. - -;;; Commentary: - -;; Solves the Towers of Hanoi puzzle while-U-wait. -;; -;; The puzzle: Start with N rings, decreasing in sizes from bottom to -;; top, stacked around a post. There are two other posts. Your mission, -;; should you choose to accept it, is to shift the pile, stacked in its -;; original order, to another post. -;; -;; The challenge is to do it in the fewest possible moves. Each move -;; shifts one ring to a different post. But there's a rule; you can -;; only stack a ring on top of a larger one. -;; -;; The simplest nontrivial version of this puzzle is N = 3. Solution -;; time rises as 2**N, and programs to solve it have long been considered -;; classic introductory exercises in the use of recursion. -;; -;; The puzzle is called `Towers of Hanoi' because an early popular -;; presentation wove a fanciful legend around it. According to this -;; myth (uttered long before the Vietnam War), there is a Buddhist -;; monastery at Hanoi which contains a large room with three time-worn -;; posts in it surrounded by 21 golden discs. Monks, acting out the -;; command of an ancient prophecy, have been moving these disks, in -;; accordance with the rules of the puzzle, once every day since the -;; monastery was founded over a thousand years ago. They are said -;; believe that when the last move of the puzzle is completed, the -;; world will end in a clap of thunder. Fortunately, they are nowhere -;; even close to being done... - -;;; Code: - -;;; -;;; hanoi-topos - direct cursor addressing -;;; -(defun hanoi-topos (row col) - (goto-line row) - (beginning-of-line) - (forward-char col)) - -;;; -;;; hanoi - user callable Towers of Hanoi -;;; -;;;###autoload -(defun hanoi (nrings) - "Towers of Hanoi diversion. Argument is number of rings." - (interactive "p") - (if (<= nrings 1) (setq nrings 7)) - (let* (floor-row - fly-row - (window-height (1- (window-height (selected-window)))) - (window-width (window-width (selected-window))) - - ;; This is half the spacing to use between poles. - (pole-spacing (/ window-width 6))) - (if (not (and (> window-height (1+ nrings)) - (> pole-spacing nrings))) - (progn - (delete-other-windows) - (if (not (and (> (setq window-height - (1- (window-height (selected-window)))) - (1+ nrings)) - (> (setq pole-spacing (/ window-width 6)) - nrings))) - (error "Window is too small (need at least %dx%d)" - (* 6 (1+ nrings)) (+ 2 nrings))))) - (setq floor-row (if (> (- window-height 3) (1+ nrings)) - (- window-height 3) window-height)) - (let ((fly-row (- floor-row nrings 1)) - ;; pole: column . fill height - (pole-1 (cons (1- pole-spacing) floor-row)) - (pole-2 (cons (1- (* 3 pole-spacing)) floor-row)) - (pole-3 (cons (1- (* 5 pole-spacing)) floor-row)) - (rings (make-vector nrings nil))) - ;; construct the ring list - (let ((i 0)) - (while (< i nrings) - ;; ring: [pole-number string empty-string] - (aset rings i (vector nil - (make-string (+ i i 3) (+ ?0 (% i 10))) - (make-string (+ i i 3) ?\ ))) - (setq i (1+ i)))) - ;; - ;; init the screen - ;; - (switch-to-buffer "*Hanoi*") - (setq buffer-read-only nil) - (buffer-disable-undo (current-buffer)) - (erase-buffer) - (let ((i 0)) - (while (< i floor-row) - (setq i (1+ i)) - (insert-char ?\ (1- window-width)) - (insert ?\n))) - (insert-char ?= (1- window-width)) - - (let ((n 1)) - (while (< n 6) - (hanoi-topos fly-row (1- (* n pole-spacing))) - (setq n (+ n 2)) - (let ((i fly-row)) - (while (< i floor-row) - (setq i (1+ i)) - (next-line 1) - (insert ?\|) - (delete-char 1) - (backward-char 1))))) - ;(sit-for 0) - ;; - ;; now draw the rings in their initial positions - ;; - (let ((i 0) - ring) - (while (< i nrings) - (setq ring (aref rings (- nrings 1 i))) - (aset ring 0 (- floor-row i)) - (hanoi-topos (cdr pole-1) - (- (car pole-1) (- nrings i))) - (hanoi-draw-ring ring t nil) - (setcdr pole-1 (1- (cdr pole-1))) - (setq i (1+ i)))) - (setq buffer-read-only t) - (sit-for 0) - ;; Disable display of line and column numbers, for speed. - (let ((line-number-mode nil) - (column-number-mode nil)) - ;; do it! - (hanoi0 (1- nrings) pole-1 pole-2 pole-3)) - (goto-char (point-min)) - (message "Done") - (setq buffer-read-only t) - (force-mode-line-update) - (sit-for 0)))) - -;;; -;;; hanoi0 - work horse of hanoi -;;; -(defun hanoi0 (n from to work) - (cond ((input-pending-p) - (signal 'quit (list "I can tell you've had enough"))) - ((< n 0)) - (t - (hanoi0 (1- n) from work to) - (hanoi-move-ring n from to) - (hanoi0 (1- n) work to from)))) - -;;; -;;; hanoi-move-ring - move ring 'n' from 'from' to 'to' -;;; -;;; -(defun hanoi-move-ring (n from to) - (let ((ring (aref rings n)) ; ring <- ring: (ring# . row) - (buffer-read-only nil)) - (let ((row (aref ring 0)) ; row <- row ring is on - (col (- (car from) n 1)) ; col <- left edge of ring - (dst-col (- (car to) n 1)) ; dst-col <- dest col for left edge - (dst-row (cdr to))) ; dst-row <- dest row for ring - (hanoi-topos row col) - (while (> row fly-row) ; move up to the fly row - (hanoi-draw-ring ring nil t) ; blank out ring - (previous-line 1) ; move up a line - (hanoi-draw-ring ring t nil) ; redraw - (sit-for 0) - (setq row (1- row))) - (setcdr from (1+ (cdr from))) ; adjust top row - ;; - ;; fly the ring over to the right pole - ;; - (while (not (equal dst-col col)) - (cond ((> dst-col col) ; dst-col > col: right shift - (end-of-line 1) - (delete-backward-char 2) - (beginning-of-line 1) - (insert ?\ ?\ ) - (sit-for 0) - (setq col (1+ (1+ col)))) - ((< dst-col col) ; dst-col < col: left shift - (beginning-of-line 1) - (delete-char 2) - (end-of-line 1) - (insert ?\ ?\ ) - (sit-for 0) - (setq col (1- (1- col)))))) - ;; - ;; let the ring float down - ;; - (hanoi-topos fly-row dst-col) - (while (< row dst-row) ; move down to the dest row - (hanoi-draw-ring ring nil (> row fly-row)) ; blank out ring - (next-line 1) ; move down a line - (hanoi-draw-ring ring t nil) ; redraw ring - (sit-for 0) - (setq row (1+ row))) - (aset ring 0 dst-row) - (setcdr to (1- (cdr to)))))) ; adjust top row - -;;; -;;; draw-ring - draw the ring at point, leave point unchanged -;;; -;;; Input: -;;; ring -;;; f1 - flag: t -> draw, nil -> erase -;;; f2 - flag: t -> erasing and need to draw ?\| -;;; -(defun hanoi-draw-ring (ring f1 f2) - (save-excursion - (let* ((string (if f1 (aref ring 1) (aref ring 2))) - (len (length string))) - (delete-char len) - (insert string) - (if f2 - (progn - (backward-char (/ (+ len 1) 2)) - (delete-char 1) (insert ?\|)))))) - -(provide 'hanoi) - -;;; hanoi.el ends here diff --git a/lisp/play/life.el b/lisp/play/life.el deleted file mode 100644 index 9645cb398df..00000000000 --- a/lisp/play/life.el +++ /dev/null @@ -1,283 +0,0 @@ -;;; life.el --- John Horton Conway's `Life' game for GNU Emacs - -;; Copyright (C) 1988 Free Software Foundation, Inc. - -;; Author: Kyle Jones <talos!kjones@uunet.uu.net> -;; Keywords: games - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; A demonstrator for John Horton Conway's "Life" cellular automaton -;; in Emacs Lisp. Picks a random one of a set of interesting Life -;; patterns and evolves it according to the familiar rules. - -;;; Code: - -(defconst life-patterns - [("@@@" " @@" "@@@") - ("@@@ @@@" "@@ @@ " "@@@ @@@") - ("@@@ @@@" "@@ @@" "@@@ @@@") - ("@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@") - ("@@@@@@@@@@") - (" @@@@@@@@@@ " - " @@@@@@@@@@ " - " @@@@@@@@@@ " - "@@@@@@@@@@ " - "@@@@@@@@@@ ") - ("@" "@" "@" "@" "@" "@" "@" "@" "@" "@" "@" "@" "@" "@" "@") - ("@ @" "@ @" "@ @" - "@ @" "@ @" "@ @" - "@ @" "@ @" "@ @" - "@ @" "@ @" "@ @" - "@ @" "@ @" "@ @") - ("@@ " " @@ " " @@ " - " @@ " " @@ " " @@ " - " @@ " " @@ " " @@ " - " @@ " " @@ " " @@ " - " @@ " " @@ " " @@ " - " @@") - ("@@@@@@@@@" "@ @ @" "@ @@@@@ @" "@ @ @ @" "@@@ @@@" - "@ @ @ @" "@ @@@@@ @" "@ @ @" "@@@@@@@@@")] - "Vector of rectangles containing some Life startup patterns.") - -;; Macros are used macros for manifest constants instead of variables -;; because the compiler will convert them to constants, which should -;; eval faster than symbols. -;; -;; Don't change any of the life-* macro constants unless you thoroughly -;; understand the `life-grim-reaper' function. - -(defmacro life-life-char () ?@) -(defmacro life-death-char () (1+ (life-life-char))) -(defmacro life-birth-char () 3) -(defmacro life-void-char () ?\ ) - -(defmacro life-life-string () (char-to-string (life-life-char))) -(defmacro life-death-string () (char-to-string (life-death-char))) -(defmacro life-birth-string () (char-to-string (life-birth-char))) -(defmacro life-void-string () (char-to-string (life-void-char))) -(defmacro life-not-void-regexp () (concat "[^" (life-void-string) "\n]")) - -(defmacro life-increment (variable) (list 'setq variable (list '1+ variable))) - - -;; list of numbers that tell how many characters to move to get to -;; each of a cell's eight neighbors. -(defconst life-neighbor-deltas nil) - -;; window display always starts here. Easier to deal with than -;; (scroll-up) and (scroll-down) when trying to center the display. -(defconst life-window-start nil) - -;; For mode line -(defconst life-current-generation nil) -;; Sadly, mode-line-format won't display numbers. -(defconst life-generation-string nil) - -(defvar life-initialized nil - "Non-nil if `life' has been run at least once.") - -;;;###autoload -(defun life (&optional sleeptime) - "Run Conway's Life simulation. -The starting pattern is randomly selected. Prefix arg (optional first -arg non-nil from a program) is the number of seconds to sleep between -generations (this defaults to 1)." - (interactive "p") - (or life-initialized - (random t)) - (setq life-initialized t) - (or sleeptime (setq sleeptime 1)) - (life-setup) - (life-display-generation sleeptime) - (catch 'life-exit - (while t - (let ((inhibit-quit t)) - (life-grim-reaper) - (life-expand-plane-if-needed) - (life-increment-generation) - (life-display-generation sleeptime))))) - -(defalias 'life-mode 'life) -(put 'life-mode 'mode-class 'special) - -(defun life-setup () - (let (n) - (switch-to-buffer (get-buffer-create "*Life*") t) - (erase-buffer) - (kill-all-local-variables) - (setq case-fold-search nil - mode-name "Life" - major-mode 'life-mode - truncate-lines t - life-current-generation 0 - life-generation-string "0" - mode-line-buffer-identification '("Life: generation " - life-generation-string) - fill-column (1- (window-width)) - life-window-start 1) - (buffer-disable-undo (current-buffer)) - ;; stuff in the random pattern - (life-insert-random-pattern) - ;; make sure (life-life-char) is used throughout - (goto-char (point-min)) - (while (re-search-forward (life-not-void-regexp) nil t) - (replace-match (life-life-string) t t)) - ;; center the pattern horizontally - (goto-char (point-min)) - (setq n (/ (- fill-column (save-excursion (end-of-line) (point))) 2)) - (while (not (eobp)) - (indent-to n) - (forward-line)) - ;; center the pattern vertically - (setq n (/ (- (1- (window-height)) - (count-lines (point-min) (point-max))) - 2)) - (goto-char (point-min)) - (newline n) - (goto-char (point-max)) - (newline n) - ;; pad lines out to fill-column - (goto-char (point-min)) - (while (not (eobp)) - (end-of-line) - (indent-to fill-column) - (move-to-column fill-column) - (delete-region (point) (progn (end-of-line) (point))) - (forward-line)) - ;; expand tabs to spaces - (untabify (point-min) (point-max)) - ;; before starting be sure the automaton has room to grow - (life-expand-plane-if-needed) - ;; compute initial neighbor deltas - (life-compute-neighbor-deltas))) - -(defun life-compute-neighbor-deltas () - (setq life-neighbor-deltas - (list -1 (- fill-column) - (- (1+ fill-column)) (- (+ 2 fill-column)) - 1 fill-column (1+ fill-column) - (+ 2 fill-column)))) - -(defun life-insert-random-pattern () - (insert-rectangle - (elt life-patterns (random (length life-patterns)))) - (insert ?\n)) - -(defun life-increment-generation () - (life-increment life-current-generation) - (setq life-generation-string (int-to-string life-current-generation))) - -(defun life-grim-reaper () - ;; Clear the match information. Later we check to see if it - ;; is still clear, if so then all the cells have died. - (store-match-data nil) - (goto-char (point-min)) - ;; For speed declare all local variable outside the loop. - (let (point char pivot living-neighbors list) - (while (search-forward (life-life-string) nil t) - (setq list life-neighbor-deltas - living-neighbors 0 - pivot (1- (point))) - (while list - (setq point (+ pivot (car list)) - char (char-after point)) - (cond ((eq char (life-void-char)) - (subst-char-in-region point (1+ point) - (life-void-char) 1 t)) - ((< char 3) - (subst-char-in-region point (1+ point) char (1+ char) t)) - ((< char 9) - (subst-char-in-region point (1+ point) char 9 t)) - ((>= char (life-life-char)) - (life-increment living-neighbors))) - (setq list (cdr list))) - (if (memq living-neighbors '(2 3)) - () - (subst-char-in-region pivot (1+ pivot) - (life-life-char) (life-death-char) t)))) - (if (null (match-beginning 0)) - (life-extinct-quit)) - (subst-char-in-region 1 (point-max) 9 (life-void-char) t) - (subst-char-in-region 1 (point-max) 1 (life-void-char) t) - (subst-char-in-region 1 (point-max) 2 (life-void-char) t) - (subst-char-in-region 1 (point-max) (life-birth-char) (life-life-char) t) - (subst-char-in-region 1 (point-max) (life-death-char) (life-void-char) t)) - -(defun life-expand-plane-if-needed () - (catch 'done - (goto-char (point-min)) - (while (not (eobp)) - ;; check for life at beginning or end of line. If found at - ;; either end, expand at both ends, - (cond ((or (eq (following-char) (life-life-char)) - (eq (progn (end-of-line) (preceding-char)) (life-life-char))) - (goto-char (point-min)) - (while (not (eobp)) - (insert (life-void-char)) - (end-of-line) - (insert (life-void-char)) - (forward-char)) - (setq fill-column (+ 2 fill-column)) - (scroll-left 1) - (life-compute-neighbor-deltas) - (throw 'done t))) - (forward-line))) - (goto-char (point-min)) - ;; check for life within the first two lines of the buffer. - ;; If present insert two lifeless lines at the beginning.. - (cond ((search-forward (life-life-string) - (+ (point) fill-column fill-column 2) t) - (goto-char (point-min)) - (insert-char (life-void-char) fill-column) - (insert ?\n) - (insert-char (life-void-char) fill-column) - (insert ?\n) - (setq life-window-start (+ life-window-start fill-column 1)))) - (goto-char (point-max)) - ;; check for life within the last two lines of the buffer. - ;; If present insert two lifeless lines at the end. - (cond ((search-backward (life-life-string) - (- (point) fill-column fill-column 2) t) - (goto-char (point-max)) - (insert-char (life-void-char) fill-column) - (insert ?\n) - (insert-char (life-void-char) fill-column) - (insert ?\n) - (setq life-window-start (+ life-window-start fill-column 1))))) - -(defun life-display-generation (sleeptime) - (goto-char life-window-start) - (recenter 0) - - ;; Redisplay; if the user has hit a key, exit the loop. - (or (eq t (sit-for sleeptime)) - (throw 'life-exit nil))) - -(defun life-extinct-quit () - (life-display-generation 0) - (signal 'life-extinct nil)) - -(put 'life-extinct 'error-conditions '(life-extinct quit)) -(put 'life-extinct 'error-message "All life has perished") - -(provide 'life) - -;;; life.el ends here diff --git a/lisp/play/meese.el b/lisp/play/meese.el deleted file mode 100644 index 8a3ad922b8a..00000000000 --- a/lisp/play/meese.el +++ /dev/null @@ -1,27 +0,0 @@ -;;; meese.el --- protect the impressionable young minds of America - -;; This is in the public domain on account of being distributed since -;; 1985 or 1986 without a copyright notice. - -;; Maintainer: FSF -;; Keywords: games - -;;; Code: - -(defun protect-innocence-hook () - (let ((dir (file-name-directory buffer-file-name))) - (if (and (equal buffer-file-name (expand-file-name "sex.6" dir)) - (file-exists-p buffer-file-name) - (not (y-or-n-p "Are you over 18? "))) - (progn - (clear-visited-file-modtime) - (setq buffer-file-name (expand-file-name "celibacy.1" dir)) - (let ((inhibit-read-only t)) ; otherwise (erase-buffer) may bomb. - (erase-buffer) - (insert-file-contents buffer-file-name t)) - (rename-buffer (file-name-nondirectory buffer-file-name)))))) - -(add-hook 'find-file-hooks 'protect-innocence-hook) -(provide 'meese) - -;;; meese.el ends here diff --git a/lisp/play/morse.el b/lisp/play/morse.el deleted file mode 100644 index 5ab461641e5..00000000000 --- a/lisp/play/morse.el +++ /dev/null @@ -1,121 +0,0 @@ -;;; morse.el --- Convert text to morse code and back. - -;; Copyright (C) 1995 Free Software Foundation, Inc. - -;; Author: Rick Farnbach <rick_farnbach@MENTORG.COM> - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(defvar morse-code '(("a" . ".-") - ("b" . "-...") - ("c" . "-.-.") - ("d" . "-..") - ("e" . ".") - ("f" . "..-.") - ("g" . "--.") - ("h" . "....") - ("i" . "..") - ("j" . ".---") - ("k" . "-.-") - ("l" . ".-..") - ("m" . "--") - ("n" . "-.") - ("o" . "---") - ("p" . ".--.") - ("q" . "--.-") - ("r" . ".-.") - ("s" . "...") - ("t" . "-") - ("u" . "..-") - ("v" . "...-") - ("w" . ".--") - ("x" . "-..-") - ("y" . "-.--") - ("z" . "--..") - ;; Punctuation - ("=" . "-...-") - ("?" . "..--..") - ("/" . "-..-.") - ("," . "--..--") - ("." . ".-.-.-") - (":" . "---...") - ("'" . ".----.") - ("-" . "-....-") - ("(" . "-.--.-") - (")" . "-.--.-") - ;; Numbers - ("0" . "-----") - ("1" . ".----") - ("2" . "..---") - ("3" . "...--") - ("4" . "....-") - ("5" . ".....") - ("6" . "-....") - ("7" . "--...") - ("8" . "---..") - ("9" . "----.")) - "Morse code character set.") - -(defun morse-region (beg end) - "Convert all text in a given region to morse code." - (interactive "r") - (if (integerp end) - (setq end (copy-marker end))) - (save-excursion - (let ((sep "") - str morse) - (goto-char beg) - (while (< (point) end) - (setq str (downcase (buffer-substring (point) (1+ (point))))) - (cond ((looking-at "\\s-+") - (goto-char (match-end 0)) - (setq sep "")) - ((setq morse (assoc str morse-code)) - (delete-char 1) - (insert sep (cdr morse)) - (setq sep "/")) - (t - (forward-char 1) - (setq sep ""))))))) - -(defun unmorse-region (beg end) - "Convert morse coded text in region to ordinary ASCII text." - (interactive "r") - (if (integerp end) - (setq end (copy-marker end))) - (save-excursion - (let (str paren morse) - (goto-char beg) - (while (< (point) end) - (if (null (looking-at "[-.]+")) - (forward-char 1) - (setq str (buffer-substring (match-beginning 0) (match-end 0))) - (if (null (setq morse (rassoc str morse-code))) - (goto-char (match-end 0)) - (replace-match - (if (string-equal "(" (car morse)) - (if (setq paren (null paren)) "(" ")") - (car morse)) t) - (if (looking-at "/") - (delete-char 1)))))))) - -(provide 'morse) - -;;; morse.el ends here diff --git a/lisp/play/mpuz.el b/lisp/play/mpuz.el deleted file mode 100644 index a99182d1689..00000000000 --- a/lisp/play/mpuz.el +++ /dev/null @@ -1,443 +0,0 @@ -;;; mpuz.el --- multiplication puzzle for GNU Emacs - -;; Copyright (C) 1990 Free Software Foundation, Inc. - -;; Author: Philippe Schnoebelen <phs@lifia.imag.fr> -;; Keywords: games - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; When this package is loaded, `M-x mpuz' generates a random multiplication -;; puzzle. This is a multiplication example in which each digit has been -;; consistently replaced with some letter. Your job is to reconstruct -;; the original digits. Type `?' while the mode is active for detailed help. - -;;; Code: - -(random t) ; randomize - -(defvar mpuz-silent nil - "*Set this to T if you don't want dings on inputs.") - -(defun mpuz-ding () - "Dings, unless global variable `mpuz-silent' forbids it." - (or mpuz-silent (ding t))) - - -;; Mpuz mode and keymaps -;;---------------------- -(defvar mpuz-mode-hook nil) - -(defvar mpuz-mode-map nil - "Local keymap to use in Mult Puzzle.") - -(if mpuz-mode-map nil - (setq mpuz-mode-map (make-sparse-keymap)) - (define-key mpuz-mode-map "a" 'mpuz-try-letter) - (define-key mpuz-mode-map "b" 'mpuz-try-letter) - (define-key mpuz-mode-map "c" 'mpuz-try-letter) - (define-key mpuz-mode-map "d" 'mpuz-try-letter) - (define-key mpuz-mode-map "e" 'mpuz-try-letter) - (define-key mpuz-mode-map "f" 'mpuz-try-letter) - (define-key mpuz-mode-map "g" 'mpuz-try-letter) - (define-key mpuz-mode-map "h" 'mpuz-try-letter) - (define-key mpuz-mode-map "i" 'mpuz-try-letter) - (define-key mpuz-mode-map "j" 'mpuz-try-letter) - (define-key mpuz-mode-map "A" 'mpuz-try-letter) - (define-key mpuz-mode-map "B" 'mpuz-try-letter) - (define-key mpuz-mode-map "C" 'mpuz-try-letter) - (define-key mpuz-mode-map "D" 'mpuz-try-letter) - (define-key mpuz-mode-map "E" 'mpuz-try-letter) - (define-key mpuz-mode-map "F" 'mpuz-try-letter) - (define-key mpuz-mode-map "G" 'mpuz-try-letter) - (define-key mpuz-mode-map "H" 'mpuz-try-letter) - (define-key mpuz-mode-map "I" 'mpuz-try-letter) - (define-key mpuz-mode-map "J" 'mpuz-try-letter) - (define-key mpuz-mode-map "\C-g" 'mpuz-offer-abort) - (define-key mpuz-mode-map "?" 'describe-mode)) - -(defun mpuz-mode () - "Multiplication puzzle mode. - -You have to guess which letters stand for which digits in the -multiplication displayed inside the `*Mult Puzzle*' buffer. - -You may enter a guess for a letter's value by typing first the letter, -then the digit. Thus, to guess that A=3, type A 3. - -To leave the game to do other editing work, just switch buffers. -Then you may resume the game with M-x mpuz. -You may abort a game by typing \\<mpuz-mode-map>\\[mpuz-offer-abort]." - (interactive) - (setq major-mode 'mpuz-mode - mode-name "Mult Puzzle") - (use-local-map mpuz-mode-map) - (run-hooks 'mpuz-mode-hook)) - - -;; Some variables for statistics -;;------------------------------ -(defvar mpuz-nb-errors 0 - "Number of errors made in current game.") - -(defvar mpuz-nb-completed-games 0 - "Number of games completed.") - -(defvar mpuz-nb-cumulated-errors 0 - "Number of errors made in previous games.") - - -;; Some variables for game tracking -;;--------------------------------- -(defvar mpuz-in-progress nil - "True if a game is currently in progress.") - -(defvar mpuz-found-digits (make-vector 10 nil) - "A vector recording which digits have been decrypted.") - -(defmacro mpuz-digit-solved-p (digit) - (list 'aref 'mpuz-found-digits digit)) - - -;; A puzzle uses a permutation of [0..9] into itself. -;; We use both the permutation and its inverse. -;;--------------------------------------------------- -(defvar mpuz-digit-to-letter (make-vector 10 0) - "A permutation from [0..9] to [0..9].") - -(defvar mpuz-letter-to-digit (make-vector 10 0) - "The inverse of mpuz-digit-to-letter.") - -(defmacro mpuz-to-digit (letter) - (list 'aref 'mpuz-letter-to-digit letter)) - -(defmacro mpuz-to-letter (digit) - (list 'aref 'mpuz-digit-to-letter digit)) - -(defun mpuz-build-random-perm () - "Initialize puzzle coding with a random permutation." - (let ((letters (list 0 1 2 3 4 5 6 7 8 9)) ; new cons cells, because of delq - (index 10) - elem) - (while letters - (setq elem (nth (random index) letters) - letters (delq elem letters) - index (1- index)) - (aset mpuz-digit-to-letter index elem) - (aset mpuz-letter-to-digit elem index)))) - - -;; A puzzle also uses a board displaying a multiplication. -;; Every digit appears in the board, crypted or not. -;;------------------------------------------------------ -(defvar mpuz-board (make-vector 10 nil) - "The board associates to any digit the list of squares where it appears.") - -(defun mpuz-put-digit-on-board (number square) - "Put (last digit of) NUMBER on SQUARE of the puzzle board." - ;; i.e. push SQUARE on NUMBER square-list - (setq number (% number 10)) - (aset mpuz-board number (cons square (aref mpuz-board number)))) - -(defun mpuz-check-all-solved () - "Check whether all digits have been solved. Return t if yes." - (catch 'found - (let ((digit -1)) - (while (> 10 (setq digit (1+ digit))) - (if (and (not (mpuz-digit-solved-p digit)) ; unsolved - (aref mpuz-board digit)) ; and appearing in the puzzle ! - (throw 'found nil)))) - t)) - - -;; To build a puzzle, we take two random numbers and multiply them. -;; We also take a random permutation for encryption. -;; The random numbers are only use to see which digit appears in which square -;; of the board. Everything is stored in individual squares. -;;--------------------------------------------------------------------------- -(defun mpuz-random-puzzle () - "Draw random values to be multiplied in a puzzle." - (mpuz-build-random-perm) - (fillarray mpuz-board nil) ; erase the board - (let (A B C D E) - ;; A,B,C,D & E, are the five rows of our multiplication. - ;; Choose random values, discarding uninteresting cases. - (while (progn - (setq A (random 1000) - B (random 100) - C (* A (% B 10)) - D (* A (/ B 10)) - E (* A B)) - (or (< C 1000) (< D 1000)))) ; forbid leading zeros in C or D - ;; Individual digits are now put on their respective squares. - ;; [NB: A square is a pair <row,column> of the screen.] - (mpuz-put-digit-on-board A '(2 . 9)) - (mpuz-put-digit-on-board (/ A 10) '(2 . 7)) - (mpuz-put-digit-on-board (/ A 100) '(2 . 5)) - (mpuz-put-digit-on-board B '(4 . 9)) - (mpuz-put-digit-on-board (/ B 10) '(4 . 7)) - (mpuz-put-digit-on-board C '(6 . 9)) - (mpuz-put-digit-on-board (/ C 10) '(6 . 7)) - (mpuz-put-digit-on-board (/ C 100) '(6 . 5)) - (mpuz-put-digit-on-board (/ C 1000) '(6 . 3)) - (mpuz-put-digit-on-board D '(8 . 7)) - (mpuz-put-digit-on-board (/ D 10) '(8 . 5)) - (mpuz-put-digit-on-board (/ D 100) '(8 . 3)) - (mpuz-put-digit-on-board (/ D 1000) '(8 . 1)) - (mpuz-put-digit-on-board E '(10 . 9)) - (mpuz-put-digit-on-board (/ E 10) '(10 . 7)) - (mpuz-put-digit-on-board (/ E 100) '(10 . 5)) - (mpuz-put-digit-on-board (/ E 1000) '(10 . 3)) - (mpuz-put-digit-on-board (/ E 10000) '(10 . 1)))) - -;; Display -;;-------- -(defconst mpuz-framework - " - . . . - Number of errors (this game): 0 - x . . - ------- - . . . . - Number of completed games: 0 - . . . . - --------- Average number of errors: 0.00 - . . . . ." - "The general picture of the puzzle screen, as a string.") - -(defun mpuz-create-buffer () - "Create (or recreate) the puzzle buffer. Return it." - (let ((buff (get-buffer-create "*Mult Puzzle*"))) - (save-excursion - (set-buffer buff) - (let ((buffer-read-only nil)) - (erase-buffer) - (insert mpuz-framework) - (mpuz-paint-board) - (mpuz-paint-errors) - (mpuz-paint-statistics))) - buff)) - -(defun mpuz-paint-errors () - "Paint error count on the puzzle screen." - (mpuz-switch-to-window) - (let ((buffer-read-only nil)) - (goto-line 3) - (move-to-column 49) - (mpuz-delete-line) - (insert (prin1-to-string mpuz-nb-errors)))) - -(defun mpuz-paint-statistics () - "Paint statistics about previous games on the puzzle screen." - (let* ((mean (if (zerop mpuz-nb-completed-games) 0 - (/ (+ mpuz-nb-completed-games (* 200 mpuz-nb-cumulated-errors)) - (* 2 mpuz-nb-completed-games)))) - (frac-part (% mean 100))) - (let ((buffer-read-only nil)) - (goto-line 7) - (move-to-column 51) - (mpuz-delete-line) - (insert (prin1-to-string mpuz-nb-completed-games)) - (goto-line 9) - (move-to-column 50) - (mpuz-delete-line) - (insert (format "%d.%d%d" (/ mean 100) (/ frac-part 10) (% frac-part 10)))))) - -(defun mpuz-paint-board () - "Paint board situation on the puzzle screen." - (mpuz-switch-to-window) - (let ((letter -1)) - (while (> 10 (setq letter (1+ letter))) - (mpuz-paint-digit (mpuz-to-digit letter)))) - (goto-char (point-min))) - -(defun mpuz-paint-digit (digit) - "Paint all occurrences of DIGIT on the puzzle board." - ;; (mpuz-switch-to-window) - (let ((char (if (mpuz-digit-solved-p digit) - (+ digit ?0) - (+ (mpuz-to-letter digit) ?A))) - (square-l (aref mpuz-board digit))) - (let ((buffer-read-only nil)) - (while square-l - (goto-line (car (car square-l))) ; line before column ! - (move-to-column (cdr (car square-l))) - (insert char) - (delete-char 1) - (backward-char 1) - (setq square-l (cdr square-l)))))) - -(defun mpuz-delete-line () - "Clear from point to next newline." ; & put nothing in the kill ring - (while (not (= ?\n (char-after (point)))) - (delete-char 1))) - -(defun mpuz-get-buffer () - "Get the puzzle buffer if it exists." - (get-buffer "*Mult Puzzle*")) - -(defun mpuz-switch-to-window () - "Find or create the Mult-Puzzle buffer, and display it." - (let ((buff (mpuz-get-buffer))) - (or buff (setq buff (mpuz-create-buffer))) - (switch-to-buffer buff) - (or buffer-read-only (toggle-read-only)) - (mpuz-mode))) - - -;; Game control -;;------------- -(defun mpuz-abort-game () - "Abort any puzzle in progress." - (message "Mult Puzzle aborted.") - (setq mpuz-in-progress nil - mpuz-nb-errors 0) - (fillarray mpuz-board nil) - (let ((buff (mpuz-get-buffer))) - (if buff (kill-buffer buff)))) - -(defun mpuz-start-new-game () - "Start a new puzzle." - (message "Here we go...") - (setq mpuz-nb-errors 0 - mpuz-in-progress t) - (fillarray mpuz-found-digits nil) ; initialize mpuz-found-digits - (mpuz-random-puzzle) - (mpuz-switch-to-window) - (mpuz-paint-board) - (mpuz-paint-errors) - (mpuz-ask-for-try)) - -(defun mpuz-offer-new-game () - "Ask if user wants to start a new puzzle." - (if (y-or-n-p "Start a new game ") - (mpuz-start-new-game) - (message "OK. I won't."))) - -;;;###autoload -(defun mpuz () - "Multiplication puzzle with GNU Emacs." - ;; Main entry point - (interactive) - (mpuz-switch-to-window) - (if mpuz-in-progress - (mpuz-offer-abort) - (mpuz-start-new-game))) - -(defun mpuz-offer-abort () - "Ask if user wants to abort current puzzle." - (interactive) - (if (y-or-n-p "Abort game ") - (mpuz-abort-game) - (mpuz-ask-for-try))) - -(defun mpuz-ask-for-try () - "Ask for user proposal in puzzle." - (message "Your try ?")) - -(defun mpuz-try-letter () - "Propose a digit for a letter in puzzle." - (interactive) - (if mpuz-in-progress - (let (letter-char digit digit-char message) - (setq letter-char (upcase last-command-char) - digit (mpuz-to-digit (- letter-char ?A))) - (cond ((mpuz-digit-solved-p digit) - (message "%c already solved." letter-char)) - ((null (aref mpuz-board digit)) - (message "%c does not appear." letter-char)) - ((progn (message "%c = " letter-char) - ;; <char> has been entered. - ;; Print "<char> =" and - ;; read <num> or = <num> - (setq digit-char (read-char)) - (if (eq digit-char ?=) - (setq digit-char (read-char))) - (message "%c = %c" letter-char digit-char) - (or (> digit-char ?9) (< digit-char ?0))) ; bad input - (ding t)) - (t - (mpuz-try-proposal letter-char digit-char)))) - (mpuz-offer-new-game))) - -(defun mpuz-try-proposal (letter-char digit-char) - "Propose LETTER-CHAR as code for DIGIT-CHAR." - (let* ((letter (- letter-char ?A)) - (digit (- digit-char ?0)) - (correct-digit (mpuz-to-digit letter))) - (cond ((mpuz-digit-solved-p correct-digit) - (message "%c has already been found.")) - ((= digit correct-digit) - (message "%c = %c correct !" letter-char digit-char) - (mpuz-ding) - (mpuz-correct-guess digit)) - (t ;;; incorrect guess - (message "%c = %c incorrect !" letter-char digit-char) - (mpuz-ding) - (setq mpuz-nb-errors (1+ mpuz-nb-errors)) - (mpuz-paint-errors))))) - -(defun mpuz-correct-guess (digit) - "Handle correct guessing of DIGIT." - (aset mpuz-found-digits digit t) ; Mark digit as solved - (mpuz-paint-digit digit) ; Repaint it (now as a digit) - (if (mpuz-check-all-solved) - (mpuz-close-game))) - -(defun mpuz-close-game () - "Housecleaning when puzzle has been solved." - (setq mpuz-in-progress nil - mpuz-nb-cumulated-errors (+ mpuz-nb-cumulated-errors mpuz-nb-errors) - mpuz-nb-completed-games (1+ mpuz-nb-completed-games)) - (mpuz-paint-statistics) - (let ((message (mpuz-congratulate))) - (message message) - (sit-for 4) - (if (y-or-n-p (concat message " Start a new game ")) - (mpuz-start-new-game) - (message "Good Bye !")))) - -(defun mpuz-congratulate () - "Build a congratulation message when puzzle is solved." - (format "Puzzle solved with %d errors. %s" - mpuz-nb-errors - (cond ((= mpuz-nb-errors 0) "That's perfect !") - ((= mpuz-nb-errors 1) "That's very good !") - ((= mpuz-nb-errors 2) "That's good.") - ((= mpuz-nb-errors 3) "That's not bad.") - ((= mpuz-nb-errors 4) "That's not too bad...") - ((and (>= mpuz-nb-errors 5) - (< mpuz-nb-errors 10)) "That's bad !") - ((and (>= mpuz-nb-errors 10) - (< mpuz-nb-errors 15)) "That's awful.") - ((>= mpuz-nb-errors 15) "That's not serious.")))) - -(defun mpuz-show-solution () - "Display solution for debugging purposes." - (interactive) - (mpuz-switch-to-window) - (let (digit list) - (setq digit -1) - (while (> 10 (setq digit (1+ digit))) - (or (mpuz-digit-solved-p digit) - (setq list (cons digit list)))) - (mapcar 'mpuz-correct-guess list))) - -;;; mpuz.el ends here diff --git a/lisp/play/solitaire.el b/lisp/play/solitaire.el deleted file mode 100644 index 4ce8b7d3ff0..00000000000 --- a/lisp/play/solitaire.el +++ /dev/null @@ -1,455 +0,0 @@ -;;; solitaire.el --- game of solitaire in Emacs Lisp - -;; Copyright (C) 1994 Free Software Foundation, Inc. - -;; Author: Jan Schormann <Jan.Schormann@informatik.uni-oldenburg.de> -;; Created: Fri afternoon, Jun 3, 1994 -;; Keywords: games - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; This mode is for playing a well-known game of solitaire -;; in which you jump pegs across other pegs. - -;; The game itself is somehow self-explanatory. Read the help text to -;; solitaire, and try it. - -;;; Code: - -(defvar solitaire-mode-map nil - "Keymap for playing solitaire.") - -(if solitaire-mode-map - () - (setq solitaire-mode-map (make-sparse-keymap)) - (suppress-keymap solitaire-mode-map t) - (define-key solitaire-mode-map "\C-f" 'solitaire-right) - (define-key solitaire-mode-map "\C-b" 'solitaire-left) - (define-key solitaire-mode-map "\C-p" 'solitaire-up) - (define-key solitaire-mode-map "\C-n" 'solitaire-down) - (define-key solitaire-mode-map [return] 'solitaire-move) - (substitute-key-definition 'undo 'solitaire-undo - solitaire-mode-map global-map) - (define-key solitaire-mode-map " " 'solitaire-do-check) - (define-key solitaire-mode-map "q" 'solitaire-quit) - - (define-key solitaire-mode-map [right] 'solitaire-right) - (define-key solitaire-mode-map [left] 'solitaire-left) - (define-key solitaire-mode-map [up] 'solitaire-up) - (define-key solitaire-mode-map [down] 'solitaire-down) - - (define-key solitaire-mode-map [S-right] 'solitaire-move-right) - (define-key solitaire-mode-map [S-left] 'solitaire-move-left) - (define-key solitaire-mode-map [S-up] 'solitaire-move-up) - (define-key solitaire-mode-map [S-down] 'solitaire-move-down) - - (define-key solitaire-mode-map [kp-6] 'solitaire-right) - (define-key solitaire-mode-map [kp-4] 'solitaire-left) - (define-key solitaire-mode-map [kp-8] 'solitaire-up) - (define-key solitaire-mode-map [kp-2] 'solitaire-down) - (define-key solitaire-mode-map [kp-5] 'solitaire-center-point) - - (define-key solitaire-mode-map [S-kp-6] 'solitaire-move-right) - (define-key solitaire-mode-map [S-kp-4] 'solitaire-move-left) - (define-key solitaire-mode-map [S-kp-8] 'solitaire-move-up) - (define-key solitaire-mode-map [S-kp-2] 'solitaire-move-down) - - (define-key solitaire-mode-map [kp-enter] 'solitaire-move) - (define-key solitaire-mode-map [kp-0] 'solitaire-undo) - - ;; spoil it with s ;) - (define-key solitaire-mode-map [?s] 'solitaire-solve) - - ;; (define-key solitaire-mode-map [kp-0] 'solitaire-hint) - Not yet provided ;) - ) - -;; Solitaire mode is suitable only for specially formatted data. -(put 'solitaire-mode 'mode-class 'special) - -(defun solitaire-mode () - "Major mode for playing solitaire. -To learn how to play solitaire, see the documentation for function -`solitaire'. -\\<solitaire-mode-map> -The usual mnemonic keys move the cursor around the board; in addition, -\\[solitaire-move] is a prefix character for actually moving a stone on the board." - (interactive) - (kill-all-local-variables) - (use-local-map solitaire-mode-map) - (setq truncate-lines t) - (setq major-mode 'solitaire-mode) - (setq mode-name "Solitaire") - (run-hooks 'solitaire-mode-hook)) - -(defvar solitaire-stones 0 - "Counter for the stones that are still there.") - -(defvar solitaire-center nil - "Center of the board.") - -(defvar solitaire-start nil - "Upper left corner of the board.") - -(defvar solitaire-start-x nil) -(defvar solitaire-start-y nil) - -(defvar solitaire-end nil - "Lower right corner of the board.") - -(defvar solitaire-end-x nil) -(defvar solitaire-end-y nil) - -(defvar solitaire-auto-eval t - "*Non-nil means check for possible moves after each major change. -This takes a while, so switch this on if you like to be informed when -the game is over, or off, if you are working on a slow machine.") - -(defconst solitaire-valid-directions - '(solitaire-left solitaire-right solitaire-up solitaire-down)) - -;;;###autoload -(defun solitaire (arg) - "Play Solitaire. - -To play Solitaire, type \\[solitaire]. -\\<solitaire-mode-map> -Move around the board using the cursor keys. -Move stones using \\[solitaire-move] followed by a direction key. -Undo moves using \\[solitaire-undo]. -Check for possible moves using \\[solitaire-do-check]. -\(The variable solitaire-auto-eval controls whether to automatically -check after each move or undo) - -What is Solitaire? - -I don't know who invented this game, but it seems to be rather old and -its origin seems be northern Africa. Here's how to play: -Initially, the board will look similar to this: - - Le Solitaire - ============ - - o o o - - o o o - - o o o o o o o - - o o o . o o o - - o o o o o o o - - o o o - - o o o - -Let's call the o's stones and the .'s holes. One stone fits into one -hole. As you can see, all holes but one are occupied by stones. The -aim of the game is to get rid of all but one stone, leaving that last -one in the middle of the board if you're cool. - -A stone can be moved if there is another stone next to it, and a hole -after that one. Thus there must be three fields in a row, either -horizontally or vertically, up, down, left or right, which look like -this: o o . - -Then the first stone is moved to the hole, jumping over the second, -which therefore is taken away. The above thus `evaluates' to: . . o - -That's all. Here's the board after two moves: - - o o o - - . o o - - o o . o o o o - - o . o o o o o - - o o o o o o o - - o o o - - o o o - -Pick your favourite shortcuts: - -\\{solitaire-mode-map}" - - (interactive "P") - (switch-to-buffer "*Solitaire*") - (solitaire-mode) - (setq buffer-read-only t) - (setq solitaire-stones 32) - (solitaire-insert-board) - (solitaire-build-modeline) - (goto-char (point-max)) - (setq solitaire-center (search-backward ".")) - (setq buffer-undo-list (list (point))) - (set-buffer-modified-p nil)) - -(defun solitaire-build-modeline () - (setq mode-line-format - (list "" "---" 'mode-line-buffer-identification - (if (< 1 solitaire-stones) - (format "--> There are %d stones left <--" solitaire-stones) - "------") - 'global-mode-string " %[(" 'mode-name 'minor-mode-alist "%n" - ")%]-%-")) - (force-mode-line-update)) - -(defun solitaire-insert-board () - (let* ((buffer-read-only nil) - (w (window-width)) - (h (window-height)) - (hsep (cond ((> w 26) " ") - ((> w 20) " ") - (t ""))) - (vsep (cond ((> h 17) "\n\n") - (t "\n"))) - (indent (make-string (/ (- w 7 (* 6 (length hsep))) 2) ?\ ))) - (erase-buffer) - (insert (make-string (/ (- h 7 (if (> h 12) 3 0) - (* 6 (1- (length vsep)))) 2) ?\n)) - (if (or (string= vsep "\n\n") (> h 12)) - (progn - (insert (format "%sLe Solitaire\n" indent)) - (insert (format "%s============\n\n" indent)))) - (insert indent) - (setq solitaire-start (point)) - (setq solitaire-start-x (current-column)) - (setq solitaire-start-y (solitaire-current-line)) - (insert (format " %s %so%so%so%s" hsep hsep hsep hsep vsep)) - (insert (format "%s %s %so%so%so%s" indent hsep hsep hsep hsep vsep)) - (insert (format "%so%so%so%so%so%so%so%s" indent hsep hsep hsep hsep hsep hsep vsep)) - (insert (format "%so%so%so%s" indent hsep hsep hsep)) - (setq solitaire-center (point)) - (insert (format ".%so%so%so%s" hsep hsep hsep vsep)) - (insert (format "%so%so%so%so%so%so%so%s" indent hsep hsep hsep hsep hsep hsep vsep)) - (insert (format "%s %s %so%so%so%s" indent hsep hsep hsep hsep vsep)) - (insert (format "%s %s %so%so%so%s %s " indent hsep hsep hsep hsep hsep hsep)) - (setq solitaire-end (point)) - (setq solitaire-end-x (current-column)) - (setq solitaire-end-y (solitaire-current-line)) - )) - -(defun solitaire-right () - (interactive) - (let ((start (point))) - (forward-char) - (while (= ?\ (following-char)) - (forward-char)) - (if (or (= 0 (following-char)) - (= ?\ (following-char)) - (= ?\n (following-char))) - (goto-char start)))) - -(defun solitaire-left () - (interactive) - (let ((start (point))) - (backward-char) - (while (= ?\ (following-char)) - (backward-char)) - (if (or (= 0 (preceding-char)) - (= ?\ (following-char)) - (= ?\n (following-char))) - (goto-char start)))) - -(defun solitaire-up () - (interactive) - (let ((start (point)) - (c (current-column))) - (forward-line -1) - (move-to-column c) - (while (and (= ?\n (following-char)) - (forward-line -1) - (move-to-column c) - (not (bolp)))) - (if (or (= 0 (preceding-char)) - (= ?\ (following-char)) - (= ?\= (following-char)) - (= ?\n (following-char))) - (goto-char start) - ))) - -(defun solitaire-down () - (interactive) - (let ((start (point)) - (c (current-column))) - (forward-line 1) - (move-to-column c) - (while (and (= ?\n (following-char)) - (forward-line 1) - (move-to-column c) - (not (eolp)))) - (if (or (= 0 (following-char)) - (= ?\ (following-char)) - (= ?\n (following-char))) - (goto-char start)))) - -(defun solitaire-center-point () - (interactive) - (goto-char solitaire-center)) - -(defun solitaire-move-right () (interactive) (solitaire-move '[right])) -(defun solitaire-move-left () (interactive) (solitaire-move '[left])) -(defun solitaire-move-up () (interactive) (solitaire-move '[up])) -(defun solitaire-move-down () (interactive) (solitaire-move '[down])) - -(defun solitaire-possible-move (movesymbol) - "Check if a move is possible from current point in the specified direction. -MOVESYMBOL specifies the direction. -Returns either a string, indicating cause of contraindication, or a -list containing three numbers: starting field, skipped field (from -which a stone will be taken away) and target." - - (save-excursion - (let (move) - (fset 'move movesymbol) - (if (memq movesymbol solitaire-valid-directions) - (let ((start (point)) - (skip (progn (move) (point))) - (target (progn (move) (point)))) - (if (= skip target) - "Off Board!" - (if (or (/= ?o (char-after start)) - (/= ?o (char-after skip)) - (/= ?. (char-after target))) - "Wrong move!" - (list start skip target)))) - "Not a valid direction")))) - -(defun solitaire-move (dir) - "Pseudo-prefix command to move a stone in Solitaire." - (interactive "kMove where? ") - (let* ((class (solitaire-possible-move (lookup-key solitaire-mode-map dir))) - (buffer-read-only nil)) - (if (stringp class) - (error class) - (let ((start (car class)) - (skip (car (cdr class))) - (target (car (cdr (cdr class))))) - (goto-char start) - (delete-char 1) - (insert ?.) - (goto-char skip) - (delete-char 1) - (insert ?.) - (goto-char target) - (delete-char 1) - (insert ?o) - (goto-char target) - (setq solitaire-stones (1- solitaire-stones)) - (solitaire-build-modeline) - (if solitaire-auto-eval (solitaire-do-check)))))) - -(defun solitaire-undo (arg) - "Undo a move in Solitaire." - (interactive "P") - (let ((buffer-read-only nil)) - (undo arg)) - (save-excursion - (setq solitaire-stones - (let ((count 0)) - (goto-char solitaire-end) - (while (search-backward "o" solitaire-start 'done) - (and (>= (current-column) solitaire-start-x) - (<= (current-column) solitaire-end-x) - (>= (solitaire-current-line) solitaire-start-y) - (<= (solitaire-current-line) solitaire-end-y) - (setq count (1+ count)))) - count))) - (solitaire-build-modeline) - (if solitaire-auto-eval (solitaire-do-check))) - -(defun solitaire-check () - (save-excursion - (if (= 1 solitaire-stones) - 0 - (goto-char solitaire-end) - (let ((count 0)) - (while (search-backward "o" solitaire-start 'done) - (and (>= (current-column) solitaire-start-x) - (<= (current-column) solitaire-end-x) - (>= (solitaire-current-line) solitaire-start-y) - (<= (solitaire-current-line) solitaire-end-y) - (mapcar - (lambda (movesymbol) - (if (listp (solitaire-possible-move movesymbol)) - (setq count (1+ count)))) - solitaire-valid-directions))) - count)))) - -(defun solitaire-do-check (&optional arg) - "Check for any possible moves in Solitaire." - (interactive "P") - (let ((moves (solitaire-check))) - (cond ((= 1 solitaire-stones) - (message "Yeah! You made it! Only the King is left!")) - ((zerop moves) - (message "Sorry, no more possible moves.")) - ((= 1 moves) - (message "There is one possible move.")) - (t (message "There are %d possible moves." moves))))) - -(defun solitaire-current-line () - "Return the vertical position of point. -Seen in info on text lines." - (+ (count-lines (point-min) (point)) - (if (= (current-column) 0) 1 0) - -1)) - -(defun solitaire-quit () - "Quit playing Solitaire." - (interactive) - (kill-buffer "*Solitaire*")) - -;; And here's the spoiler:) -(defun solitaire-solve () - "Spoil solitaire by solving the game for you - nearly ... -... stops with five stones left ;)" - (interactive) - (let ((allmoves [up up S-down up left left S-right up up left S-down - up up right right S-left down down down S-up up - S-down down down down S-up left left down - S-right left left up up S-down right right right - S-left left S-right right right right S-left - right down down S-up down down left left S-right - up up up S-down down S-up up up up S-down up - right right S-left down right right down S-up - left left left S-right right S-left down down - left S-right S-up S-left S-left S-down S-right - up S-right left left]) - ;; down down S-up left S-right - ;; right S-left - (solitaire-auto-eval nil)) - (solitaire-center-point) - (mapcar (lambda (op) - (if (memq op '(S-left S-right S-up S-down)) - (sit-for 0.2)) - (execute-kbd-macro (vector op)) - (if (memq op '(S-left S-right S-up S-down)) - (sit-for 0.4))) - allmoves)) - (solitaire-do-check)) - -(provide 'solitaire) - -;;; solitaire.el ends here diff --git a/lisp/play/spook.el b/lisp/play/spook.el deleted file mode 100644 index cf6685af51b..00000000000 --- a/lisp/play/spook.el +++ /dev/null @@ -1,69 +0,0 @@ -;;; spook.el --- spook phrase utility for overloading the NSA line eater - -;; Copyright (C) 1988, 1993 Free Software Foundation, Inc. - -;; Maintainer: FSF -;; Keywords: games -;; Created: May 1987 - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; 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. -;; -;; To use this: -;; 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. Help defeat the NSA trunk trawler! - -;;; Code: - -(require 'cookie1) - -; Variables -(defvar spook-phrases-file (concat data-directory "spook.lines") - "Keep your favorite phrases here.") - -(defvar spook-phrase-default-count 15 - "Default number of phrases to insert") - -;;;###autoload -(defun spook () - "Adds that special touch of class to your outgoing mail." - (interactive) - (cookie-insert spook-phrases-file - spook-phrase-default-count - "Checking authorization..." - "Checking authorization...Approved")) - -;;;###autoload -(defun snarf-spooks () - "Return a vector containing the lines from `spook-phrases-file'." - (cookie-snarf spook-phrases-file - "Checking authorization..." - "Checking authorization...Approved")) - -;; Note: the implementation that used to take up most of this file has been -;; cleaned up, generalized, gratuitously broken by esr, and now resides in -;; cookie1.el. - -;;; spook.el ends here diff --git a/lisp/play/studly.el b/lisp/play/studly.el deleted file mode 100644 index b5aafcab09a..00000000000 --- a/lisp/play/studly.el +++ /dev/null @@ -1,63 +0,0 @@ -;;; studly.el --- StudlyCaps (tm)(r)(c)(xxx) - -;;; This is in the public domain, since it was distributed -;;; by its author without a copyright notice in 1986. - -;; Keywords: games - -;;; Commentary: - -;; Functions to studlycapsify a region, word, or buffer. Possibly the -;; esoteric significance of studlycapsification escapes you; that is, -;; you suffer from autostudlycapsifibogotification. Too bad. - -;;; Code: - -(defun studlify-region (begin end) - "Studlify-case the region" - (interactive "*r") - (save-excursion - (goto-char begin) - (setq begin (point)) - (while (and (<= (point) end) - (not (looking-at "\\W*\\'"))) - (forward-word 1) - (backward-word 1) - (setq begin (max (point) begin)) - (forward-word 1) - (let ((offset 0) - (word-end (min (point) end)) - c) - (goto-char begin) - (while (< (point) word-end) - (setq offset (+ offset (following-char))) - (forward-char 1)) - (setq offset (+ offset (following-char))) - (goto-char begin) - (while (< (point) word-end) - (setq c (following-char)) - (if (and (= (% (+ c offset) 4) 2) - (let ((ch (following-char))) - (or (and (>= ch ?a) (<= ch ?z)) - (and (>= ch ?A) (<= ch ?Z))))) - (progn - (delete-char 1) - (insert (logxor c ? )))) - (forward-char 1)) - (setq begin (point)))))) - -(defun studlify-word (count) - "Studlify-case the current word, or COUNT words if given an argument" - (interactive "*p") - (let ((begin (point)) end rb re) - (forward-word count) - (setq end (point)) - (setq rb (min begin end) re (max begin end)) - (studlify-region rb re))) - -(defun studlify-buffer () - "Studlify-case the current buffer" - (interactive "*") - (studlify-region (point-min) (point-max))) - -;;; studly.el ends here diff --git a/lisp/play/yow.el b/lisp/play/yow.el deleted file mode 100644 index 501758e94a4..00000000000 --- a/lisp/play/yow.el +++ /dev/null @@ -1,130 +0,0 @@ -;;; yow.el --- quote random zippyisms - -;; Copyright (C) 1993, 1994, 1995 Free Software Foundation, Inc. - -;; Maintainer: FSF -;; Author: Richard Mlynarik -;; Keywords: games - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; Important pinheadery for GNU Emacs. -;; -;; See cookie1.el for implementation. Note --- the `n' argument of yow -;; from the 18.xx implementation is no longer; we only support *random* -;; random access now. - -;;; Code: - -(require 'cookie1) - -(defvar yow-file (concat data-directory "yow.lines") - "File containing pertinent pinhead phrases.") - -(defconst yow-load-message "Am I CONSING yet?...") -(defconst yow-after-load-message "I have SEEN the CONSING!!") - -;;;###autoload -(defun yow (&optional insert) - "Return or display a random Zippy quotation. With prefix arg, insert it." - (interactive "P") - (let ((yow (cookie yow-file yow-load-message yow-after-load-message))) - (cond (insert - (insert yow)) - ((not (interactive-p)) - yow) - ((not (string-match "\n" yow)) - (delete-windows-on (get-buffer-create "*Help*")) - (message "%s" yow)) - (t - (message "Yow!") - (with-output-to-temp-buffer "*Help*" - (princ yow) - (save-excursion - (set-buffer standard-output) - (help-mode))))))) - -(defsubst read-zippyism (prompt &optional require-match) - "Read a Zippyism from the minibuffer with completion, prompting with PROMPT. -If optional second arg is non-nil, require input to match a completion." - (read-cookie prompt yow-file yow-load-message yow-after-load-message - require-match)) - -;;;###autoload -(defun insert-zippyism (&optional zippyism) - "Prompt with completion for a known Zippy quotation, and insert it at point." - (interactive (list (read-zippyism "Pinhead wisdom: " t))) - (insert zippyism)) - -;;;###autoload -(defun apropos-zippy (regexp) - "Return a list of all Zippy quotes matching REGEXP. -If called interactively, display a list of matches." - (interactive "sApropos Zippy (regexp): ") - ;; Make sure yows are loaded - (cookie yow-file yow-load-message yow-after-load-message) - (let* ((case-fold-search t) - (cookie-table-symbol (intern yow-file cookie-cache)) - (string-table (symbol-value cookie-table-symbol)) - (matches nil) - (len (length string-table)) - (i 0)) - (save-match-data - (while (< i len) - (and (string-match regexp (aref string-table i)) - (setq matches (cons (aref string-table i) matches))) - (setq i (1+ i)))) - (and matches - (setq matches (sort matches 'string-lessp))) - (and (interactive-p) - (cond ((null matches) - (message "No matches found.")) - (t - (let ((l matches)) - (with-output-to-temp-buffer "*Zippy Apropos*" - (while l - (princ (car l)) - (setq l (cdr l)) - (and l (princ "\n\n")))))))) - matches)) - - -;; Yowza!! Feed zippy quotes to the doctor. Watch results. -;; fun, fun, fun. Entertainment for hours... -;; -;; written by Kayvan Aghaiepour - -;;;###autoload -(defun psychoanalyze-pinhead () - "Zippy goes to the analyst." - (interactive) - (doctor) ; start the psychotherapy - (message "") - (switch-to-buffer "*doctor*") - (sit-for 0) - (while (not (input-pending-p)) - (insert-string (yow)) - (sit-for 0) - (doctor-ret-or-read 1) - (doctor-ret-or-read 1))) - -(provide 'yow) - -;;; yow.el ends here |