home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 January / usenetsourcesnewsgroupsinfomagicjanuary1994.iso / sources / games / volume14 / dunnet / part02 / dun-util.el < prev    next >
Lisp/Scheme  |  1992-08-31  |  8KB  |  259 lines
  1. (require 'cl)
  2.  
  3. ;;;;;;;;;;;;;;;;;;;;; Utility functions
  4.  
  5. ;;; Function which takes a verb and a list of other words.  Calls proper
  6. ;;; function associated with the verb, and passes along the other words.
  7.  
  8. (defun doverb (ignore verblist verb rest)
  9.   (if (not verb)
  10.       nil
  11.     (if (member (intern verb) ignore)
  12.     (if (not (car rest)) -1
  13.       (doverb ignore verblist (car rest) (cdr rest)))
  14.       (if (not (cdr (assq (intern verb) verblist))) -1
  15.     (setq numcmds (1+ numcmds))
  16.     (eval (list (cdr (assq (intern verb) verblist)) (quote rest)))))))
  17.  
  18.  
  19. ;;; Function to take a string and change it into a list of lowercase words.
  20.  
  21. (defun listify-string (strin)
  22.   (let (pos ret-list end-pos)
  23.     (setq pos 0)
  24.     (setq ret-list nil)
  25.     (while (setq end-pos (string-match "[ ,:;]" (substring strin pos)))
  26.       (setq end-pos (+ end-pos pos))
  27.       (if (not (= end-pos pos))
  28.       (setq ret-list (append ret-list (list 
  29.                        (downcase
  30.                         (substring strin pos end-pos))))))
  31.       (setq pos (+ end-pos 1))) ret-list))
  32.  
  33. (defun listify-string2 (strin)
  34.   (let (pos ret-list end-pos)
  35.     (setq pos 0)
  36.     (setq ret-list nil)
  37.     (while (setq end-pos (string-match " " (substring strin pos)))
  38.       (setq end-pos (+ end-pos pos))
  39.       (if (not (= end-pos pos))
  40.       (setq ret-list (append ret-list (list 
  41.                        (downcase
  42.                         (substring strin pos end-pos))))))
  43.       (setq pos (+ end-pos 1))) ret-list))
  44.  
  45. (defun replace (list n number)
  46.   (rplaca (nthcdr n list) number))
  47.  
  48.  
  49. ;;; Get the first non-ignored word from a list.
  50.  
  51. (defun firstword (list)
  52.   (if (not (car list))
  53.       nil
  54.     (while (and list (member (intern (car list)) ignore))
  55.       (setq list (cdr list)))
  56.     (car list)))
  57.  
  58. (defun firstwordl (list)
  59.   (if (not (car list))
  60.       nil
  61.     (while (and list (member (intern (car list)) ignore))
  62.       (setq list (cdr list)))
  63.     list))
  64.  
  65. ;; parse a line passed in as a string  Call the proper verb with the
  66. ;; rest of the line passed in as a list.
  67.  
  68. (defun parse (ignore verblist line)
  69.   (mprinc "\n")
  70.   (setq line-list (listify-string (concat line " ")))
  71.   (doverb ignore verblist (car line-list) (cdr line-list)))
  72.  
  73. (defun parse2 (ignore verblist line)
  74.   (mprinc "\n")
  75.   (setq line-list (listify-string2 (concat line " ")))
  76.   (doverb ignore verblist (car line-list) (cdr line-list)))
  77.  
  78. (defun read-line ()
  79.   (let (line)
  80.     (setq line (read-string ""))
  81.     (mprinc line) line))
  82.  
  83. (defun minsert (string)
  84.   (if (stringp string)
  85.       (insert string)
  86.     (insert (prin1-to-string string))))
  87.  
  88. (defun mprinc (string)
  89.   (if (stringp string)
  90.       (insert string)
  91.     (insert (prin1-to-string string))))
  92.  
  93. (defun minsertl (string)
  94.   (minsert string)
  95.   (minsert "\n"))
  96.  
  97. (defun mprincl (string)
  98.   (mprinc string)
  99.   (mprinc "\n"))
  100.  
  101. ;;;; Function which will get an object number given the list of
  102. ;;;; words in the command, except for the verb.
  103.  
  104. (defun objnum-from-args (obj)
  105.   (let (objnum)
  106.     (setq obj (firstword obj))
  107.     (if (not obj)
  108.     255
  109.       (setq objnum (cdr (assq (intern obj) objnames))))))
  110.  
  111. (defun objnum-from-args-std (obj)
  112.   (let (result)
  113.   (if (eq (setq result (objnum-from-args obj)) 255)
  114.       (mprincl "You must supply an object."))
  115.   (if (eq result nil)
  116.       (mprincl "I don't know what that is."))
  117.   (if (eq result 255)
  118.       nil
  119.     result)))
  120.  
  121. ;; Take a short room description, and change spaces and slashes to dashes.
  122.  
  123. (defun space-to-hyphen (string)
  124.   (let (space)
  125.     (if (setq space (string-match "[ /]" string))
  126.     (progn
  127.       (setq string (concat (substring string 0 space) "-"
  128.                    (substring string (1+ space))))
  129.       (space-to-hyphen string))
  130.       string)))
  131.  
  132. ;; Given a unix style pathname, build a list of path components (recursive)
  133.  
  134. (defun get-path (dirstring startlist)
  135.   (let (slash pos)
  136.     (if (= (length dirstring) 0)
  137.     startlist
  138.       (if (string= (substring dirstring 0 1) "/")
  139.       (get-path (substring dirstring 1) (append startlist (list "/")))
  140.     (if (not (setq slash (string-match "/" dirstring)))
  141.         (append startlist (list dirstring))
  142.       (get-path (substring dirstring (1+ slash))
  143.             (append startlist
  144.                 (list (substring dirstring 0 slash)))))))))
  145.  
  146.  
  147. (defun members (string string-list)
  148.   (let (found)
  149.     (setq found nil)
  150.     (dolist (x string-list)
  151.       (if (string= x string)
  152.       (setq found t))) found))
  153.  
  154. (defun put-objs-in-treas (objlist)
  155.   (let (oscore newscore)
  156.     (setq oscore (reg-score))
  157.     (replace room-objects 0 (append (nth 0 room-objects) objlist))
  158.     (setq newscore (reg-score))
  159.     (if (not (= oscore newscore))
  160.     (score nil))))
  161.  
  162. (defun load-d (filename)
  163.   (let (old-buffer key result)
  164.     (setq result t)
  165.     (setq old-buffer (current-buffer))
  166.     (switch-to-buffer (get-buffer-create "*loadc*"))
  167.     (erase-buffer)
  168.     (condition-case nil
  169.     (insert-file-contents filename)
  170.       (error (setq result nil)))
  171.     (unless (not result)
  172.         (setq key (buffer-substring (point-min) (+ (point-min) 2)))
  173.         (delete-char 2 t)
  174.         (condition-case nil
  175.         (crypt-buffer key)
  176.           (error (yank)))
  177.         (eval-current-buffer)
  178.         (kill-buffer (current-buffer))
  179.         (switch-to-buffer old-buffer))
  180.     result))
  181.  
  182. (defun compile-globals ()
  183.   (switch-to-buffer (get-buffer-create "*compd*"))
  184.   (erase-buffer)
  185.   (insert-file-contents "dun-globals.el")
  186.   (setq key (concat (prin1-to-string (% (abs (random)) 9))
  187.             (prin1-to-string (% (abs (random)) 9))))
  188.   (crypt-buffer key)
  189.   (goto-char (point-min))
  190.   (insert key)
  191.   (write-region 1 (point-max) "dun-globals.dat")
  192.   (kill-buffer (current-buffer)))
  193.  
  194. ;; Functions to remove an object either from a room, or from inventory.
  195.  
  196. (defun remove-obj-from-room (room objnum)
  197.   (let (newroom)
  198.     (setq newroom nil)
  199.     (dolist (x (nth room room-objects))
  200.       (if (not (= x objnum))
  201.       (setq newroom (append newroom (list x)))))
  202.     (rplaca (nthcdr room room-objects) newroom)))
  203.  
  204. (defun remove-obj-from-inven (objnum)
  205.   (let (new-inven)
  206.     (setq new-inven nil)
  207.     (dolist (x inventory)
  208.       (if (not (= x objnum))
  209.       (setq new-inven (append new-inven (list x)))))
  210.     (setq inventory new-inven)))
  211.  
  212. (defun get-glob-dat ()
  213.   (let (result)
  214.     (setq result nil)
  215.     (dolist (x load-path)
  216.         (if (file-exists-p (concat x "/dun-globals.dat"))
  217.         (setq result (concat x "/dun-globals.dat"))))
  218.     result))
  219.  
  220. ;;;
  221. ;;; This is a small part copied from crypt.el by kyle@cs.odu.edu, with
  222. ;;; a small change.
  223.  
  224.  
  225. ;;; Compaction, compression and encryption for GNU Emacs
  226. ;;; Copyright (C) 1988, 1989, 1990 Kyle E. Jones
  227. ;;;
  228. ;;; This program is free software; you can redistribute it and/or modify
  229. ;;; it under the terms of the GNU General Public License as published by
  230. ;;; the Free Software Foundation; either version 1, or (at your option)
  231. ;;; any later version.
  232. ;;;
  233. ;;; This program is distributed in the hope that it will be useful,
  234. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  235. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  236. ;;; GNU General Public License for more details.
  237. ;;;
  238. ;;; A copy of the GNU General Public License can be obtained from this
  239. ;;; program's author (send electronic mail to kyle@cs.odu.edu) or from
  240. ;;; the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA
  241. ;;; 02139, USA.
  242. ;;;
  243. ;;; Send bug reports to kyle@cs.odu.edu.
  244.  
  245. ;;; Changes for dungeon - 
  246. ;;; ronnie@eddie.mit.edu - changed shell to use /bin/sh explicitly.
  247. ;;;                        Otherwise user's 'rc' file might produce
  248. ;;;                        output that gets stuffed into buffer.
  249.  
  250. (defun crypt-region (start end key)
  251.    (let ((opoint-max (point-max)))
  252.      (call-process-region start end "/bin/sh" t t nil "-c"
  253.               (concat "crypt \"" key "\""))
  254.      (if (not (= opoint-max (point-max)))
  255.      (error "crypt command failed!"))))
  256.  
  257. (defun crypt-buffer (key &optional buffer)
  258.   (crypt-region (point-min) (point-max) key))
  259.