empclient.el100444 145 12 100103 5651177072 12224 0ustar armbrustaff;;; empclient.el --- Simple, extensible, self contained empire client ;; Copyright (C) 1994 Markus Armbruster ;; Author: Markus Armbruster ;; Version: $Id: empclient.el,v 1.6 1994/10/19 11:08:41 armbru Exp $ ;; Keywords: games ;; Empclient 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. ;; Empclient 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 Empclient; see the file COPYING. If not, write to ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. ;;; Commentary: ;; This file is a simple, extensible, self contained empire-client-in- ;; a-buffer package (empire client mode). Simple means there is ;; essentially everything the stock emp_client provides plus what we ;; get for free from Emacs, but nothing more. Extensible means there ;; are hooks to plug in other tools. Self contained means you don't ;; need anything but this file and a *recent* Emacs. GNU Emacs 19.26 ;; works fine, alas, 19.22 doesn't. I don't care for version 18 ;; anymore. ;; Since this mode is built on top of Emacs's general command- ;; interpreter-in-a-buffer mode (comint mode), it shares a common ;; base functionality, and a common set of bindings, with all modes ;; derived from comint mode. This makes these modes easier to use. ;; For documentation on the functionality provided by comint mode, and ;; the hooks available for customising it, see the file comint.el that ;; comes with Emacs. ;;; Summary of Commands & Bindings ;; empire-client Connect to an empire-server ;; empire-client-mode Major mode ;; empire-pop-to-tool TAB Pop to current tool ;; Replacements for comint commands, bindings as in comint: ;; empire-delchar-or-maybe-eof Replaces comint-delchar-or-maybe-eof ;; empire-send-eof Replaces comint-send-eof ;; empire-send-intr Replaces comint-interrupt-subjob ;;; Summary of User Options ;; empire-host Name of the server host ;; empire-port Port to use on empire-host ;; empire-country Your empire country ;; empire-passwd Your empire password ;; empire-prompt-format To customize `[#:#] Command: ' prompts ;; empire-keep-redir-buffers Keep or kill buffers created for redirections ;; empire-client-mode-hook Major mode hook ;;; Plugging in Tools ;; Empclient filters each line of input through the functions in ;; `empire-input-filter-functions'. They may perform arbitrary ;; substitutions. The function `empire-filter-input' may be used for ;; recursive substitutions. Then, Empclient calls the function in ;; `empire-input-split-function' to split the input line into a list ;; of commands. Each command is sent to the server on a separate ;; line. Filtering and splitting is inhibited while the variable ;; `empire-verbatim-input' is non-nil. ;; Tools may insert commands as if they were typed in by the user. ;; See functions `empire-insert-input' and `empire-send-command'. ;; Empclient calls the function in `empire-output-filter' for each ;; line of output. This function may snoop data from the empire ;; dialog. Empclient runs `empire-after-output-hook' after each chunk ;; of server output. ;; A set of tools including a map display is currently under ;; development. ;;; Installation ;; You need this file somewhere in your load-path. ;; You may byte compile it for speed ;; M-x byte-compile whereever/empclient.el ;; To just give it a try, use ;; M-x load-library empclient ;; M-x empire-client ;; To install it, add the following line to ~/.emacs ;; (autoload 'empire-client "empclient" "Connect to an empire server, with I/O through buffer *empire*." t) ;;; How to get ;; anonymous ftp ;; i44ftp.info.uni-karlsruhe.de:/pub/misc/empire/emacs/empclient.el ;; or from the Elisp Archive, ;; archive.cis.ohio-state.edu:pub/gnu/emacs/elisp-archive/games/empclient.el.Z ;; or one of its mirrors. ;; or from the Empire archive, ;; ftp.cis.ksu.edu:/pub/Games/Empire/... ;; LCD Archive Entry: ;; empclient|Markus Armbruster|armbru@pond.sub.org| ;; Simple, extensible, self contained empire client.| ;; $Date: 1994/10/19 11:08:41 $|$Revision: 1.6 $|~/games/empclient.el.Z| ;;; Bugs ;; The empire command `wait' confuses Empclient. If this happens, use ;; `empire-send-intr' with an argument to reset Empclient. ;;; Restrictions ;; Currently, you can't have multiple empires per Emacs. ;;; To do ;; Do not busy wait in empire-send ;; Clean up comint's menus. ;; Allow multiple connections (not that I needed them :) ;;; Code: (require 'comint) (provide 'empclient) ;;; User options (defvar empire-host (getenv "EMPIREHOST") "*Name of the server host, or its IP address.") (defvar empire-port (getenv "EMPIREPORT") "*Port to use on empire-host.") (defvar empire-country (getenv "COUNTRY") "*Your empire country") (defvar empire-passwd (getenv "PLAYER") "*Your empire password, the so called representative.") (defvar empire-prompt-format "[%s:%s] Command: " "*The format string for empire prompts. The first %s will print as your current number of BTUs, the second as your login time.") (defvar empire-client-prompt "Client> " "*The prompt string for client generated prompts.") (defvar empire-keep-redir-buffers nil "*Non-nil means buffers created for redirections should be kept. Nil means silently kill buffers created for redirections. Already existing buffers are never killed.") (defvar empire-client-mode-hook nil "*Hook for customising Empire Client mode.") ;;; Variables ;; Empire client mode keymap (defvar empire-client-mode-map nil "Keymap used in Empire Client mode.") (cond ((not empire-client-mode-map) (setq empire-client-mode-map (copy-keymap comint-mode-map)) (define-key empire-client-mode-map "\t" 'empire-pop-to-tool) (define-key empire-client-mode-map "\C-c\C-v" 'empire-toggle-verbatim) (substitute-key-definition 'comint-send-eof 'empire-send-eof empire-client-mode-map) (substitute-key-definition 'comint-delchar-or-maybe-eof 'empire-delchar-or-maybe-eof empire-client-mode-map) (substitute-key-definition 'comint-interrupt-subjob 'empire-send-intr empire-client-mode-map))) ;; Variables provided for external tools to interface with empire client (defconst empclient-version "1.4" "Empclient's version number. This is really the oldest version that looks like this one for tools. When interface changes, it gets bumped up to the `real' version number.") (defvar empire-input-filter-functions nil "A list of functions to filter lines of user input. For each line the functions are called in list order. The line is passed to the first one, subsequent ones are passed their predecessor's result, and the last result is sent to the server. If a function returns nil, filtering is terminated and the line of input is removed.") (defvar empire-input-split-function 'list "Function to split the filtered input into a list of commands. It is called with one argument, a string or nil. It should return a list of strings and optionally the following symbols: `at-prompt-or-abort' requests to force the session to command level, `at-flush-or-ignore' requests to ignore the immedialtely following string if the session is at command level.") (defvar empire-verbatim-input nil "If non-nil, send input verbatim. Else it is filtered through `empire-input-filter-functions' and split with `empire-input-split-function'.") ;; To avoid interference with user commands, tools should not inject ;; commands while `empire-busy' is non-nil. (defvar empire-busy nil "Non-nil if session is at command-level and there are no unprocessed commands.") (defvar empire-output-filter (function (lambda (tag string) string)) "Function to filter lines of server output. Called inside of an excursion with two arguments. First argument is one of the symbols `exit', `flush', `prompt', `abort', `cmderr', `badcmd', `data'. Second argument is the line of output. Returns the filtered string.") ;; The function in `empire-output-filter' might want to know this: (defvar empire-current-input nil "Empclient currently receives this input line's output.") ;; This hook is intented for output triggered actions that move point. ;; They can't be called from `empire-output-filter', as it runs inside ;; of an excursion. (defvar empire-after-output-hook nil "Hook run after each chunk of server output.") (defvar empire-tool-buffer nil "If non-nil, \\[empire-pop-to-tool] pops to this buffer.") ;; Internal variables (defvar empire-process-mark nil "If non-nil, overrides process mark. Comint abuses the process mark as mark for the start of the current input. Sometimes the real process mark needs to be somewhere else.") (defvar empire-sent-ahead nil "Number of lines sent to server but not acknowledged by a prompt.") (defconst empire-server-tag-alist '((cmdok . ?0) (data . ?1) (init . ?2) (exit . ?3) (flush . ?4) (noecho . ?5) (prompt . ?6) (abort . ?7) (redir . ?8) (pipe . ?9) (cmderr . ?A) (badcmd . ?B) (execute . ?C)) "Alist associating symbols with server message tags.") (defvar empire-consumer nil "Function that `consumes' a line of server output. Called with one argument, the line of output.") (defvar empire-partial-line nil "Trailing partial line of server output.") (defvar empire-login-proto nil "Description of the remaining login protocol. A list of lists `(EXPECTED-TAG ERROR NEXT-COMMAND)' where EXPECTED-TAG is a symbol, ERROR a function or nil, NEXT-COMMAND a string or nil. If we get EXPECTED-TAG, the NEXT-COMMAND is sent to the server if non-nil and the first element is deleted from empire-login-proto. If this exhausts the list, login was successful. On receiving an unexpected tag, ERROR is called if non-nil with three arguments, the expected tag, the received tag and the received string. The connection is then closed.") ;; Good choice: ?\240 is ?\ with msb set --- gets displayed as ;; highlighted blank if we can't make it invisible. (defvar empire-magic-prompt-cookie "\240" "String to append to strange prompts. We need to match prompts with `comint-prompt-regexp'. If we can't, we append this magic cookie to make it recognizable.") (defvar empire-redir-buffer nil "Buffer that holds the current redirection. If this is not a buffer, ignore output.") (defvar empire-pipe-process nil "The process we are currently piping to.") ;;; Commands (defun empire-client-mode () "Major mode for interacting with an empire server. Return after the end of the process's output sends the text from the end of process to the end of the current line. Return before end of process output copies the current line (except for the prompt) to the end of the buffer and sends it. \\{empire-client-mode-map} Entry to this mode runs the hooks `comint-mode-hook' and `empire-client-mode-hook' (in that order)." (interactive) (comint-mode) (setq comint-input-filter 'empire-save-on-history-p) (setq comint-input-sender 'empire-send) (setq comint-process-echoes t) ; not really, but we fake it (setq comint-prompt-regexp (concat "^" (format (regexp-quote empire-prompt-format) "[0-9]*" "[0-9]*") "\\|^" empire-client-prompt "\\|^.*" empire-magic-prompt-cookie)) (setq major-mode 'empire-client-mode) (setq mode-name "Empire-Client") ;; hack mode line to display `Verb' while empire-verbatim-input is non-nil (setq mode-line-format (copy-sequence mode-line-format)) (let ((tail (memq 'mode-line-process mode-line-format))) (setcdr tail (cons '(empire-verbatim-input " Verb") (cdr tail)))) (use-local-map empire-client-mode-map) ;; arrange display table to interpret characters' msb as highlight (setq buffer-display-table (make-display-table)) (let ((highlight-face-id (if (fboundp 'face-id) (face-id 'highlight) 0)) (char 128)) (while (< char 256) (aset buffer-display-table char (vector (+ char -128 (* 256 highlight-face-id)))) (setq char (1+ char)))) (run-hooks 'empire-client-mode-hook)) (defun empire-client (&optional kill) "Connect to an empire server, with I/O through buffer *empire*. If there is already a connection, just switch to its buffer. With prefix arg, try to kill an existing connection instead of starting a new one." (interactive "P") (let* ((buffer (get-buffer-create "*empire*")) (process (get-buffer-process buffer))) (save-excursion (set-buffer buffer) (if (and process (eq (process-status process) 'open)) nil ; reuse old connection (empire-client-mode) ;; outdated emacs versions may choke on this, but 19.25 works: (add-text-properties 0 (length empire-magic-prompt-cookie) '(invisible t rear-nonsticky t) empire-magic-prompt-cookie) ;; open connection (or empire-host (setq empire-host (read-string "Empire host? "))) (or empire-port (setq empire-port (read-string "Empire port? "))) (and (stringp empire-port) (string-match "\\`[0-9]+\\'" empire-port) (setq empire-port (string-to-number empire-port))) (or empire-country (setq empire-country (read-string "Country? "))) (or empire-passwd (setq empire-passwd (read-string "Player? "))) (if process (delete-process process)) (setq process (open-network-stream "empire" buffer empire-host empire-port)) (goto-char (point-max)) (set-marker (process-mark process) (point)) (setq empire-process-mark (make-marker)) (set-process-filter process 'empire-process-filter) (setq empire-consumer 'empire-login) (setq empire-partial-line "") (setq empire-login-proto (list (list 'init nil (concat "user " (user-login-name))) (list 'cmdok nil (concat "coun " empire-country)) (list 'cmdok (function (lambda (exp rec args) (setq empire-country nil))) (concat "pass " empire-passwd)) (list 'cmdok (function (lambda (exp rec args) (setq empire-country nil empire-passwd nil))) (if kill "kill" "play")))) (setq empire-sent-ahead 1) ; expecting one initial prompt (setq empire-busy t) (setq empire-redir-buffer nil) (setq empire-pipe-process nil)) (switch-to-buffer buffer) buffer))) (defun empire-delchar-or-maybe-eof (arg) "Delete ARG characters forward, or (if at eob) send an end-of-file cookie." (interactive "p") (if (eobp) (empire-send-eof) (delete-char arg))) (defun empire-send-eof () "Send end-of-file cookie to empire server." (interactive) (let ((empire-verbatim-input t)) (empire-send-command "ctld"))) (defun empire-send-intr (&optional arg) "Send interrupt cookie to empire server. With argument, reset Empclient to sane state." (interactive "P") (cond (arg (setq empire-sent-ahead 0 empire-partial-line "") (empire-close-pipe) (empire-unredirect) (set-marker empire-process-mark nil))) (let ((empire-verbatim-input t)) (empire-send-command "aborted"))) (defun empire-pop-to-tool () "Select `empire-tool-buffer' in some window, preferably a different one." (interactive) (if empire-tool-buffer (pop-to-buffer empire-tool-buffer) (message "No current tool"))) (defun empire-toggle-verbatim (&optional arg) "Change whether input is sent verbatim or filtered and split. With arg, set verbatim iff arg is positive." (interactive "P") (setq empire-verbatim-input (if (not arg) (not empire-verbatim-input) (> (prefix-numeric-value arg) 0))) (force-mode-line-update)) ;;; Sending input (defun empire-save-on-history-p (string) "Return non-nil if STRING should be saved on the input history list. Don't save all whitespace, end-of-file or interrupt cookies. This usually serves as `comint-input-filter'." (not (string-match "\\`\\( *\\|ctld\\|aborted\\)\\'" string))) (defun empire-send (process string) "Sent to PROCESS input STRING and a newline. Input is filtered through `empire-input-filter-functions' and split with `empire-input-split-function' unless `empire-verbatim-input' is non-nil." (let ((pmark (process-mark process)) cmds) (insert string) ; fake echo (insert "\n") (let ((opoint (point))) (setq cmds (if empire-verbatim-input (list string) (condition-case err (funcall empire-input-split-function (empire-filter-input string empire-input-filter-functions)) (error (message "Input filtering failed: %s" err) nil)))) (if (and (= opoint (point)) (not (cdr cmds)) (string= string (car cmds))) ;; no need to echo both string and cmds, undo former (delete-region pmark (point)))) (or cmds ;; nothing will be sent, will get no server prompt, fake one (insert empire-client-prompt)) (while cmds (cond ((eq (car cmds) 'at-prompt-or-abort) ;; TODO: no busy wait (empire-wait-until-non-busy t) (if empire-busy ; not at prompt, abort command (empire-send-intr))) ((eq (car cmds) 'at-flush-or-ignore) ;; TODO: no busy wait (empire-wait-until-non-busy t) (or empire-busy ; not at flush, ignore next cmd (setq cmds (cdr cmds)))) (t (let ((cmd (concat (car cmds) "\n"))) (and (zerop empire-sent-ahead) (setq empire-current-input cmd)) (save-excursion ; echo cmd (insert cmd) (set-marker pmark (point))) (while (< (point) pmark) (and (/= 0 empire-sent-ahead) (not (marker-position empire-process-mark)) (set-marker empire-process-mark (point))) (setq empire-sent-ahead (1+ empire-sent-ahead)) (setq empire-busy t) (forward-line) ;; mark end of server input line (add-text-properties (1- (point)) (point) '(empire-input t rear-nonsticky t))) (comint-send-string process cmd)))) (setq cmds (cdr cmds))))) (defun empire-filter-input (input filters) "Filter INPUT through FILTERS." (while (and filters input) (setq input (funcall (car filters) input)) (setq filters (cdr filters))) input) ;;; Functions for tools to insert & send input (defun empire-insert-input (string) "Insert STRING into *empire* buffer as if it were typed in by the user. If STRING contains newlines, send the current input up to the last newline." (let ((saved-buffer (window-buffer (selected-window))) (pop-up-windows nil) (pop-up-frames nil)) (or (zerop (length string)) ;; doesn't work if current buffer is *empire* (unwind-protect (progn (pop-to-buffer (get-buffer "*empire*")) (let ((this-command 'yank)) (comint-preinput-scroll-to-bottom)) (let ((opoint (point))) (insert string) (save-excursion (cond ((search-backward "\n" opoint t) (comint-send-input) (delete-char 1)))))) (pop-to-buffer saved-buffer))))) (defun empire-send-command (string) "Insert and send empire command STRING. Use function `empire-wait-until-non-busy' to wait for the command's completion." (let ((saved-buffer (window-buffer (selected-window))) (pop-up-windows nil) (pop-up-frames nil) proc-mark point-mark) (unwind-protect (progn (pop-to-buffer (get-buffer "*empire*")) (setq proc-mark (process-mark (get-buffer-process (current-buffer)))) (setq point-mark (and (/= (point) proc-mark) (point-marker))) (goto-char proc-mark) (insert string) (let ((comint-eol-on-send nil)) ; send exactly up to point (comint-send-input)) (goto-char (or point-mark proc-mark)) (if point-mark (set-marker point-mark nil))) (pop-to-buffer saved-buffer)))) (defun empire-wait-until-non-busy (&optional partial) "Wait until empire session is not busy. If optional argument PARTIAL is non-nil, only wait for a prompt for which no input is pending." (let ((process (get-buffer-process "*empire*"))) (while (if partial (/= 0 empire-sent-ahead) empire-busy) (cond ((not (accept-process-output process 1)) ;; no progress for one second, better tell user what's up (message "Waiting for empire server sending prompt") (accept-process-output process))) (sit-for 0) (or (eq (process-status process) 'open) (error "Empire session died"))) (message ""))) ;;; Receiving output (defun empire-process-filter (process output) ;; Process filter for empire connection PROCESS. ;; Split OUTPUT in lines and feed it to value of `empire-consumer'. ;; Save a remaining partial line in variable `empire-partial-line'. (if (process-buffer process) (save-excursion (save-restriction (save-match-data (widen) (let ((start 0) (debug-on-error t) (debug-on-quit t) (inhibit-quit nil)) ; debugging on (set-buffer (process-buffer process)) (while (string-match "\n" output start) (let* ((msg (concat empire-partial-line (substring output start (match-end 0)))) (tag (car (rassq (upcase (aref msg 0)) empire-server-tag-alist)))) (setq start (match-end 0)) (if (and tag (= (aref msg 1) ?\ )) (funcall empire-consumer process tag (substring msg 2)) (empire-message (format "Ignored strange line `%s'" (substring msg 0 -1)))) (setq empire-partial-line ""))) (setq empire-partial-line (substring output start)))))) (delete-process process)) (run-hooks 'empire-after-output-hook)) (defun empire-login (process tag args) ;; Empire connection PROCESS sent TAG with ARGS. ;; Check TAG, insert ARGS into buffer, send next command as ;; described by empire-login-proto. ;; This is in `empire-consumer' during initial login. (let ((expected (nth 0 (car empire-login-proto))) (handler (nth 1 (car empire-login-proto))) (command (nth 2 (car empire-login-proto)))) (cond ((eq tag expected) (empire-insert-output args) (and command (process-send-string process (concat command "\n"))) (setq empire-login-proto (cdr empire-login-proto)) (or empire-login-proto (setq empire-consumer 'empire-play))) (t (if handler (funcall handler expected tag args)) (if (> (length args) 0) (setq args (substring args 0 -1))) (empire-abort (if (and (eq tag 'cmderr) (> (length args) 0)) args (format "expected %s, got %s %s" expected tag args))))))) (defun empire-play (process tag args) ;; Empire connection PROCESS sent TAG with ARGS. ;; Do the right thing. ;; This is in `empire-consumer' during play. (cond ((eq tag 'init) (let ((good-proto 2)) (if (/= (string-to-number args) good-proto) (empire-abort (format "server protocol %s, expected %s" args good-proto))) (setq args nil))) ((eq tag 'exit) (setq args (concat "Exit: " args))) ((eq tag 'flush) (setq args (substring args 0 -1))) ((eq tag 'prompt) (empire-close-pipe) (empire-unredirect) (setq args (apply 'format empire-prompt-format (if (string-match "\\`\\s-*\\([0-9]+\\)\\s-+\\([0-9]+\\)" args) (list (substring args (match-beginning 1) (match-end 1)) (substring args (match-beginning 2) (match-end 2))) (empire-message (format "Got bad prompt `%s'" (substring args 0 -1))) (list "" ""))))) ((eq tag 'abort) (setq args (concat "Aborted\n" args))) ((eq tag 'redir) (setq args (substring args 0 -1)) (if (and (string-match "\\`\\s-*>\\([>!]?\\)\\s-*" args) (< (match-end 0) (length args))) (empire-redirect (substring args (match-end 0)) (cdr (assoc (substring args (match-beginning 1) (match-end 1)) '(("" . excl) (">" . append) ("!" . trunc))))) (empire-message (format "Bad redirect `%s'" args))) (setq args nil)) ((eq tag 'pipe) (setq args (substring args 0 -1)) (if (and (string-match "\\`\\s-*|\\s-*" args) (< (match-end 0) (length args))) (empire-open-pipe (substring args (match-end 0))) (empire-message (concat "Bad pipe `%s'" args))) (setq args nil)) ((memq tag '(cmderr badcmd)) (setq args (concat "Error; " args))) ((eq tag 'execute) (setq args (substring args 0 -1)) (if (string-match "\\S-" args) (empire-execute (substring args (match-beginning 0))) (empire-message (format "Bad execute `%s'" args))) (setq args nil)) ((not (eq tag 'data)) (empire-message (format "Ignored %s `%s'" tag (substring args 0 -1))) (setq args nil))) (cond ((> (length args) 0) (empire-out (funcall empire-output-filter tag args)))) (cond ((memq tag '(flush prompt)) ;; if prompt doesn't match regexp append magic cookie (cond ((not (string-match comint-prompt-regexp args)) (empire-insert-output empire-magic-prompt-cookie))) ;; update variables (if (>= empire-sent-ahead 1) (setq empire-sent-ahead (1- empire-sent-ahead)) (message "Unexpected prompt") (setq empire-sent-ahead 0)) (setq empire-busy (not (and (zerop empire-sent-ahead) (eq tag 'prompt)))) ;; set current command, skip over type ahead (if (>= empire-sent-ahead 1) (let* ((start (or (marker-position empire-process-mark) (marker-position (process-mark process)))) (end (if (get-text-property start 'empire-input) start (next-single-property-change start 'empire-input)))) (setq empire-current-input (buffer-substring start (or end (point-max)))) (set-marker empire-process-mark (if end (1+ end) (point-max))))) ;; if in sync, clear empire-process-mark (if (<= empire-sent-ahead 1) (set-marker empire-process-mark nil))) ((eq tag 'exit) (delete-process process)))) (defun empire-out (string) ;; If it is piped, send STRING to pipe. ;; else if empire connection is redirected, append STRING to redirection, ;; else insert string into buffer. (cond (empire-pipe-process (if (memq (process-status empire-pipe-process) '(run stop)) ;; process may exit asynchronously, have to catch SIGPIPE (condition-case err (process-send-string empire-pipe-process string) (error (or (string-match "SIGPIPE" (nth 1 err)) (signal (car err) (cdr err))))))) ((bufferp empire-redir-buffer) (save-excursion (set-buffer empire-redir-buffer) (save-restriction (widen) (goto-char (point-max)) (insert string)))) ((not empire-redir-buffer) (empire-insert-output string)))) (defun empire-redirect (file mode) ;; Redirect connection output to FILE. ;; MODE excl means don't overwrite FILE if it exists already. ;; MODE append appends to FILE. ;; Another MODE overwrites FILE. (let ((buffer (get-file-buffer file)) new-buffer) (cond ((string= file "/dev/null") ; handled specially for speed (setq empire-redir-buffer t)) ; ignore output ((and (eq mode 'excl) (or buffer (file-nlinks file))) (setq empire-redir-buffer t) ; ignore output (empire-message (format "Redirect: `%s' exists" file))) ((not (file-writable-p file)) (setq empire-redir-buffer t) ; ignore output (empire-message (format "Redirect: `%s' unwriteable" file))) (t (or buffer (setq buffer (find-file-noselect file t) new-buffer t)) (setq empire-redir-buffer buffer) (put 'empire-redir-buffer 'empire-keep (or (not new-buffer) empire-keep-redir-buffers)) (or (eq mode 'append) (save-excursion (set-buffer buffer) (erase-buffer))))))) (defun empire-unredirect () ;; Terminate redirection of empire connection PROCESS. (if (bufferp empire-redir-buffer) (save-excursion (set-buffer empire-redir-buffer) (save-buffer) (or (get 'empire-redir-buffer 'empire-keep) (kill-buffer empire-redir-buffer)))) (setq empire-redir-buffer nil)) (defun empire-open-pipe (command) ;; Pipe empire connection's output through COMMAND. (let ((process-connection-type nil)) (string-match "\\S-+" command) (setq empire-pipe-process (start-process-shell-command (substring command 0 (match-end 0)) nil command)) (process-kill-without-query empire-pipe-process) ;; Set the process mark so that empire-pipe-filter can find the ;; buffer. The actual position is irrelevant. (set-marker (process-mark empire-pipe-process) 1) (set-process-filter empire-pipe-process 'empire-pipe-filter))) (defun empire-pipe-filter (process string) ;; Process filter for a pipe on behalf of empire connection PROCESS. ;; Insert STRING into buffer. (let ((buffer (marker-buffer (process-mark process))) (empire-pipe-process nil)) (save-excursion (set-buffer buffer) (empire-out string)))) (defun empire-close-pipe () ;; Finish piping empire connection through a command. ;; Send EOF and wait for command to terminate. (let ((pipe empire-pipe-process)) (cond (pipe (setq empire-pipe-process nil) (cond ((memq (process-status pipe) '(run stop)) (process-send-eof pipe) (condition-case err (while (memq (process-status pipe) '(run stop)) (let ((inhibit-quit nil)) (cond ((not (accept-process-output pipe 1)) ;; no progress for one second, better ;; tell user what's up (message (substitute-command-keys "Waiting for %s, \\[keyboard-quit] to quit") (process-name pipe)) (accept-process-output pipe))))) (quit (empire-message "killing...") (delete-process pipe))) (message nil))) (empire-process-status pipe) (delete-process pipe))))) (defun empire-execute (script) ;; Feed SCRIPT to empire connection. (let ((process (get-buffer-process (current-buffer))) buffer) (unwind-protect (if (file-readable-p script) (save-excursion (setq buffer (generate-new-buffer " *empire-exec*")) (set-buffer buffer) (insert-file-contents script) (comint-send-region process 1 (point-max))) (empire-message (format "Execute: `%s' unreadable" script))) (process-send-string process "ctld\n") (if buffer (kill-buffer buffer))))) ;; Inserting output into buffer (defun empire-process-status (process) "Insert any unusual status of PROCESS." (let ((name (process-name process)) (status (process-status process)) (code (process-exit-status process)) event) (cond ((eq status 'run) (setq event "%s is running")) ((eq status 'stop) (setq event "%s is stopped")) ((eq status 'exit) (setq event (and (/= code 0) "%s exited abnormally with code %d"))) ((eq status 'signal) (setq event "%s died with signal %d")) (t (setq event (format "is %s" status)))) (if event (empire-message (format event name code))))) (defun empire-abort (message) "Abort empire connection with MESSAGE." (setq empire-consumer 'ignore) (empire-message (concat message " --- session died")) (delete-process (get-buffer-process (current-buffer)))) (defun empire-message (message) "Insert client MESSAGE." (empire-insert-output (concat (if (looking-at "^") "" "\n") "Client: " message "\n"))) (defun empire-insert-output (string) "Insert STRING as empire connection output." (let ((process (get-buffer-process (current-buffer)))) (if (marker-position empire-process-mark) ;; set process mark temporarily to empire-process-mark (let* ((pmark (process-mark process)) (saved-pmark (copy-marker pmark))) (unwind-protect (progn (set-marker pmark (marker-position empire-process-mark)) (comint-output-filter process string) (empire-interpret-backspace comint-last-output-start pmark)) (set-marker pmark (marker-position saved-pmark)) (set-marker saved-pmark nil))) (comint-output-filter process string)))) (defun empire-interpret-backspace (from to) "Try to convert backspaces between FROM and TO into text properties." (save-excursion (let ((underline-props '(face underline rear-nonsticky t)) (overstrike-props '(face bold rear-nonsticky t))) (goto-char from) (while (search-forward "\b" to t) (let ((char1 (char-after (- (point) 2))) (char2 (following-char))) (cond ((and char1 (= char2 ?_)) (forward-char -1) (delete-char 2) (add-text-properties (1- (point)) (point) underline-props)) ((and char2 (= char1 ?_)) (delete-backward-char 2) (add-text-properties (point) (1+ (point)) underline-props) (forward-char)) ((and char1 (= char1 char2)) (delete-backward-char 2) (add-text-properties (point) (1+ (point)) overstrike-props) (forward-char)))))))) ;;; empclient.el ends here empdata.el100444 145 12 42055 5614701167 11647 0ustar armbrustaff;;; empdata.el --- Access GENIE game data ;; Copyright (C) 1994 Markus Armbruster ;; Author: Markus Armbruster ;; Version: $Id: empdata.el,v 1.6 1994/07/25 09:14:31 armbru Exp $ ;; Keywords: games ;; This file is part of GENIE, the GNU Emacs's Nifty Interface to Empire ;; GENIE 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. ;; GENIE 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 GENIE; see the file COPYING. If not, write to the Free ;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. ;;; Commentary: ;; For general information on GENIE, see file empire.el. ;; This file defines means to store and retrieve information about an ;; empire. ;;; Terminology ;; Coordinates are pairs (X . Y) of integers. ;; An x-coordinate X is canonical if XMIN<=X<=XMAX, where XMIN, XMAX ;; are determined by the world size. Y-coordinates likewise. ;; Two x-coordinates X, X' are equivalent if their difference is a ;; multiple of the world's x size. Y-coordinates likewise. ;; Coordinates are valid if they are both even or both odd. ;; Sector designations are characters as defined by empire. ;; Commodities are characters as defined by empire. ;;; To do ;; Cutoffs & deliveries ;; Units, ships, planes ;; Production, starve, budget, nation ;; Relations, etc. ;; Mail & news ;; Persistency ;;; Code: (require (if window-system 'empwin 'empterm)) (provide 'empdata) ;;; User options (defvar empire-login-hook nil "*Hook run after successful login.") (defvar empire-high-min 95 "*Iron ore contents above or equal this value are considered high.") (defvar empire-high-gold 60 "*Gold ore contents above or equal this value are considered high.") (defvar empire-high-fert 100 "*Soil fertility above or equal this value is considered high.") (defvar empire-high-ocontent 80 "*Oil contents above or equal this value is considered high.") (defvar empire-high-uran 95 "*Uranium contents above or equal this value is considered high.") ;;; Variables ;; You should not access these variables directly, except when ;; explicitely stated. Use the access functions. ;; Empire state (defvar empire-command-failed nil "Non-nil means some command failed.") (defvar empire-anno-waiting nil "Non-nil means there are unread announcements.") (defvar empire-tele-waiting nil "Non-nil means there are unread telegrams.") ;; Empire data (defvar empire-world-size nil "Size of the empire world. Looks like (X-SIZE . Y-SIZE).") (defvar empire-current-coord nil "Current coordinates. Just for convenient inter-tool communication.") (defvar empire-map nil "The empire map. This is a vector of rows which are strings") (defvar empire-map-version 0 "Every map change increments this variable.") (defvar empire-dump nil "Empire sector dump. This is a vector of rows which are vectors of sectors. A sector is nil or a vector.") (defvar empire-dump-version 0 "Every dump change increments this variable.") ;; dump index symbols ;; values are lists (index-in-sector-vector function-to-convert-from-string) (defconst empire-dump-index-eff '(0 string-to-number)) (defconst empire-dump-index-civ '(1 string-to-number)) (defconst empire-dump-index-mil '(2 string-to-number)) (defconst empire-dump-index-uw '(3 string-to-number)) (defconst empire-dump-index-min '(4 string-to-number)) (defconst empire-dump-index-gold '(5 string-to-number)) (defconst empire-dump-index-fert '(6 string-to-number)) (defconst empire-dump-index-ocontent '(7 string-to-number)) (defconst empire-dump-index-uran '(8 string-to-number)) (defconst empire-dump-index-owner '(9 nil)) (defconst empire-dump-index-sdes '(10 string-to-char)) (defconst empire-dump-index-mob '(11 string-to-number)) (defconst empire-dump-index-* '(12 string-to-char)) (defconst empire-dump-index-off '(13 string-to-number)) (defconst empire-dump-index-work '(14 string-to-number)) (defconst empire-dump-index-avail '(15 string-to-number)) (defconst empire-dump-index-terr '(16 string-to-number)) (defconst empire-dump-index-food '(17 string-to-number)) (defconst empire-dump-index-shell '(18 string-to-number)) (defconst empire-dump-index-gun '(19 string-to-number)) (defconst empire-dump-index-pet '(20 string-to-number)) (defconst empire-dump-index-iron '(21 string-to-number)) (defconst empire-dump-index-dust '(22 string-to-number)) (defconst empire-dump-index-bar '(23 string-to-number)) (defconst empire-dump-index-oil '(24 string-to-number)) (defconst empire-dump-index-lcm '(25 string-to-number)) (defconst empire-dump-index-hcm '(26 string-to-number)) (defconst empire-dump-index-rad '(27 string-to-number)) ;; TODO: cutoffs and deliveries (defconst empire-dump-index-dist_x '(28 string-to-number)) (defconst empire-dump-index-dist_y '(29 string-to-number)) (defconst empire-dump-index-c_dist '(30 string-to-number)) (defconst empire-dump-index-m_dist '(31 string-to-number)) (defconst empire-dump-index-u_dist '(32 string-to-number)) (defconst empire-dump-index-f_dist '(33 string-to-number)) (defconst empire-dump-index-s_dist '(34 string-to-number)) (defconst empire-dump-index-g_dist '(35 string-to-number)) (defconst empire-dump-index-p_dist '(36 string-to-number)) (defconst empire-dump-index-i_dist '(37 string-to-number)) (defconst empire-dump-index-d_dist '(38 string-to-number)) (defconst empire-dump-index-b_dist '(39 string-to-number)) (defconst empire-dump-index-o_dist '(40 string-to-number)) (defconst empire-dump-index-l_dist '(41 string-to-number)) (defconst empire-dump-index-h_dist '(42 string-to-number)) (defconst empire-dump-index-r_dist '(43 string-to-number)) (defconst empire-dump-length 44) ;; TODO: cutoffs and deliveries (defconst empire-commodities '((?c empire-dump-index-civ empire-dump-index-c_dist) (?m empire-dump-index-mil empire-dump-index-m_dist) (?u empire-dump-index-uw empire-dump-index-u_dist) (?f empire-dump-index-food empire-dump-index-f_dist) (?s empire-dump-index-shell empire-dump-index-s_dist) (?g empire-dump-index-gun empire-dump-index-g_dist) (?p empire-dump-index-pet empire-dump-index-p_dist) (?i empire-dump-index-iron empire-dump-index-i_dist) (?d empire-dump-index-dust empire-dump-index-d_dist) (?b empire-dump-index-bar empire-dump-index-b_dist) (?o empire-dump-index-oil empire-dump-index-o_dist) (?l empire-dump-index-lcm empire-dump-index-l_dist) (?h empire-dump-index-hcm empire-dump-index-h_dist) (?r empire-dump-index-rad empire-dump-index-r_dist)) "Alist associating commodity characters with dump index symbols. Each association is a list (COMMODITY AMOUNT-SYMBOL THRESHOLD-SYMBOL).") ;; access directly (defvar empire-your-cnum nil "Your country number.") ;; access directly (defvar empire-number-of-countries nil "The maximal number of countries in the game.") (defvar empire-cnums (make-vector 109 0) "Obarray to map country names to numbers.") (defvar empire-cnames nil "Country names, a vector of strings, indexed by country numbers.") ;; Highlights ;; Define highlight symbols and their bit index. A bit index is a ;; power of two, of course. (defconst empire-highlight-0 0) (defconst empire-highlight-1 1) (defvar empire-highlight-symbols (vector 'empire-highlight-0 'empire-highlight-1) "Array of symbols used as text properties for highlighting.") (defvar empire-default-highlight empire-highlight-0 "The highlight symbol to use if no specific one is requested.") ;;; World size, coordinates. (defun empire-world-x () "Return world's x-size." (car empire-world-size)) (defun empire-world-y () "Return world's y-size." (cdr empire-world-size)) (defun empire-set-world-size (x y) "Set worlds size to X, Y, return the new world size as pair (X . Y). If world size was previously unknown, initialize all other empire data." (cond (empire-world-size ; world size already known (and (= x (car empire-world-size)) (= y (cdr empire-world-size)) empire-world-size)) ((and (zerop (% x 2)) (zerop (% y 2))) ; new size valid (empire-new-map x y) (empire-new-dump x y) (setq empire-world-size (cons x y))) (t nil))) ; new size invalid (defun empire-canon-x (x) "Return the canonical x-coordinate equivalent to X." (let ((size (empire-world-x))) (- (mod (+ x (/ size 2)) size) (/ size 2)))) (defun empire-canon-y (y) "Return the canonical y-coordinate equivalent to Y." (let ((size (empire-world-y))) (- (mod (+ y (/ size 2)) size) (/ size 2)))) (defsubst empire-x-y-valid-p (x y) "Return non-nil if X, Y are valid coordinates." (eq (zerop (% x 2)) (zerop (% y 2)))) ;; More efficient than (empire-canon-x (1+ X)). X must be canonical. (defsubst empire-next-x (x) "Return the next x-coordinate on the right." (let ((max (/ (empire-world-x) 2))) (setq x (1+ x)) (if (>= x max) (- x max max) x))) ;; More efficient than (empire-canon-y (1+ Y)). Y must be canonical. (defsubst empire-next-y (y) "Return the next y-coordinate in downwards direction." (let ((max (/ (empire-world-y) 2))) (setq y (1+ y)) (if (>= y max) (- y max max) y))) (defun empire-current-x () "Return current x-coordinate." (car empire-current-coord)) (defun empire-current-y () "Return current y-coordinate." (cdr empire-current-coord)) (defun empire-set-current-coord (x y) "Set current coordinates to X, Y." (setq empire-current-coord (cons x y))) ;;; Access map (defsubst empire-map-x (x) "Return X's column index in map. X must be canonical." (let ((size (empire-world-x))) (% (+ x (/ size 2)) size))) (defsubst empire-map-y (y) "Return Y's row index in map. Y must be canonical." (let ((size (empire-world-y))) (% (+ y (/ size 2)) size))) (defun empire-new-map (x y) "Initialize the map for world size X, Y." (setq empire-map (apply 'vector ; y rows of strings with length x (mapcar (function (lambda (ignored) (make-string x ?\ ))) (make-list y nil))) empire-map-version (1+ empire-map-version))) (defun empire-map-changed-p (old-version) "Return current map version if it differs from OLD-VERSION, else nil." (and (not (eq old-version empire-map-version)) empire-map-version)) (defun empire-ref-map-sector (x y) "Return designation of sector X, Y. X, Y must be canonical. Invalid coordinates return ?\\ ." (aref (aref empire-map (empire-map-y y)) (empire-map-x x))) (defun empire-update-map-row (x y des) "Update map row, leftmost sector is X, Y, with string DES. (aref DES I) is the designation for sector X+I, Y. X, Y must be canonical and valid." (let ((i (length des))) (while (> i 0) (setq i (1- i)) (empire-update-map-sector (+ x i i) y (aref des i))))) (defun empire-update-map-sector (x y des) "Update map sector X, Y with DES. If sector's designation changed, return old one, else nil. X, Y must be canonical and valid." (or (empire-x-y-valid-p x y) (error "Bad coordinates")) (let* ((row (aref empire-map (empire-map-y y))) (index (empire-map-x x)) (old-des (aref row index))) ;; server highlight (cond ((>= des 128) (setq des (- des 128)) (empire-set-map-highlight empire-default-highlight row index))) ;; update owner (if (and (= des ??) (memq (empire-dump-value (empire-ref-dump-sector x y) 'empire-dump-index-owner) '(nil me))) (empire-update-dump-sector x y '((empire-dump-index-owner . foreign)))) ;; update designation (cond ((= des ?\ ) ; terra incognita nil) ((= des ?0) ; center of a radmap nil) ((and (<= ?A des) (<= des ?Z)) ; ship, plane or unit nil) ((or (/= des ??) (memq old-des '(?\ ?. ?-))) (aset row index des) (setq empire-map-version (1+ empire-map-version)) old-des)))) (defun empire-format-map-row (x y len) "Format a map row for display, leftmost sector is X, Y, width LEN characters." (let ((map-row (empire-highlight-map-row (aref empire-map (empire-map-y y)))) disp-row) (setq disp-row (substring map-row (empire-map-x x))) (setq len (- len (length disp-row))) (while (>= len 0) (setq disp-row (concat disp-row map-row)) (setq len (- len (length map-row)))) (substring disp-row 0 len))) (defun empire-highlight-map-row (row) "Return a copy of ROW highlighted for display." (let ((start 0) end) (setq row (concat row "")) ; copy row (remove-text-properties 0 (length row) '(face nil) row) (while (setq end (next-property-change start row)) (empire-highlight-string row start end (text-properties-at start row)) (setq start end)) row)) (defun empire-remove-map-highlight (n) "Remove highlight N from the map." (let ((prop (aref empire-highlight-symbols n)) (row-index (length empire-map))) (while (> row-index 0) (setq row-index (1- row-index)) (let ((row (aref empire-map row-index))) (remove-text-properties 0 (length row) (list prop nil) row))))) (defun empire-set-map-highlight (n row index) "Set highlight N at ROW, INDEX." (put-text-property index (1+ index) (aref empire-highlight-symbols n) t row)) ;;; Access dump (defsubst empire-dump-index (string) "Map STRING to its dump index symbol." (intern (concat "empire-dump-index-" string))) (defsubst empire-dump-x (x) "Return X's column index in dump." (if (< x 0) (- -1 x) x)) (defsubst empire-dump-y (y) "Return Y's row index in dump." (if (< y 0) (- -1 y y) (+ y y))) (defun empire-new-dump (x y) "Initialize the dump for world size X, Y." (setq empire-dump (apply 'vector ; y rows of x/2 columns (mapcar (function (lambda (ignored) (make-vector (/ x 2) nil))) (make-list y nil))) empire-dump-version (1+ empire-dump-version))) (defun empire-dump-changed-p (old-version) "Return current dump version if it differs from OLD-VERSION, else nil." (and (not (eq old-version empire-dump-version)) empire-dump-version)) (defun empire-ref-dump-sector (x y) "Return dump for sector X, Y. The value can be examined with `empire-dump-value'." (or (empire-x-y-valid-p x y) (error "Bad coordinates")) (aref (aref empire-dump (empire-dump-y y)) (empire-dump-x x))) (defun empire-dump-value (dump key) "Return DUMP's value for KEY. DUMP is a value obtained with `empire-ref-dump-sector'. KEY is a dump index symbol." (let ((index (car (symbol-value key)))) (and (< index (length dump)) (aref dump index)))) (defun empire-update-dump-sector (x y alist) "Update dump at sector X, Y according to ALIST. ALIST is a list of pairs (KEY . VALUE), where KEY is a dump index symbol." (or (empire-x-y-valid-p x y) (error "Bad coordinates")) (let ((sect (aref (aref empire-dump (empire-dump-y y)) (empire-dump-x x))) ;; convert (KEY . VALUE) to (INDEX . CONVERTED-VALUE) (data (mapcar (function (lambda (asso) (let ((def (symbol-value (car asso)))) (cons (nth 0 def) (if (stringp (cdr asso)) (funcall (nth 1 def) (cdr asso)) (cdr asso)))))) alist))) ;; enlarge sect if necessary (let ((delta-len (- (min empire-dump-length (1+ (apply 'max (mapcar 'car data)))) (length sect)))) (or (<= delta-len 0) (setq sect (vconcat sect (make-list delta-len nil))))) ;; set new values (mapcar (function (lambda (asso) (aset sect (car asso) (cdr asso)))) data) (aset (aref empire-dump (empire-dump-y y)) (empire-dump-x x) sect) (setq empire-dump-version (1+ empire-dump-version)))) (defun empire-dump-filter (alist) "Return ALIST with all unrecognized associations removed. ALIST's keys are dump index symbols or strings. The latter are mapped to the former." (delq nil (mapcar (function (lambda (asso) (if (stringp (car asso)) (setcar asso (empire-dump-index (car asso)))) (and (boundp (car asso)) asso))) alist))) ;;; Access countries (defun empire-ref-cname (num) "Return country NUM's name." (and (< num (length empire-cnames)) (aref empire-cnames num))) (defun empire-ref-cnum (name) "Return country NAME's number." (let ((sym (intern name empire-cnums))) (and (boundp sym) (symbol-value sym)))) (defun empire-set-country (num name) "Associate country NUM with NAME." (or (< num (length empire-cnames)) (setq empire-cnames (vconcat empire-cnames (make-list (- num (length empire-cnames) -1) nil)))) (aset empire-cnames num name) (set (intern name empire-cnums) num)) ;;; Display (defun empire-number-of-highlights () "Return the number of highlights we can display." (length empire-highlight-symbols)) (defun empire-highlight-index (prop-list) "Return the highlight index to use for PROP-LIST." (apply 'logior (mapcar (function (lambda (prop) (if (memq prop prop-list) (lsh 1 (symbol-value prop)) 0))) empire-highlight-symbols))) ;;; empdata.el ends here empire.el100444 145 12 6462 5651177210 11474 0ustar armbrustaff;;; empire.el --- GNU Emacs' Nifty Interface to Empire ;; Copyright (C) 1994 Markus Armbruster ;; Author: Markus Armbruster ;; Version: $Id: empire.el,v 1.4 1994/10/19 11:10:00 armbru Exp $ ;; Keywords: games ;; This file is part of GENIE, the GNU Emacs's Nifty Interface to Empire ;; GENIE 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. ;; GENIE 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 GENIE; see the file COPYING. If not, write to the Free ;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. ;;; Commentary: ;; GENIE is a set of tools for Empclient, the simple, extensible, self ;; contained empire client. It currently features a map display (see ;; empmap.el) and extends Empclient by a variable and function ;; substitution mechanism (see empsubst.el). Other neat stuff is ;; under development and may even be finished some day ;-> ;; From the Oxford Dictionary: ge-nie (in Arabic stories) spirit or ;; goblin with strange powers. ;; This is an ALPHA TEST RELEASE. You were warned. ;;; Installation ;; See empclient.el for Empclient's instalation instructions. ;; You need these file somewhere in your load-path: ;; ... ;; You may byte compile them for speed. ;; To just give it a try, use ;; M-x load-library empire ;; M-x empire ;; To install it, add the following line to ~/.emacs ;; (autoload 'empire "empire" "Crank up empire-client and various tools." t) ;;; How to get ;; anonymous ftp ;; i44ftp.info.uni-karlsruhe.de:/pub/misc/empire/emacs/... ;; or (not yet) from the Empire archive, ;; ftp.cis.ksu.edu:/pub/Games/Empire/... ;;; Call for Contribution ;; In the true spirit of Emacs, GENIE is (intended to be) easily ;; extensible. You are invited to add you own tools. If you want to ;; contribute code to GENIE itself, contact me. ;; Of course, comments, criticism, or bug reports are welcome. ;;; Restrictions ;; Currently, you can't have multiple empires per Emacs. ;;; To do ;; Snoop ;; Snoop more commands ;; Displays ;; Units, ships, planes ;; Production, starve, budget, nation ;; Tools ;; Commodity mover ;; Auto feeder ;; Production checker ;; Dist & threshold fixer ;; Mail & news reader ;; Defense checker ;;; Code: (require 'empclient) (require 'empmap) (require 'empsnoop) (require 'empsubst) ;;; User options (defvar empire-use-whole-frame t "*If non-nil empire uses the whole frame.") ;;; Commands (defun empire () "Crank up empire-client and various tools." (interactive) (or (string= empclient-version "1.4") (error "Requires Empclient version 1.4, found %s" empclient-version)) (if empire-use-whole-frame (delete-other-windows)) (let ((client-buffer (empire-client))) (empire-wait-until-non-busy) (run-hooks 'empire-login-hook) (empire-map) (empire-pop-to-client)) (message "This is an ALPHA TEST RELEASE. You were warned.")) ;;; empire.el ends here empmap.el100444 145 12 72106 5614704255 11514 0ustar armbrustaff;;; empmap.el --- GENIE map display ;; Copyright (C) 1994 Markus Armbruster ;; Author: Markus Armbruster ;; Version: $Id: empmap.el,v 1.6 1994/07/25 09:41:01 armbru Exp $ ;; Keywords: games ;; This file is part of GENIE, the GNU Emacs's Nifty Interface to Empire ;; GENIE 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. ;; GENIE 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 GENIE; see the file COPYING. If not, write to the Free ;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. ;;; Commentary: ;; For general information on GENIE, see file empire.el. ;; This file defines the map display (empire map mode) and related ;; functions. ;;; Summary of Commands & Bindings ;; empire-map Create a map ;; empire-map-mode Major mode ;; empire-pop-to-client TAB Pop to empire client ;; empire-map-recenter C-l Recenter map, redisplay frame ;; empire-map-goto t Goto coordinates ;; empire-set-map-mark C-@ Set map mark, bound like set-mark-command ;; empire-exchange-point-and-map-mark Exchange point and map mark, bound ;; C-x C-x like exchange-point-and-mark ;; empire-scroll-down C-v Scroll map down, bound like scroll-down ;; empire-scroll-up M-v Scroll map up, bound like scroll-up ;; empire-scroll-right < Scroll map right, also bound like scroll-right ;; empire-scroll-left > Scroll map left, also bound like scroll-left ;; empire-map-move y,u,g,j,b,n Move point in this direction ;; empire-goto-current h Goto current coordinates ;; empire-insert-move Y,U,G,H,J,B,N dto. and insert movement character ;; empire-insert-sect s Insert sector coordinates ;; empire-insert-sects S Insert rectangle coordinates ;; empire-send-and-goto-current Send current command and goto resulting ;; RET coordinates ;; empire-dump-sector d Dump sector ;; empire-brief-sector SPC Display sector summary ;; empire-brief-census c Display sector's census ;; empire-brief-resources r Display sector's resources ;; empire-brief-commodities m Display sector's commodities ;; empire-highlight l Highlight sectors (not yet implemented) ;; empire-mouse-insert-sect [mouse-2] Insert sector coordinates ;; empire-mouse-brief-sector [C-mouse-2] Display sector summary ;; Note: `bound like foo' means this function is bound like function ;; `foo' in global-map. ;;; Summary of User Options ;; empire-display-coordinates Toggle coordinate display in mode line ;; empire-map-mode-hook Major mode hook ;;; To do ;; Highlight sectors that match a user expression ;; Extend empire-insert-move to all allowed movement characters, eg v ;; Means to undo a empire-insert-move ;; Scroll map with mouse ;; Recenter map on mouse click ;; Rewrite empire-mouse-insert-sects. ;;; Code: (require 'empclient) (require 'emputil) (require 'empdata) (provide 'empmap) ;;; User options (defvar empire-display-coordinates t "*Non-nil mean display current coordinates in the mode line. This may be slow. Changing this variable does not affect existing maps.") (defvar empire-map-mode-hook nil "*Hook for customising Empire Map mode.") ;;; Variables ;; Empire map mode keymap (defvar empire-map-mode-map nil "Keymap used in Empire Map mode.") (cond ((not empire-map-mode-map) (setq empire-map-mode-map (make-keymap)) (suppress-keymap empire-map-mode-map) (define-key empire-map-mode-map [tab] 'empire-pop-to-client) (define-key empire-map-mode-map "\C-l" 'empire-map-recenter) (define-key empire-map-mode-map "t" 'empire-map-goto) (define-key empire-map-mode-map "\C-@" 'empire-set-map-mark) (substitute-key-definition 'set-mark-command 'empire-set-map-mark empire-map-mode-map global-map) (define-key empire-map-mode-map "\C-x\C-x" 'empire-exchange-point-and-map-mark) (substitute-key-definition 'exchange-point-and-mark 'empire-exchange-point-and-map-mark empire-map-mode-map global-map) (define-key empire-map-mode-map "\C-v" 'empire-scroll-map-down) (substitute-key-definition 'scroll-down 'empire-scroll-map-down empire-map-mode-map global-map) (define-key empire-map-mode-map "\M-v" 'empire-scroll-map-up) (substitute-key-definition 'scroll-up 'empire-scroll-map-up empire-map-mode-map global-map) (define-key empire-map-mode-map ">" 'empire-scroll-map-right) (substitute-key-definition 'scroll-right 'empire-scroll-map-right empire-map-mode-map global-map) (define-key empire-map-mode-map "<" 'empire-scroll-map-left) (substitute-key-definition 'scroll-left 'empire-scroll-map-left empire-map-mode-map global-map) (define-key empire-map-mode-map "y" 'empire-map-move) (define-key empire-map-mode-map "u" 'empire-map-move) (define-key empire-map-mode-map "g" 'empire-map-move) (define-key empire-map-mode-map "h" 'empire-goto-current) (define-key empire-map-mode-map "j" 'empire-map-move) (define-key empire-map-mode-map "b" 'empire-map-move) (define-key empire-map-mode-map "n" 'empire-map-move) (define-key empire-map-mode-map "Y" 'empire-insert-move) (define-key empire-map-mode-map "U" 'empire-insert-move) (define-key empire-map-mode-map "G" 'empire-insert-move) (define-key empire-map-mode-map "H" 'empire-insert-move) (define-key empire-map-mode-map "J" 'empire-insert-move) (define-key empire-map-mode-map "B" 'empire-insert-move) (define-key empire-map-mode-map "N" 'empire-insert-move) (define-key empire-map-mode-map "L" 'empire-insert-move) (define-key empire-map-mode-map "R" 'empire-insert-move) (define-key empire-map-mode-map "M" 'empire-insert-move) (define-key empire-map-mode-map "S" 'empire-insert-move) (define-key empire-map-mode-map "V" 'empire-insert-move) (define-key empire-map-mode-map "s" 'empire-insert-sect) (define-key empire-map-mode-map "\M-S" 'empire-insert-sects) (define-key empire-map-mode-map [return] 'empire-send-and-goto-current) (define-key empire-map-mode-map "d" 'empire-dump-sector) (define-key empire-map-mode-map " " 'empire-brief-sector) (define-key empire-map-mode-map "c" 'empire-brief-census) (define-key empire-map-mode-map "m" 'empire-brief-commodities) (define-key empire-map-mode-map "r" 'empire-brief-resources) (define-key empire-map-mode-map "l" 'empire-highlight) (define-key empire-map-mode-map [mouse-2] 'empire-mouse-insert-sect) (define-key empire-map-mode-map [C-mouse-2] 'empire-mouse-brief-sector))) ;; Internal variables (defvar empire-map-mode-line-coord nil "Mode-line control for displaying empire map's current coordinates") (defvar empire-map-buffers nil "List of active map buffers.") (defvar empire-map-center nil "Coordinates of displayed map's center. Permanently buffer local.") (defvar empire-map-size nil "Displayed map's size, looks like (X-SIZE . Y-SIZE). Permanently buffer local.") (defvar empire-displayed-version nil "Displayed map's version. Permanently buffer local.") (defvar empire-map-mark nil "Coordinates of mark. Permanently buffer local.") (defconst empire-x-ruler-height 2) (defconst empire-y-ruler-width 5) (defconst empire-directions '((?y -1 -1) (?u 1 -1) (?g -2 0) (?j 2 0) (?b -1 1) (?n 1 1)) "Alist mapping the empire direction characters to lists (DELTA-X DELTA-Y).") ;;; Empire map mode (defun empire-map-mode () "Major mode to display an empire map. \\{empire-map-mode-map} Entry to this mode runs the hook `empire-map-mode-hook'." (kill-all-local-variables) (setq major-mode 'empire-map-mode) (setq mode-name "Empire-Map") (cond (empire-display-coordinates (setq mode-line-format '("" mode-line-modified mode-line-buffer-identification " " global-mode-string " %[(" mode-name mode-line-process minor-mode-alist "%n" ")%]--@" empire-map-mode-line-coord "-%-")) (make-local-variable 'post-command-hook) (make-local-variable 'empire-map-current-coord) (setq post-command-hook 'empire-update-map-coord))) (toggle-read-only 1) (use-local-map empire-map-mode-map) (make-local-variable 'empire-map-center) (put 'empire-map-center 'permanent-local t) (make-local-variable 'empire-map-size) (put 'empire-map-size 'permanent-local t) (make-local-variable 'empire-displayed-version) (put 'empire-displayed-version 'permanent-local t) (make-local-variable 'empire-map-mark) (put 'empire-map-mark 'permanent-local t) ;; TODO: move to empterm? (if (not window-system) (setq buffer-display-table empire-highlight-display-table)) (run-hooks 'empire-map-mode-hook)) (defun empire-map () "Create an empire map in buffer *empire map*." (interactive) (or (empire-world-x) (error "World size unknown")) (switch-to-buffer (get-buffer-create "*empire-map*")) (if empire-displayed-version (empire-redraw-maps (list (current-buffer))) (empire-map-mode) (empire-draw-map 0 0) (empire-map-goto 0 0) (setq empire-map-mode-line-coord "0,0")) (or (memq (current-buffer) empire-map-buffers) (setq empire-map-buffers (cons (current-buffer) empire-map-buffers))) (add-hook 'empire-after-output-hook 'empire-redraw-changed-maps) (setq empire-tool-buffer (current-buffer)) (current-buffer)) ;;; Commands (defun empire-pop-to-client () "Select *empire* buffer in some window, preferably a different one." (interactive) (setq empire-tool-buffer (current-buffer)) (pop-to-buffer (get-buffer "*empire*")) (empire-redraw-changed-maps)) (defun empire-redraw-maps (buffers) "Redraw displayed maps for BUFFERS. When called interactively, redraw either the current buffer or, with prefix argument, all map buffers." (interactive (list (if current-prefix-arg empire-map-buffers (list (current-buffer))))) (empire-forget-killed-maps) (mapcar (function (lambda (buffer) (let ((window (get-buffer-window buffer t)) new-point) (cond (window (save-excursion (set-buffer buffer) ;; TODO: shrink window if larger than map (let ((where (empire-map-where (point)))) (empire-draw-map (empire-map-x-center) (empire-map-y-center)) (empire-map-goto (car where) (cdr where)) (setq new-point (point)))) ;; set point outside of excursion (set-window-point window new-point)))))) buffers)) (defun empire-map-recenter (&optional arg) "Center point in window and redisplay frame. With prefix arg don't redisplay frame." (interactive "P") (let ((where (empire-map-where (point)))) (empire-draw-map (car where) (cdr where)) (empire-map-goto (car where) (cdr where)) (or arg (recenter)))) (defun empire-map-goto (x y) "Move point to sector X, Y. If called interactively, prompt for coordinates." (interactive "nGoto x: \nnGoto x: %s, y: ") (let ((xoffs (empire-display-x-offs x)) (yoffs (empire-display-y-offs y))) (cond ((and xoffs yoffs) (goto-char (point-min)) (forward-line (+ empire-x-ruler-height yoffs)) (empire-move-to-column (+ empire-y-ruler-width xoffs))) (t (empire-draw-map x y) (empire-map-goto x y))))) ; recursion depth <= 1 ;; TODO: mark ring? (defun empire-set-map-mark (pos) "Set the map mark to the coordinates for POS." (interactive "d") (set-mark pos) (setq empire-map-mark (empire-map-where pos))) (defun empire-exchange-point-and-map-mark () "Set the map mark to the coordinates for point and move to the old mark." (interactive) (let ((omark empire-map-mark)) (empire-set-map-mark (point)) (empire-map-goto (car omark) (cdr omark)))) (defun empire-scroll-map-up (&optional arg) "Scroll map upward ARG lines; or near full screen if no ARG. A near full screen is `next-screen-context-lines' less than a full screen. Negative ARG means scroll downward." (interactive "P") (let ((count (if arg (prefix-numeric-value arg) (max 1 (- (empire-map-height) next-screen-context-lines))))) (empire-scroll-map 0 count))) (defun empire-scroll-map-down (&optional arg) "Scroll map downward ARG lines; or near full screen if no ARG. A near full screen is `next-screen-context-lines' less than a full screen. Negative ARG means scroll upward." (interactive "P") (let ((count (if arg (prefix-numeric-value arg) (max 1 (- (empire-map-height) next-screen-context-lines))))) (empire-scroll-map 0 (- count)))) (defun empire-scroll-map-left (&optional arg) "Scroll map left ARG columns; or near full screen if no ARG. A near full screen is `next-screen-context-lines' less than a full screen. Negative ARG means scroll right." (interactive "P") (let ((count (if arg (prefix-numeric-value arg) (max 1 (- (empire-map-width) next-screen-context-lines))))) (empire-scroll-map count 0))) (defun empire-scroll-map-right (&optional arg) "Scroll map right ARG lines; or near full screen if no ARG. A near full screen is `next-screen-context-lines' less than a full screen. Negative ARG means scroll left." (interactive "P") (let ((count (if arg (prefix-numeric-value arg) (max 1 (- (empire-map-width) next-screen-context-lines))))) (empire-scroll-map (- count) 0))) (defun empire-map-move (arg) "Move point ARG sectors. Whichever character you type to run this command determines the direction." (interactive "p") (let ((direction (assq (downcase last-command-char) empire-directions)) (where (empire-map-where (point)))) (empire-map-goto (+ (car where) (* arg (nth 1 direction))) (+ (cdr where) (* arg (nth 2 direction)))))) (defun empire-goto-current () "Move point to current coordinates, if any." (interactive) (if (empire-current-x) (empire-map-goto (empire-current-x) (empire-current-y)))) (defun empire-insert-move (arg) "Move point ARG sectors and insert the route into *empire* buffer. Whichever character you type to run this command determines the direction." (interactive "p") (let ((cmd (downcase last-command-char))) (cond ((memq cmd '(?h ?l ?r ?m ?s ?v)) (empire-insert-input (char-to-string cmd))) ((> arg 0) (empire-insert-input (make-string arg cmd)) (empire-map-move arg))))) (defun empire-send-and-goto-current () "Send input and move point to the resulting current coordinates, if any." (interactive) (empire-insert-input "\n") (empire-wait-until-non-busy t) (empire-goto-current)) (defun empire-insert-sect (pos) "Insert coordinates of sector near POS into *empire* buffer." (interactive "d") (let ((where (empire-map-where pos t))) (empire-insert-input (format "%d,%d " (car where) (cdr where))))) (defun empire-mouse-insert-sect (click) "Insert coordinates of sector clicked on into *empire* buffer." (interactive "e") (let ((where (save-excursion (set-buffer (window-buffer (posn-window (event-end click)))) (empire-map-where (posn-point (event-end click)) t)))) (empire-insert-input (format "%d,%d " (car where) (cdr where))))) (defun empire-insert-sects () "Insert coordinates of current rectangle into *empire* buffer. The current rectangle has corners at the map mark and point." (interactive) (or empire-map-mark (error "No mark set in this map.")) (let* ((where (empire-map-where (point))) (x-range (empire-pick-range (car where) (car empire-map-mark) (empire-display-x-offs (car where)) (empire-display-x-offs (car empire-map-mark)))) (y-range (empire-pick-range (cdr where) (cdr empire-map-mark) (empire-display-y-offs (cdr where)) (empire-display-y-offs (cdr empire-map-mark))))) (empire-insert-input (format "%d:%d,%d:%d " (car x-range) (cdr x-range) (car y-range) (cdr y-range))))) ;; Defunct, TODO: rewrite from scratch ;;(defun empire-mouse-insert-sects (click) ;; "Insert coordinates of dragged rectangle into *empire* buffer." ;; (interactive "e") ;; (if (eq (posn-window (event-start click)) ;; (posn-window (event-end click))) ;; ;; can't use save-excursion, need to move point in *empire* ;; ;; which may be current ;; (let ((saved-buffer (current-buffer))) ;; (unwind-protect ;; (let ((start (posn-point (event-start click))) ;; (end (posn-point (event-end click)))) ;; (set-buffer (window-buffer (posn-window (event-end click)))) ;; (empire-insert-sects (min start end) (max start end))) ;; (set-buffer saved-buffer))))) (defun empire-brief-sector (x y) "Display data for sector X, Y in the echo area. If called interactively in a map, display for sector near point." (interactive (empire-x-y-arg t)) (let* ((dump (empire-ref-dump-sector x y)) (des (empire-ref-map-sector x y)) (data (list (list "%d,%d" x y) (list " %c" des) (empire-brief-owner dump) (empire-brief-value "%c" dump 'empire-dump-index-sdes ?_) (empire-brief-value " %d%%" dump 'empire-dump-index-eff) (empire-brief-value " mob:%d" dump 'empire-dump-index-mob) (empire-brief-value " %c" dump 'empire-dump-index-* ?.) (empire-brief-value " work:%d%%" dump 'empire-dump-index-work 100) (empire-brief-value " av:%d" dump 'empire-dump-index-avail 0) (empire-brief-commo dump "cmufsgpidbolhr") (empire-brief-reso dump des)))) (apply 'message (empire-concat-format-lists data)))) (defun empire-mouse-brief-sector (click) "Display data for sector clicked on in the echo area." (interactive "e") (save-excursion (set-buffer (window-buffer (posn-window (event-end click)))) (let ((where (empire-map-where (posn-point (event-end click)) t))) (empire-brief-sector (car where) (cdr where))))) (defun empire-brief-census (x y) "Display census for sector X, Y in the echo area. If called interactively in a map, display for sector near point." (interactive (empire-x-y-arg t)) (let* ((dump (empire-ref-dump-sector x y)) (data (list (list "%d,%d" x y) (list " %c" (empire-ref-map-sector x y)) (empire-brief-owner dump) (empire-brief-value "%c" dump 'empire-dump-index-sdes ?_) (empire-brief-value " %d%%" dump 'empire-dump-index-eff) (empire-brief-value " mob:%d" dump 'empire-dump-index-mob) (empire-brief-commo dump "cmuf") (empire-brief-value " work:%d%%" dump 'empire-dump-index-work 100) (empire-brief-value " av:%d" dump 'empire-dump-index-avail 0)))) (apply 'message (empire-concat-format-lists data)))) (defun empire-brief-resources (x y) "Display resources for sector X, Y in the echo area. If called interactively in a map, display for sector near point." (interactive (empire-x-y-arg t)) (let* ((dump (empire-ref-dump-sector x y)) (data (list (list "%d,%d" x y) (list " %c" (empire-ref-map-sector x y)) (empire-brief-value "%c" dump 'empire-dump-index-sdes ?_) (empire-brief-value " %d%%" dump 'empire-dump-index-eff) (empire-brief-reso dump)))) (apply 'message (empire-concat-format-lists data)))) (defun empire-brief-commodities (x y) "Display commodities for sector X, Y in the echo area. If called interactively in a map, display for sector near point." (interactive (empire-x-y-arg t)) (let* ((dump (empire-ref-dump-sector x y)) (data (list (list "%d,%d" x y) (list " %c" (empire-ref-map-sector x y)) (empire-brief-commo dump "sgpidbolhr")))) (apply 'message (empire-concat-format-lists data)))) (defun empire-dump-sector (x y) "Send dump command for sector X, Y. If called interactively in a map, dump sector near point." (interactive (empire-x-y-arg t)) (if empire-busy (message "Can't dump now, server is busy") (empire-send-command (format "dump %d,%d >>/dev/null" x y)))) ;; TODO: implement (defun empire-highlight (n expr) (interactive "nHighlight # \nsHighlight #%s expression ") (empire-remove-map-highlight n) (empire-redraw-maps empire-map-buffers)) ;;; Functions (defun empire-update-map-coord () "Set `empire-map-current-coord' and run default value of `post-command-hook'. This may be put in a *buffer-local* `post-command-hook'." (let ((where (empire-map-where (point)))) (setq empire-map-mode-line-coord (format "%d,%d" (car where) (cdr where))) (force-mode-line-update)) (run-hooks (default-value post-command-hook))) (defun empire-forget-killed-maps () "Remove killed buffers from `empire-map-buffers'." (setq empire-map-buffers (delq nil (mapcar (function (lambda (buffer) (and (buffer-name buffer) buffer))) empire-map-buffers)))) (defun empire-redraw-changed-maps () "Redraw displayed maps that are out of date." (empire-redraw-maps (delq nil (mapcar (function (lambda (buffer) (let ((window (get-buffer-window buffer t))) (and window (save-excursion (set-buffer buffer) (or (empire-map-changed-p empire-displayed-version) (/= (empire-map-width) (empire-map-width-for-window window)) (/= (empire-map-height) (empire-map-height-for-window window)))) buffer)))) empire-map-buffers)))) (defun empire-draw-map (x y) "Draw map centered around X, Y. The current buffer must be displayed in a window." (let* ((inhibit-read-only t) (window (or (get-buffer-window (current-buffer) t) (error "Buffer not displayed, can't draw map."))) (width (empire-map-width-for-window window)) (height (empire-map-height-for-window window)) (x0 (empire-canon-x (- x (/ width 2)))) (y0 (empire-canon-y (- y (/ height 2)))) (x-ruler (empire-map-x-ruler x0 width)) (y-left-ruler-format (format "%%%dd " (1- empire-y-ruler-width))) (i 0)) (setq empire-map-center nil empire-map-size nil) (erase-buffer) (insert x-ruler) (let ((i 0) (yi y0)) (while (< i height) (insert (format y-left-ruler-format yi)) (insert (empire-format-map-row x0 yi width)) (insert (format " %d" yi)) (insert "\n") (setq i (1+ i) yi (empire-next-y yi)))) (insert x-ruler) (delete-backward-char 1) ; delete final newline (setq empire-map-center (cons x y) empire-map-size (cons width height) empire-displayed-version (empire-map-changed-p nil)))) (defun empire-map-width-for-window (window) (min (- (window-width window) (* 2 empire-y-ruler-width) 1) (empire-world-x))) (defun empire-map-height-for-window (window) (min (- (window-height window) (* 2 empire-x-ruler-height) 1) (empire-world-y))) (defun empire-map-x-ruler (x0 width) "Insert a horizontal ruler starting with X0, WIDTH sectors wide." (let ((ten (make-string (+ width empire-y-ruler-width) ?\ )) (one (make-string (+ width empire-y-ruler-width) ?\ )) (index 0) (xi x0)) (while (< index width) (let ((x (substring (format "%02d" xi) -2))) (aset ten (+ index empire-y-ruler-width) (aref x 0)) (aset one (+ index empire-y-ruler-width) (aref x 1)) (setq index (1+ index) xi (empire-next-x xi)))) (concat ten "\n" one "\n"))) (defun empire-scroll-map (delta-x delta-y) "Scroll map by DELTA-X, DELTA-Y." (let* ((where (empire-map-where (point))) (x (car where)) (y (cdr where))) (empire-draw-map (empire-canon-x (+ (empire-map-x-center) delta-x)) (empire-canon-y (+ (empire-map-y-center) delta-y))) (or (empire-display-x-offs x) (setq x (if (< delta-x 0) (+ (empire-map-left-x) (empire-map-width) -1) (empire-map-left-x)))) (or (empire-display-y-offs y) (setq y (if (< delta-y 0) (+ (empire-map-top-y) (empire-map-height) -1) (empire-map-top-y)))) (empire-map-goto x y))) (defun empire-x-y-arg (&optional valid) "Return coordinates as a list (x y). If the current buffer is a map return coordinates of point, else ask user. If optional argument VALID is non-nil, return coordinates of a valid sector." (if (empire-map-x-center) (let ((coord (empire-map-where (point) t))) (list (car coord) (cdr coord))) (call-interactively (function (lambda (x y) (interactive "nSector x: \nnSector x: %s, y: ") (or (not valid) (empire-x-y-valid-p x y) (error "Bad coordinates")) (list x y)))))) (defun empire-display-x-offs (x) "Return column X's offset from `(empire-map-left-x)' or nil if not displayed." (let ((xoffs (- x (empire-map-left-x)))) (and (<= 0 xoffs) (< xoffs (empire-map-width)) xoffs))) (defun empire-display-y-offs (y) "Return row Y's offset from `(empire-map-top-y)' or nil if not displayed." (let ((yoffs (- y (empire-map-top-y)))) (and (<= 0 yoffs) (< yoffs (empire-map-height)) yoffs))) (defun empire-pick-range (r1 r2 offs1 offs2) (cond ((not (and offs1 offs2)) ;; range not visible, pick arbitrary one (cons (min r1 r2) (max r1 r2))) ((< offs1 offs2) ;; range visible, r1 left (cons r1 r2)) (t ;; range visible, r1 right (cons r2 r1)))) (defun empire-map-where (pos &optional valid) "Convert buffer position POS to map coordinates. If optional argument VALID is non-nil, return coordinates of a valid sector near POS." (save-excursion (goto-char pos) (let ((x (+ (empire-current-column) (- empire-y-ruler-width) (empire-map-left-x))) (y (+ (empire-current-line) (- empire-x-ruler-height) -1 (empire-map-top-y)))) (or (not valid) (empire-x-y-valid-p x y) (setq x (1- x))) (cons (empire-canon-x x) (empire-canon-y y))))) (defun empire-map-x-center () "Return map center's x-coordinate." (car empire-map-center)) (defun empire-map-y-center () "Return map center's y-coordinate." (cdr empire-map-center)) (defun empire-map-left-x () "Return map's left x-coordinate." (- (car empire-map-center) (/ (car empire-map-size) 2))) (defun empire-map-top-y () "Return map's top y-coordinate." (- (cdr empire-map-center) (/ (cdr empire-map-size) 2))) (defun empire-map-width () "Return map's width." (car empire-map-size)) (defun empire-map-height () "Return map's height." (cdr empire-map-size)) (defun empire-brief-value (fmt dump key &optional uninteresting) "Return a format list to format with FMT DUMP's value for KEY. If the value is unknown or equal to optional arg UNINTERESTING, return (\"\"), else return (FMT value)." (let ((value (empire-dump-value dump key))) (if (and value (not (equal value uninteresting))) (list fmt value) '("")))) (defun empire-brief-owner (dump) "Return a format list to format DUMP's owner." (let ((owner (empire-dump-value dump 'empire-dump-index-owner))) (cond ((eq owner empire-your-cnum) '("")) ((numberp owner) (list " own:%d" owner)) (t (list " own:%c" ??))))) (defun empire-brief-commo (dump commodities) "Return a format list to format DUMP's COMMODITIES. COMMODITIES is a string of commodity characters \"cmufsgpidbolhr\". A format list is a list to which `format' can be applied." (let ((fmt "") (rev-data nil) (com-list (append commodities nil))) (while com-list (let* ((com-def (assq (car com-list) empire-commodities)) (value (empire-dump-value dump (nth 1 com-def))) (thres (empire-dump-value dump (nth 2 com-def)))) (cond ((and thres (not (eq 0 thres))) (setq fmt (concat fmt " %d/%d%c") rev-data (append (list (car com-list) thres value) rev-data))) ((and value (not (eq 0 value))) (setq fmt (concat fmt " %d%c") rev-data (append (list (car com-list) value) rev-data)))) (setq com-list (cdr com-list)))) (cons fmt (nreverse rev-data)))) (defun empire-brief-reso (dump &optional des) "Return a format list to format DUMP's resources. With optional argument DES only show resources interesting for this designation." (let ((des-interest (cdr (assq des '((?m empire-dump-index-min) (?g empire-dump-index-gold) (?a empire-dump-index-fert) (?o empire-dump-index-ocontent) (?u empire-dump-index-uran) (?- . t) (?+ . t) (nil . t) (?. empire-dump-index-fert empire-dump-index-ocontent))))) (resources (list (list 'empire-dump-index-min " min:%d" empire-high-min) (list 'empire-dump-index-gold " gold:%d" empire-high-gold) (list 'empire-dump-index-fert " fert:%d" empire-high-fert) (list 'empire-dump-index-ocontent " oil:%d" empire-high-ocontent) (list 'empire-dump-index-uran " uran:%d" empire-high-uran)))) (empire-concat-format-lists (mapcar (function (lambda (sym) (let ((reso (assq sym resources)) (value (empire-dump-value dump sym))) (and value (or (eq des-interest t) (memq sym des-interest) (>= value (nth 2 reso))) (list (nth 1 reso) value))))) '(empire-dump-index-min empire-dump-index-gold empire-dump-index-fert empire-dump-index-ocontent empire-dump-index-uran))))) (defun empire-concat-format-lists (lists) "Concatenate format lists in LISTS into a single format list. A format list is a list to which `format' can be applied." (cons (apply 'concat (mapcar 'car lists)) (apply 'append (mapcar 'cdr lists)))) ;;; empmap.el ends here empsnoop.el100444 145 12 37670 5651177440 12105 0ustar armbrustaff;;; empsnoop.el --- GENIE empire dialog snooper ;; Copyright (C) 1994 Markus Armbruster ;; Author: Markus Armbruster ;; Version: $Id: empsnoop.el,v 1.7 1994/10/19 11:12:31 armbru Exp $ ;; Keywords: games ;; This file is part of GENIE, the GNU Emacs's Nifty Interface to Empire ;; GENIE 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. ;; GENIE 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 GENIE; see the file COPYING. If not, write to the Free ;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. ;;; Commentary: ;; For general information on GENIE, see file empire.el. ;; This file defines the GENIE empire dialog snooper. It passively ;; snoops the dialog and snarfs any useful information it recognizes. ;; The natural way to snoop output line by line would be with ;; continuations, eg ;; (defun snoop-something () ;; (call/cc (lambda (escape) ;; snoop first line ;; (call/cc (lambda (continue) ;; (escape continue))) ;; snoop second line ;; (call/cc (lambda (continue) ;; (escape continue))) ;; ... ;; snoop last line ;; (escape some-value)))) ;; Calling snoop-something snoops the first line and returns a ;; continuation. Calling the continuation snoops the next line and ;; returns another continuation, etc. Calling last continuation ;; snoops the last line and returns some-value. ;; Emacs Lisp has no continuations. Nevertheless, the following code ;; is written in a (weird) continuation-like style. ;; A snoop function snoops one line of output and returns a list. The ;; list's car is the snoop function to use for the next line of ;; output, the list's cdr are arguments to pass to this function. ;; This simulates a closure. ;; If a snoop function fails, it returns a descriptive string instead. ;;; Restrictions ;; Can't snoop script execution ;;; To do ;; Snoop more commands, not just the bare minimum, perhaps plagiarize ;; Ken Steven's parse.pl ;; Consider using cl's lexical-let for closures ;;; Code: (require 'emputil) (require 'empdata) (provide 'empsnoop) ;;; Variables (defvar empire-snooper-alist '(("version" empire-snoop-version) ("map" empire-snoop-map) ("bmap" empire-snoop-map) ("sect" empire-snoop-sect) ("dump" empire-snoop-dump) ("explore" empire-snoop-explore) ("country" empire-snoop-country) ("relations" empire-snoop-relations)) "Alist associating empire commands with snoop closures.") (defvar empire-snoop-closure nil "List that specifies how to snoop the next line of output. The list's car is a function that takes (1+ (length list)) arguments.") ;;; Functions (add-hook 'empire-login-hook 'empire-init-snoop) (defun empire-init-snoop () "Initialize the empire dialog snooper." (setq empire-output-filter 'empire-snoop empire-snoop-closure nil) (empire-wait-until-non-busy) ;; get world size, etc from version (empire-send-command "version >>/dev/null") (empire-wait-until-non-busy) (or (empire-world-x) (error "Can't determine world size")) ;; get your country number (let ((cnum 1)) (while (and (not empire-your-cnum) (< cnum empire-number-of-countries)) (empire-send-command (format "relations %d >>/dev/null" cnum)) (empire-wait-until-non-busy) (setq empire-your-cnum (empire-ref-cnum empire-country)) (setq cnum (1+ cnum)))) (or empire-your-cnum (error "Can't determine country number")) ;; double check country number (setq empire-command-failed nil) (empire-send-command (format "dump * ?own#%d >>/dev/null" empire-your-cnum)) (empire-wait-until-non-busy) (if empire-command-failed (setq empire-command-failed nil) (setq empire-your-cnum nil) (error "Incorrect country number"))) (defun empire-snoop (tag string) "Snoop a line TAG, STRING. This function should be in `empire-client-output-filter'." (cond ((eq tag 'prompt) ;; abort current snoop (setq empire-snoop-closure nil)) ((memq tag '(data flush)) ;; if there is no current snoop, create one (cond ((not empire-snoop-closure) (setq empire-snoop-closure (or (empire-get-snooper empire-current-input) '(ignore))) (empire-set-current-coord nil nil))) ;; continue current snoop (let ((cont nil)) (unwind-protect (setq cont (apply (car empire-snoop-closure) tag string (cdr empire-snoop-closure))) (cond ((listp cont) (setq empire-snoop-closure (or cont '(ignore)))) (t (message "Snooping failed: %s" cont) (setq empire-snoop-closure '(ignore)))))))) (if (and (eq tag 'data) (string-match "\\(^\".*\" is ambiguous --\\|^\".*\" is not a legal command\\|^You don't have the BTU's\\|^Command not implemented\\|^\\(Update in progress...\\)?command failed\\|^Usage: \\)\\|\\(^You have .* new announcements? waiting\\)\\|\\(^You have .* new telegrams? waiting\\)" string)) (cond ((match-end 1) (setq empire-command-failed t)) ((match-end 2) (setq empire-anno-waiting t)) ((match-end 3) (setq empire-tele-waiting t)))) string) (defun empire-get-snooper (string) "Return the snooper closure to snoop command STRING." (and (string-match "[^ \t\n]+" string) (let ((cmd-regexp (concat "^" (regexp-quote (substring string (match-beginning 0) (match-end 0))))) (alist empire-snooper-alist)) (while (and alist (not (string-match cmd-regexp (car (car alist))))) (setq alist (cdr alist))) (cdr (car alist))))) ;; Version (defun empire-snoop-version (tag string) (cond ((string-match "^World size is \\([0-9]+\\) by \\([0-9]+\\).$" string) (or (empire-set-world-size (empire-string-match-to-number 1 string) (empire-string-match-to-number 2 string)) (error "Bad world size"))) ((string-match "^There can be up to \\([0-9]+\\) countries.$" string) (setq empire-number-of-countries (empire-string-match-to-number 1 string)))) '(empire-snoop-version)) ;; Map ;; Snoop a line up to the first line of the map header (defun empire-snoop-map (tag string) (if (eq tag 'flush) '(empire-snoop-map) ; ignore flushs ;; snoop first line of header (if (string-match "^ +\\([-0-9][-0-9]+\\)" string) (let ((left (match-beginning 1))) (list 'empire-snoop-map-1 left (match-end 1) (substring string left (1+ left)) (substring string (1+ left) (+ left 2)))) "Can't find map header"))) ;; Snoop a trailing line of a map header ;; LEFT is the ruler's beginnning ;; RIGHT is the ruler's end ;; COL0 is a digit string describing the leftmost x-coordinate ;; COL1 is a digit string describing the next x-coordinate (defun empire-snoop-map-1 (tag string left right col0 col1) (if (and (string-match "^ +\\([0-9][0-9]+\\)" string) (eq (match-beginning 1) left)) ;; this is a header line (list 'empire-snoop-map-1 left right (concat col0 (substring string left (1+ left))) (concat col1 (substring string (1+ left) (+ left 2)))) ;; must be the map body (empire-snoop-map-2 tag string left right (let ((x0 (string-to-number col0))) (if (and (> x0 0) (> x0 (string-to-number col1))) (- x0) x0))))) ;; Snoop a map body line ;; LEFT is the beginning of the map interior ;; RIGHT is the end of the map interior ;; X0 is the leftmost x-coordinate (defun empire-snoop-map-2 (tag string left right x0) (if (string-match "^ *\\(-?[0-9]+\\) .* \\1" string) ;; this is a body line (let ((y (string-to-number (substring string (match-beginning 1) (match-end 1))))) (empire-snoop-map-row string left right x0 y) (list 'empire-snoop-map-2 left right x0)) ;; must be the map footer (empire-snoop-map-3 tag string left right))) ;; Snoop a map footer line ;; LEFT is the ruler's beginnning ;; RIGHT is the ruler's end (defun empire-snoop-map-3 (tag string left right) (if (and (string-match "^ +\\([-0-9]+\\)" string) (eq (match-beginning 1) left)) ;; this is a footer line (list 'empire-snoop-map-3 left right) ;; we are done nil)) (defun empire-snoop-sect (tag string) (empire-remove-map-highlight 0) (empire-snoop-map tag string)) (defun empire-snoop-map-row (string left right x y) "Snoop map row in STRING between LEFT andf RIGHT, leftmost sector is at X, Y." (or (empire-x-y-valid-p x y) (setq left (1+ left) x (1+ x))) (let ((row (make-string (/ (- (1+ right) left) 2) 0)) (index 0)) (while (< left right) (aset row index (aref string left)) (setq index (1+ index) left (+ left 2))) (empire-update-map-row x y row))) ;; Dump ;; Snoop a line up to `DUMP SECTOR' (defun empire-snoop-dump (tag string) (if (or (eq tag 'flush) (not (string= "DUMP SECTOR\n" string))) '(empire-snoop-dump) '(empire-snoop-dump-1))) ;; Snoop the dump header line (defun empire-snoop-dump-1 (tag string) (if (string-match "\\" string) (list 'empire-snoop-dump-2 (mapcar 'empire-dump-index (empire-split string "[ \n]+"))) "Can't find dump")) ;; Snoop a dump data line or the final number of sectors line ;; HEADER is a list of dump index symbols describing the dump's fields. (defun empire-snoop-dump-2 (tag string header) (if (string-match "^[0-9]+ sector" string) nil ; we are done (let* ((alist (empire-mapcar 'cons header (empire-split string "[ \n]+"))) (x (string-to-number (cdr (assq 'empire-dump-index-x alist)))) (y (string-to-number (cdr (assq 'empire-dump-index-y alist)))) (des (cdr (assq 'empire-dump-index-des alist))) (dump (cons (cons 'empire-dump-index-owner empire-your-cnum) (empire-dump-filter alist)))) (if des (empire-update-map-sector x y (string-to-char des))) (empire-update-dump-sector x y dump)) (list 'empire-snoop-dump-2 header))) ;; Explore ;; Snoop a line from prompt or flush up to an explore map's first line (defun empire-snoop-explore (tag string) (cond ((eq tag 'flush) '(empire-snoop-explore)) ; ignore flushs ((string-match " \\([^ \n] [^ \n]\\) +\\(\\<\\).*min" string) ;; this is a explore map's first line (list 'empire-snoop-explore-1 (match-beginning 0) (list (substring string (match-beginning 1) (match-end 1))) (match-beginning 2) (empire-split-header string (match-beginning 2)))) ((string-match "\\([0-9]+\\) mob left in \\(-?[0-9]+\\),\\(-?[0-9]+\\)" string) ;; trailing mobility cost line (empire-update-dump-sector (empire-string-match-to-number 2 string) (empire-string-match-to-number 3 string) (list (cons 'empire-dump-index-mob (empire-string-match-to-number 1 string)))) '(empire-snoop-explore)) ((string-match "Sector \\(-?[0-9]+\\),\\(-?[0-9]+\\) is now yours" string) ;; trailing ownership line (empire-update-dump-sector (empire-string-match-to-number 1 string) (empire-string-match-to-number 2 string) (list (cons 'empire-dump-index-owner empire-your-cnum))) '(empire-snoop-explore)) (t ;; other blabla '(empire-snoop-explore)))) ;; Snoop an explore map's second line ;; MAP-INDENT is the map's indentation ;; MAP is a list containing the first map line's map string. ;; RESO-INDENT is the resource table's indentation ;; RESO describes the resource header (produced by empire-split-header) (defun empire-snoop-explore-1 (tag string map-indent map reso-indent reso) (if (and (string-match " \\([^ \n] [^ \n] [^ \n]\\) " string) (= map-indent (match-beginning 1))) (list 'empire-snoop-explore-2 map-indent (cons (substring string (match-beginning 1) (match-end 1)) map) (empire-dump-filter (empire-mapcar 'cons (car reso) (cdr (empire-split-at string (cons reso-indent (cdr reso))))))) "Can't find explore map")) ;; Snoop an explore map's third line ;; MAP-INDENT is the map's indentation ;; MAP is a list containing the first two map lines' map strings (reversed). ;; RESO is an alist describing the resources (defun empire-snoop-explore-2 (tag string map-indent map reso) (cond ((and (string-match " \\([^ \n] [^ \n]\\)" string) (= map-indent (match-beginning 0))) (list 'empire-snoop-explore-3 (cons (substring string (match-beginning 1) (match-end 1)) map) reso)) (t "Can't find explore map"))) ;; Snoop explore sub-prompt line ;; MAP-INDENT is the map's indentation ;; MAP is a list containing the map lines' map strings (reversed). ;; RESO is an alist describing the resources (defun empire-snoop-explore-3 (tag string map reso) (if (and (eq tag 'flush) (string-match "^<.*: . \\(-?[0-9]+\\),\\(-?[0-9]+\\)>" string)) (let ((x (empire-string-match-to-number 1 string)) (y (empire-string-match-to-number 2 string))) (empire-update-dump-sector x y reso) (empire-snoop-map-row (nth 2 map) 0 3 (1- x) (1- y)) (empire-snoop-map-row (nth 1 map) 0 5 (- x 2) y) (empire-snoop-map-row (nth 0 map) 0 3 (1- x) (1+ y)) (empire-set-current-coord x y) ;; redo from start '(empire-snoop-explore)) "Can't find explore prompt")) ;; Country ;; Snoop a country line up to header (defun empire-snoop-country (tag string) (if (string-match "^ *# *last access" string) '(empire-snoop-country-1) '(empire-snoop-country))) ;; Snoop a country body line (defun empire-snoop-country-1 (tag string) (if (not (string-match " *\\([0-9]+\\).+\\([^ ]+\\)$" string)) nil (empire-set-country (empire-string-match-to-number 1 string) (substring string (match-beginning 1) (match-end 1))) '(empire-snoop-country-1))) ;; Relations ;; Snoop a relations line up to header (defun empire-snoop-relations (tag string) (if (string-match "^ *Formal Relations" string) '(empire-snoop-relations-1) '(empire-snoop-relations))) ;; Snoop a relations body line (defun empire-snoop-relations-1 (tag string) (if (not (string-match " *\\([0-9]+\\)) +\\([^ ]+\\)" string)) nil ;; TODO: remember relations (empire-set-country (empire-string-match-to-number 1 string) (substring string (match-beginning 1) (match-end 1))) '(empire-snoop-relations-1))) ;; Utilities (defun empire-string-match-to-number (arg string) "Convert ARG-th match in STRING to a number with `string-to-number'." (string-to-number (substring string (match-beginning arg) (match-end arg)))) (defun empire-split (string split-regexp) "Split STRING at SPLIT-REGEXP, return list of pieces." (let ((pieces nil) (start (if (string-match (concat "^" split-regexp) string) (match-end 0) ; skip leading split-regexp 0))) (while (string-match split-regexp string start) (setq pieces (cons (substring string start (match-beginning 0)) pieces) start (match-end 0))) (nreverse (if (= start (length string)) pieces (cons (substring string start) pieces))))) (defun empire-split-header (string start) "Split STRING beginning with START at space or newline. Return the list of pieces and the list of pieces' end positions in STRING consed together." (let ((pieces nil) (positions nil)) (while (string-match "[ \n]+" string start) (setq pieces (cons (substring string start (match-beginning 0)) pieces) positions (cons (match-beginning 0) positions) start (match-end 0))) (if (/= start (length string)) (setq pieces (cons (substring string start) pieces) positions (cons (length string) positions))) (cons (nreverse pieces) (nreverse positions)))) (defun empire-split-at (string positions) "Split STRING at POSITIONS, return list of pieces." (let ((pieces nil) (start 0)) (while positions (setq pieces (cons (substring string start (car positions)) pieces) start (car positions) positions (cdr positions))) (nreverse pieces))) empsubst.el100444 145 12 47471 5651177665 12120 0ustar armbrustaff;;; empsubst.el --- GENIE Variable & Function expansion for Empclient ;; Copyright (C) 1994 Markus Armbruster ;; Author: Markus Armbruster ;; Version: $Id: empsubst.el,v 1.7 1994/10/19 11:15:01 armbru Exp $ ;; Keywords: games ;; This file is part of GENIE, the GNU Emacs's Nifty Interface to Empire ;; GENIE 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. ;; GENIE 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 GENIE; see the file COPYING. If not, write to the Free ;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. ;;; Commentary: ;; For general information on GENIE, see file empire.el. ;; This file extends Empclient by a variable and function expansion ;; mechanism. Some functions to get help, set variables and define ;; aliases are predefined. ;; Meta-Characters ;; The following characters have special meanings: ;; \\ backslash ;; ' single quote ;; \" double quote ;; @ jolly alpha ;; $ dollar ;; \t tab ;; \n newline ;; ; semicolon ;; ? question mark ;; [ ] brackets ;; Quoting ;; A backslash quotes the following character. ;; Everything between single quotes is quoted. ;; Space, tab, single quote, semicolon, newline and jolly alpha are ;; quoted between double quotes. ;; Quoted meta-characters loose their special meaning. ;; Comments ;; A jolly alpha introduces a comment that extends up to the end of ;; the line excluding the newline. ;; Variable Expansion ;; `$NAME' or `${NAME}' expands into the value bound to variable NAME. ;; NAME consists of letters, digits and underscores. ;; Function Expansion ;; Newlines and semicolons separate commands. Every command is ;; scanned from left to right. Everything between brackets is an ;; function call and is expanded recursively. Then the command is ;; split into words separated by spaces or tabs. If the first word is ;; bound as a function, the call is expanded into the result of ;; applying this function to the remaining words. If a top level ;; command function-expands into the empty string, the command is ;; removed completely. ;; Command Splitting ;; Every line is split into commands at semicolons. A command ;; starting with a question mark is called sub-command; the question ;; mark is removed. Non-sub-commands are called proper commands. ;; Proper commands after semicolons abort the preceding command if it ;; is still prompting for arguments. ;; Sub-commands are ignored unless they are prompted for. ;; Empty proper commands after semicolons are ignored. Hence, if you ;; terminate a line with a semicolon, the last command completes or is ;; aborted. Useful for scripts. ;; Defining Functions ;; The macro `empire-subst-defun' feels very much like `defun' but ;; binds words for function expansion instead. The value of the such ;; a function must be a string and is used as expansion. The function ;; may call `insert' to print messages. The predefined functions are ;; implemented this way and serve as examples. ;; Predefined Functions ;; The predefined functions are self-documenting. Use function `help' ;; to browse their documentation. ;; Accessing Variables and Functions from Lisp ;; Use `(empire-user-symbol NAME)' to get the symbol used for the ;; string NAME. ;;; Summary of User Options ;; empire-unbound-var-error signal error on unbound variables ;; empire-unbound-fun-error signal error on unbound functions ;; (only for bracketed calls) ;;; Restrictions ;; Neither variables nor functions can be made buffer local. ;;; To do ;; Function "source" ;;; Code: (require 'empclient) (provide 'empsubst) ;;; User options (defvar empire-unbound-var-error nil "*If non-nil, expanding unbound variables givs an error instead of \"\".") (defvar empire-unbound-fun-error nil "*If non-nil, expanding unbound functions below top level gives an error.") ;;; Variables (defvar empire-user-obarray (make-vector 109 0) "Obarray for user symbols.") ;;; Functions (add-hook 'empire-client-mode-hook 'empire-init-subst) (defun empire-init-subst () "Initialize the empire substitution tool." (add-hook 'empire-input-filter-functions 'empire-substitute) (setq empire-input-split-function 'empire-split-command)) (defun empire-substitute (string) "Return STRING with substitutions performed." (empire-subst-fun (empire-subst-var (empire-unquote string)))) (defun empire-split-command (string) "Split string at semicolons into commands. Strip question mark form sub-commands and prefix them with `at-flush-or-ignore'. Remove non-leading empty proper commands. Prefix non-leading proper commands with `at-prompt-or-abort'." (let ((cmds (apply 'append (mapcar (function (lambda (cmd) (let ((first (string-match "[^ \t]" cmd))) (cond ((not first) (list 'at-prompt-or-abort)) ((eq ?? (aref cmd first)) (list 'at-flush-or-ignore (substring cmd (1+ first)))) (t (list 'at-prompt-or-abort (substring cmd first))))))) (empire-split-unquoted string ";"))))) (if (eq (car cmds) 'at-prompt-or-abort) (setq cmds (cdr cmds))) ; undo prefixing leading proper (if (or (stringp (car cmds)) (not string)) cmds (cons "" cmds)))) ; undo removal of leading empty proper (defun empire-user-symbol (name) "Map string NAME to symbol." (intern name empire-user-obarray)) (defun empire-subst-error (fmt &rest args) "Like function `error', but inserts message in current buffer." (insert (apply 'format fmt args)) (insert "\n") (error "Bad substitution")) (defun empire-split-unquoted (string split-regexp) "Split STRING at unquoted SPLIT-REGEXP, return list of pieces." (and string (let ((cmds nil) (start 0) (copied 0)) (while (string-match split-regexp string start) (if (and (not (get-text-property (match-beginning 0) 'empire-quoted string)) (= (next-single-property-change (match-beginning 0) 'empire-quoted string (match-end 0)) (match-end 0))) (setq cmds (cons (substring string copied (match-beginning 0)) cmds) copied (match-end 0))) (setq start (match-end 0))) (nreverse (cons (substring string copied) cmds))))) ;; Quote & comment removal (defun empire-unquote (string) "Return string with quotes and comments removed. Quoted characters get a non-nil empire-quoted text property instead. Everything between single quotes is quoted. Spaces, tabs, newlines and semicolons between double quotes are quoted. The character after a backslash is quoted. A comment starts with a jolly alpha and extends to the end of the line. Quoted empty strings are replaced by an unquoted quote, which is recognized and removed by function `empire-unquote-hack'. This is a hack." (let ((result "") (start 0)) (while (string-match "['\"\\\\@]" string start) (setq result (concat result (substring string start (match-beginning 0)))) (setq start (match-end 0)) (let ((found (aref string (1- start))) sub-str) (cond ((= ?' found) (or (string-match "'" string start) (empire-subst-error "Unclosed quote %s" (substring string (1- start)))) (setq sub-str (substring string start (match-beginning 0)) start (match-end 0)) (put-text-property 0 (length sub-str) 'empire-quoted t sub-str)) ((= ?\" found) (or (string-match "\"" string start) (empire-subst-error "Unclosed doublequote %s" (substring string (1- start)))) (setq sub-str (substring string start (match-beginning 0)) start (match-end 0)) (let ((sub-start 0)) (while (string-match "[ \t';\n@]+" sub-str sub-start) (put-text-property (match-beginning 0) (match-end 0) 'empire-quoted t sub-str) (setq sub-start (match-end 0))))) ((= ?\\ found) (or (< start (length string)) (empire-subst-error "Trailing \\")) (setq sub-str (substring string start (1+ start)) start (1+ start)) (put-text-property 0 1 'empire-quoted t sub-str)) ((= ?@ found) (setq sub-str "\n") (setq start (if (string-match "\n" string (match-end 0)) (match-end 0) (length string))))) (setq result (concat result (if (zerop (length sub-str)) "'" sub-str))))) (concat result (substring string start)))) (defun empire-unquote-hack (string) "Return string with unquoted single quotes removed." (let ((start 0)) (while (string-match "'" string start) (if (get-text-property (match-beginning 0) 'empire-quoted string) (setq start (match-end 0)) (setq string (empire-string-replace-match "" string) start (match-beginning 0)))) string)) ;; Variable expansion (defun empire-subst-var (string) "Return STRING with variables expanded. A variable looks like `$name' or `${name}', where name matches [a-zA-Z_0-9]+. It is expanded into the value of (empire-user-symbol name)." (let ((result "") (start 0)) (while (string-match "$[{a-zA-Z_0-9]" string start) (cond ((or (get-text-property (match-beginning 0) 'empire-quoted string) (get-text-property (1- (match-end 0)) 'empire-quoted string)) (setq result (concat result (substring string start (1- (match-end 0))))) (setq start (1- (match-end 0)))) (t (setq result (concat result (substring string start (match-beginning 0)))) (let (var) (cond ((= ?{ (aref string (1- (match-end 0)))) (let* ((vstart (match-end 0)) (vend (string-match "}" string vstart))) (setq var (substring string vstart vend)) (or (and vend (string-match "\\`[a-zA-Z_0-9]+\\'" var)) (empire-subst-error "Bad substitution `%s'" var)) (setq start (1+ vend)))) (t (let* ((vstart (1- (match-end 0))) (vend (or (string-match "[^a-zA-Z_0-9]" string vstart) (length string)))) (setq var (substring string vstart vend)) (setq start vend)))) (let ((varsym (empire-user-symbol var))) (cond ((boundp varsym) (setq result (concat result (symbol-value varsym)))) (empire-unbound-var-error (empire-subst-error "Unbound variable `%s'" var)))))))) (concat result (substring string start)))) ;; Function expansion (defun empire-subst-fun (string) "Return STRING with function calls expanded. A top level function call looks like `fun arg1 arg2 ...', inner function calls are bracketed with `[' and `]'. Calls are expanded into the value of (apply (empire-user-symbol fun) (list arg1 arg2 ...)). Unquoted single quotes are removed. See function `empire-unquote'." (setq string (concat string "\n")) (let ((pieces nil) (start 0)) (while (< start (length string)) (let ((result (empire-subst-fun-1 string start t))) (if (cdr result) (setq pieces (cons (cdr result) pieces))) (setq start (car result)))) (and pieces (mapconcat 'identity (nreverse pieces) ";")))) ;; Expand function call in STRING starting at START. If TOP, this is ;; at top level. Return pair (END . EXPANSION), where END is the end ;; of the call and EXPANSION its expansion. (defun empire-subst-fun-1 (string start top) (catch 'return (let ((result "") (copied start)) (while (string-match "[][\n;]" string start) (if (get-text-property (match-beginning 0) 'empire-quoted string) (setq start (match-end 0)) (let ((found (aref string (match-beginning 0)))) (if (/= copied (match-beginning 0)) (setq result (concat result (substring string copied (match-beginning 0))))) (cond ((= ?\[ found) (let ((sub (empire-subst-fun-1 string (match-end 0) nil))) (setq result (concat result (cdr sub))) (setq start (car sub)) (setq copied start))) (t ; ?\[ ?\n ?\; (if (eq top (= ?\] found)) (error "Mismatched brackets")) (let ((end (match-end 0)) (pieces (mapcar 'empire-unquote-hack (delete "" (empire-split-unquoted result "[ \t]"))))) (cond ((and (car pieces) (fboundp (empire-user-symbol (car pieces)))) (setq result (apply (empire-user-symbol (car pieces)) (cdr pieces))) (and top (zerop (length result)) (setq result nil))) ((and (not top) empire-unbound-fun-error) (empire-subst-error "Unbound function `%s'" (car pieces))) (t (empire-unquote-hack result) (if (= found ?\]) (setq result (concat "[" result "]"))))) (throw 'return (cons end result)))))))) (empire-subst-error "Mismatched brackets")))) ;; Predefined Functions (defmacro empire-subst-defun (name arglist docstring &rest body) "Define function expansion method for NAME. Syntax like defun: (empire-subst-defun NAME ARGLIST DOCSTRING BODY...), but NAME is a string and DOCSTRING is mandatory." (` (fset (empire-user-symbol (, name)) (function (lambda (, arglist) (, docstring) (,@ body)))))) (empire-subst-defun "help" (&rest names) "help [name ...] Print documentation about the specified names, expand to the empty string. Without arguments print brief help for all functions, except aliases." (if names (mapcar (function (lambda (name) (insert (if (fboundp (empire-user-symbol name)) (empire-subst-documentation (empire-user-symbol name)) (format "%s is not bound" name))) (insert "\n"))) names) (insert "Type `help NAME' to find out more about NAME.\n") (mapatoms (function (lambda (symbol) (if (and (fboundp symbol) (not (get symbol 'empire-alias))) (insert (format "%s\n" (empire-subst-documentation symbol t)))))) empire-user-obarray)) "") (defun empire-subst-documentation (symbol &optional brief) "Return SYMBOL's documentation as user function. If optional arg BRIEF is non-nil, return at most one line." (let ((name (symbol-name symbol))) (if (get symbol 'empire-alias) (format "%s is aliased to %s" name (get symbol 'empire-alias)) (let ((docstring (documentation symbol))) (cond ((not docstring) (format "%s is not documented" name)) (brief (substring docstring 0 (or (string-match "\n" docstring) (length docstring)))) (t docstring)))))) (empire-subst-defun ":" (&rest args) ": ... No effect, just expand to the empty string." "") (empire-subst-defun "set" (&optional name value) "set [name [value]] Set variable NAME to VALUE, expand to the empty string. If VALUE is omitted, assume the empty string. If both are omitted, print variable bindings." (if name (set (empire-user-symbol name) (or value "")) (mapatoms (function (lambda (symbol) (if (boundp symbol) (insert (format "%s=%s\n" (symbol-name symbol) (symbol-value symbol)))))) empire-user-obarray)) "") (empire-subst-defun "unset" (name &rest more-names) "unset name ... Remove the specified variables, expand to the empty string." (mapcar (function (lambda (name) (makunbound (empire-user-symbol name)))) (cons name more-names)) "") (empire-subst-defun "print" (&rest args) "print ... Print arguments, expand to the empty string." (insert (mapconcat 'identity args " ")) (insert "\n") "") (empire-subst-defun "alias" (&optional name &rest value) "alias [name [value ...]] Define NAME to be an alias for VALUE ..., expand to the empty string. An alias is a special kind of function. It expands into VALUE ... with occurences of !N replaced by the N-th argument, !N-M by the N-th to the M-th argument separated by spaces and likewise !N- by all arguments from the N-th on. If VALUE is omitted, print alias NAME. Without arguments, print all aliases." (if name (let ((symbol (empire-user-symbol name))) (cond (value (let ((string (mapconcat 'identity value " "))) (remove-text-properties 0 (length string) '(empire-quoted nil) string) (empire-define-alias symbol string))) ((and (fboundp symbol) (get symbol 'empire-alias)) (insert (empire-subst-documentation symbol)) (insert "\n")) (t (empire-subst-error "alias: `%s' not found" name)))) (mapatoms (function (lambda (symbol) (cond ((and (fboundp symbol) (get symbol 'empire-alias)) (insert (empire-subst-documentation symbol)) (insert "\n"))))) empire-user-obarray)) "") (empire-subst-defun "unalias" (name &rest more-names) "unalias name ... Remove the specified aliases, expand to the empty string." (mapcar (function (lambda (name) (let ((symbol (empire-user-symbol name))) (if (not (get symbol 'empire-alias)) (empire-subst-error "unalias: `%s' not found" name) (fmakunbound symbol) (put symbol 'empire-alias nil))))) (cons name more-names)) "") (defun empire-define-alias (symbol string) "Set SYMBOL's function cell to an alias expander for STRING." (let ((pieces nil) (start 0) (copied 0)) ;; Parse STRING into list PIECES. ;; Elements are strings or lisp expressions that access the ;; argument list ARGS. (while (string-match "!\\([0-9]+\\)\\(-\\([0-9]+\\)?\\)?" string start) (let ((n (string-to-number (substring string (match-beginning 1) (match-end 1)))) (m (and (match-end 2) (if (match-end 3) (string-to-number (substring string (match-beginning 3) (match-end 3))) 'rest)))) (setq start (match-end 0)) (or (> n 0) (not m) (eq m 'rest) (<= n m) (empire-subst-error "alias: bad substitution `%s'" (substring string (match-beginning 0) (match-end 0)))) (cond ((not (get-text-property (match-beginning 0) 'empire-quoted string)) (setq pieces (cons (substring string copied (match-beginning 0)) pieces)) (cond ((not m) (setq pieces (cons (list ', (list 'nth (1- n) 'args)) pieces))) ((eq m 'rest) (setq pieces (cons (list ', (list 'mapconcat '(quote identity) (list 'nthcdr (1- n) 'args) " ")) pieces))) (t (while (<= n m) (setq pieces (cons " " (cons (list ', (list 'nth (1- n) 'args)) pieces))) (setq n (1+ n))) (setq pieces (cdr pieces)))))) (setq copied start))) (if pieces (setq pieces (cons (substring string copied (length string)) pieces)) ;; no !, append all arguments (setq pieces (cons (list ', (list 'mapconcat '(quote identity) 'args " ")) (list (concat string " "))))) ;; build function from PIECES (fset symbol (` (lambda (&rest args) (let ((save (symbol-function (quote (, symbol))))) (unwind-protect (progn (fmakunbound (quote (, symbol))) (empire-filter-input (apply 'concat ((, (intern "`")) (, (nreverse pieces)))) empire-input-filter-functions)) (fset (quote (, symbol)) save)))))) (put symbol 'empire-alias string))) (empire-subst-defun "eval" (&rest args) "eval ... Re-expand the arguments." (let ((string (mapconcat 'identity args " "))) (remove-text-properties 0 (length string) '(empire-quoted nil) string) (empire-filter-input string empire-input-filter-functions))) (empire-subst-defun "lisp" (&rest args) "lisp ... Expand into the arguments evaluated as lisp expression. Precisely: concatenate arguments separated with spaces, evaluate, convert to string." (let* ((string (mapconcat 'identity args " ")) (pair (read-from-string string))) (or (= (cdr pair) (length string)) (error "Trailing garbage following expression")) (format "%s" (eval (car pair))))) ;;; empsubst.el ends here empterm.el100444 145 12 6760 5642566261 11675 0ustar armbrustaff;;; empterm.el --- Functions used by GENIE on character terminals ;; Copyright (C) 1994 Markus Armbruster ;; Author: Markus Armbruster ;; Version: $Id: empterm.el,v 1.2 1994/07/25 09:25:14 armbru Exp $ ;; Keywords: games ;; This file is part of GENIE, the GNU Emacs's Nifty Interface to Empire ;; GENIE 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. ;; GENIE 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 GENIE; see the file COPYING. If not, write to the Free ;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. ;;; Commentary: ;; For general information on GENIE, see file empire.el. ;; This file contains definitions specific to character terminals. ;; See empwin.el for window system specific stuff. ;; Entry points: ;; empire-highlight-string ;; To do: ;; Reuse display characters & glyphs ;; Terminal independence, don't assume VT-style escapes ;; Document the non-obvious glyph hackery ;;; Code: (require 'disp-table) (provide 'empterm) (defvar empire-highlight-display-table (make-display-table) "Display table to display map highlights.") (defvar empire-glyph-formats (vector nil "\e[1m%c\e[m" "\e[7m%c\e[m" "\e[1;7m\%c\e[m") "Array of highlight glyph formats. The array index encodes the combination highlights: bit I is on iff highlight I is active. Array elements are used to make glyph strings from characters with (format array-element char).") (defvar empire-highlight-xlat (vector nil (make-string 94 ?\ )) "Array of translation tables mapping ordinary characters to display characters. To display C with highlight index I use (aref (aref xlat I) C).") (defvar empire-next-highlight-xlat 0 "The next character to use as display character.") (defun empire-highlight-string (string start end prop-list) "Modify STRING between START and END to highlight it according to PROP-LIST." (let ((index (empire-highlight-index prop-list))) (if (/= 0 index) (let ((xlat (aref empire-highlight-xlat index))) (while (< start end) (let* ((char (aref string start)) (xlat-index (empire-highlight-xlat-index char))) (cond ((and (<= 0 xlat-index) (< xlat-index (length xlat))) (if (= ?\ (aref xlat xlat-index)) (empire-create-highlight-xlat char index)) (aset string start (aref xlat xlat-index)))) (setq start (1+ start)))))) string)) (defun empire-create-highlight-xlat (char index) "Create a translation for CHAR with highlight INDEX." (if (> empire-next-highlight-xlat 255) (error "Highlights exhausted display table")) (aset empire-highlight-display-table empire-next-highlight-xlat (vector (create-glyph (format (aref empire-glyph-formats index) char)))) (aset (aref empire-highlight-xlat index) (empire-highlight-xlat-index char) empire-next-highlight-xlat) (setq empire-next-highlight-xlat (1+ empire-next-highlight-xlat)) (if (= empire-next-highlight-xlat ?\ ) (setq empire-next-highlight-xlat 128))) (defun empire-highlight-xlat-index (char) "Return CHAR's index in an element of `empire-highlight-xlat'." (- char ?\ 1)) ;;; empterm.el ends here emputil.el100444 145 12 10402 5614701320 11671 0ustar armbrustaff;;; emputil.el --- Common utilities for GENIE ;; Copyright (C) 1994 Markus Armbruster ;; Author: Markus Armbruster ;; Version: $Id: emputil.el,v 1.4 1994/07/25 09:16:00 armbru Exp $ ;; Keywords: games ;; This file is part of GENIE, the GNU Emacs's Nifty Interface to Empire ;; GENIE 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. ;; GENIE 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 GENIE; see the file COPYING. If not, write to the Free ;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. ;;; Commentary: ;; For general information on GENIE, see file empire.el. ;; This file defines some general utility functions. ;;; Code: (provide 'emputil) (defun empire-current-line () "Return current line number." (+ (count-lines 1 (point)) (if (zerop (current-column)) 1 0))) (defun empire-current-column () "Return distance of point from beginning of line. Unlike `current-column', this function ignores the actual width of the characters' displayed representation." (save-excursion (let ((opoint (point))) (beginning-of-line) (- opoint (point))))) (defun empire-current-indentation () "Return distance of the first non-blank character from beginning of line. Unlike `current-indentation', this function ignores the actual width of the characters' displayed representation." (save-excursion (back-to-indentation) (let ((opoint (point))) (beginning-of-line) (- opoint (point))))) (defun empire-move-to-column (col) "Move point to COL-th character in current line. Unlike `move-to-column', this function ignores the actual width of the characters' displayed representation." (save-restriction (let ((bol (progn (beginning-of-line) (point))) (eol (progn (end-of-line) (point)))) (narrow-to-region bol eol) (goto-char (point-min)) (forward-char col)))) (defun empire-string-replace-match (newtext string) "Replace text matched by last call to `string-match' with NEWTEXT in STRING. Treat `\' in NEWTEXT as special: `\&' in NEWTEXT means substitute original matched text. `\N' means substitute what matched the Nth `\(...\)'. If Nth parens didn't match, substitute nothing. `\\' means insert one `\'." (let ((prefix (substring string 0 (match-beginning 0))) (suffix (substring string (match-end 0))) (replacement nil) (start 0)) (save-match-data (while (string-match "\\\\\\(&\\|[0-9]+\\|\\\\\\)" newtext start) (setq replacement (cons (cond ((= ?& (aref newtext (1+ (match-beginning 0)))) 0) ((= ?\ (aref newtext (1+ (match-beginning 0)))) "\\") (t (string-to-number (substring newtext (1+ (match-beginning 0)) (match-end 0))))) (cons (substring newtext start (match-beginning 0)) replacement))) (setq start (match-end 0))) (setq replacement (cons (substring newtext start) replacement))) (concat prefix (mapconcat (function (lambda (elt) (cond ((stringp elt) elt) ((numberp elt) (substring string (match-beginning elt) (match-end elt)))))) (nreverse replacement) "") suffix))) ;; Emacs Lisp has no real mapcar, sigh! (defun empire-mapcar (fun &rest args) "Apply FUNCTION to successive cars of all ARGS. Return the list of results." (let (result) ;; While no list is exhausted, (while (not (memq 'nil args)) ;; apply function to CARs. (setq result (cons (apply fun (mapcar 'car args)) result)) (setq args (mapcar 'cdr args))) (nreverse result))) ;; Alas, nsubstitute is missing, too. (defun empire-nsubstitute (new old list) "Substitute NEW for OLD everywhere in LIST (destructively). Comparison is done with equal." (let ((tail list)) (while tail (if (equal (car tail) old) (setcar tail new)) (setq tail (cdr tail)))) list) ;;; emputil.el ends here empwin.el100444 145 12 3514 5614701335 11505 0ustar armbrustaff;;; empwin.el --- Functions used by GENIE on window systems ;; Copyright (C) 1994 Markus Armbruster ;; Author: Markus Armbruster ;; Version: $Id: empwin.el,v 1.2 1994/07/25 09:16:13 armbru Exp $ ;; Keywords: games ;; This file is part of GENIE, the GNU Emacs's Nifty Interface to Empire ;; GENIE 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. ;; GENIE 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 GENIE; see the file COPYING. If not, write to the Free ;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. ;;; Commentary: ;; For general information on GENIE, see file empire.el. ;; This file contains definitions specific to window systems. ;; See empterm.el for character terminal specific stuff. ;; Entry points: ;; empire-highlight-string ;;; To do ;; Combine highlight faces from user customizable settings ;;; Code: (provide 'empwin) (defvar empire-highlight-faces (vector 'default 'highlight 'italic 'bold-italic) "Array of highlight faces. The array index encodes the combination highlights: bit I on means highlight I is active.") (defun empire-highlight-string (string start end prop-list) "Modify STRING between START and END to highlight it according to PROP-LIST." (let ((index (empire-highlight-index prop-list))) (put-text-property start end 'face (aref empire-highlight-faces index) string) string)) ;;; empwin.el ends here