home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / elisp / modes / multi-forms-mode / utilities / simple-menu.el < prev    next >
Encoding:
Text File  |  1992-06-08  |  27.3 KB  |  703 lines
  1. ;;;; -*- Mode: Emacs-Lisp -*- 
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;;;; 
  4. ;;;; File            : simple-menu.el
  5. ;;;; Author          : Frank Ritter
  6. ;;;; Created On      : Mon Oct 28 12:28:03 1991
  7. ;;;; Last Modified By: Frank Ritter
  8. ;;;; Last Modified On: Mon Jun  8 17:49:10 1992
  9. ;;;; Update Count    : 45
  10. ;;;; 
  11. ;;;; PURPOSE
  12. ;;;; Simple Menu Enhancements for GNU Emacs
  13. ;;;; I've completely rewritten the Chris Ward's menu system to suit my
  14. ;;;; needs.  It is a simple tty based menu system for providing a limited
  15. ;;;; number of choices in an extensible way.  I use it daily (well, not
  16. ;;;; really, I now use the keystroke equivalents it teaches), but the point
  17. ;;;; is that it is robust enough to put out.  I have cut most of Chris's 
  18. ;;;; emacs commands from the menus, the present package is offered more for
  19. ;;;; applications, but I would be happy to paste stuff people send me.  At
  20. ;;;; the bottom of this file I provide a sample set of menus for emacs.
  21. ;;;;     
  22. ;;;; TABLE OF CONTENTS
  23. ;;;;     i.    LCD archive entry
  24. ;;;;    ii.    COPYRIGHT and WARNINGS
  25. ;;;;    iii.    Update information and how to get copies
  26. ;;;;    iv.    OVERVIEW/INTRODUCTION
  27. ;;;;    v.    Requires/provides/compile info
  28. ;;;;
  29. ;;;;     I.    Variables and constants 
  30. ;;;;     II.    Creating functions
  31. ;;;;    III.    Running functions
  32. ;;;;     IV.     Helper functions 
  33. ;;;;     V.    Utilities
  34. ;;;;    VI.    Example menus for emacs
  35. ;;;; 
  36. ;;;; Copyright 1991, Frank Ritter.
  37. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  38. ;;; Status          : Released version 1.2.
  39. ;;; HISTORY
  40. ;;; Version 1.3 (not yet released)
  41. ;;; 18-Mar-92 -FER fixed default usage, added bytecomp information.
  42. ;;; 12-Feb-92 -FER more robust in allowing user to move in pop-up help.
  43. ;;; 11-Feb-92 -FER added optional default to running a menu.
  44. ;;; 13-Jan-92 -FER added sm-clear-menu, and now run-menu returns values
  45. ;;; 19-Nov-91 -FER added variable prompts
  46. ;;;                f/ Christopher fernand@SPUNKY.CS.NYU.EDU
  47. ;;; 28-Oct-91 release 1.2 to elisp archive  -FER
  48. ;;;  3-oct-91 -FER TAB and M- replace "   " and ^[ in full help descriptions.
  49. ;;; 16-Sep-91 -FER better help display
  50. ;;; 6-12-91 - unbelievably better key search in sm-find-binding
  51. ;;; 6-11-91 - even more robust key search in sm-find-binding
  52. ;;; 6-10-91 - more robust key search in sm-find-binding
  53. ;;; Version 1.1
  54. ;;; 6-5-91 - added ability to show esc-x commands in help
  55. ;;; 5-27-91 - added ability to show esc-x commands after command completion
  56. ;;; 2 may 91 added (require 'cl) reported by dfreuden@govt.shearson.com,
  57. ;;;   ne201ph@prism.gatech.edu (Halvorson,Peter J), rayv@revenge.sps.mot.com 
  58. ;;;   (Ray Voith), & Sara.Kalvala@computer-lab.cambridge.ac.uk
  59. ;;; 30 may 91 - posted to gnu.emacs.sources version 1.0
  60. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  61.  
  62.  
  63.  
  64. ;;;
  65. ;;;     i.    LCD archive entry
  66. ;;;
  67.  
  68. ;; LCD Archive Entry:
  69. ;; simple-menu|Frank Ritter|ritter@cs.cmu.edu
  70. ;; |Command-line menus made declaratively (rev of Ward's procedural version)
  71. ;; |91-10-28|1.2|~/interfaces/simple-menu2.el.Z
  72.  
  73.  
  74.  
  75. ;;;
  76. ;;;    ii.     COPYRIGHT and WARNINGS
  77. ;;;
  78. ;;; GNU Emacs is distributed in the hope that it will be useful,
  79. ;;; but WITHOUT ANY WARRANTY.  No author or distributor
  80. ;;; accepts responsibility to anyone for the consequences of using it
  81. ;;; or for whether it serves any particular purpose or works at all,
  82. ;;; unless he says so in writing.  Refer to the GNU Emacs General Public
  83. ;;; License for full details.
  84. ;;;
  85. ;;; Everyone is granted permission to copy, modify and redistribute
  86. ;;; GNU Emacs, but only under the conditions described in the
  87. ;;; GNU Emacs General Public License.   A copy of this license is
  88. ;;; supposed to have been given to you along with GNU Emacs so you
  89. ;;; can know your rights and responsibilities.  It should be in a
  90. ;;; file named COPYING.  Among other things, the copyright notice
  91. ;;; and this notice must be preserved on all copies.
  92.  
  93.  
  94. ;;;
  95. ;;;    iii.    Update information and how to get copies
  96. ;;;
  97. ;;; Updated versions (if any) are available from the author or via ftp:
  98. ;;; from the elisp archive on archive.cis.ohio-state.edu as file
  99. ;;;  pub/gnu/emacs/elisp-archive/interfaces/simple-menu2.el.Z
  100. ;;; Iff you post me mail that you use it, I'll post you updates when they 
  101. ;;; come out.
  102. ;;;
  103. ;;; Initially based on code posted by Chris Ward.
  104. ;;;        Texas Instruments 
  105. ;;;        (cward@houston.sc.ti.com)       (214) 575-3128
  106. ;;;        (X.400: /ADMD=MCI/PRMD=TI/C=US/G=Chris/S=Ward MCI_Mail_ID #4418566)
  107. ;;; and posted comments on Chris's code by Erik Hennum (Erik@informix.com)
  108.  
  109.  
  110. ;;;
  111. ;;;    iv.    OVERVIEW/INTRODUCTION
  112. ;;; 
  113. ;;; Simple-menu is a way to provide simple menus, rather reminiscent of
  114. ;;; the menus provided by the PDP software of McClellend & Rumelhart.  With
  115. ;;; the simple menus defined here for gnu-emacs, an initial menu of
  116. ;;; commands is displayed in the message line by calling run-menu on a
  117. ;;; previously defined menu.  The user types the first letter of an item to 
  118. ;;; select it, and a command gets executed, or a sub-menu is entered.
  119. ;;; Often you will bind the top menu call to a key.
  120. ;;;
  121. ;;; The prompt that is displayed includes a reminder that help is available  
  122. ;;; by typing ``?''.  (Help is also available by typing ^h or SPC.)
  123. ;;; The prompt can be a string (which will get a ":" tacked on to it),
  124. ;;; a list that will get evaled, a variable that will get evaled, or a
  125. ;;; function that will get funcalled.
  126. ;;;
  127. ;;; Simple menus are defined with def-menu.  This takes a menu-name, an
  128. ;;; title, an intro help comment (ie.: "Pick a command"), and a list of
  129. ;;; items to be put on the menu.  Each  menu item is a list with 2 
  130. ;;; components: 1) a display string, and 2) the command corresponding 
  131. ;;; to the string.  The first word is put in the menu, the first letter in
  132. ;;; the string is used as the selector for the item (case insensitive),
  133. ;;; and the whole string is used in the help display.  
  134. ;;; Def-menu and sm-add-to-menu allow you add commands to menus after they have
  135. ;;; been created, and sm-clear-menu lets you start from scratch.
  136. ;;;
  137. ;;; For example, the menu item:
  138. ;;; 
  139. ;;; ("Redraw         Redraw the screen."   recenter)
  140. ;;; 
  141. ;;; would create the item Redraw in the menu, and the letter R would
  142. ;;; select it.  In the help display, the full string would appear, along
  143. ;;; with any keybindings for the command in the local buffer, in this case
  144. ;;; the help line would look like 
  145. ;;; 
  146. ;;; Redraw         Redraw the screen. (C-l)
  147. ;;; 
  148. ;;; The command given as the second argument can be either: 1) a simple
  149. ;;; function name, 2) a list to eval, or 3) a menu name (symbol).  If you
  150. ;;; want two commands there, wrap them in a progn because the internals of
  151. ;;; the program use each list position.  The command should not display 
  152. ;;; a value with message as its result.
  153. ;;;
  154. ;;; If there is only one menu item, it is executed when the menu is run.
  155. ;;; After an item is selected and sucessfully completed, a possible keybinding
  156. ;;; or call via meta-X is displayed if possible.
  157. ;;;
  158. ;;;  Here's an example:
  159. ;;; 
  160. ;;; (def-menu 'simple-menu
  161. ;;;   "Choose a simple command"
  162. ;;;   "Here are some simple commands to choose from"
  163. ;;; '(("Add 2 + 2      Add 2+2 and print it out for me."
  164. ;;;    (progn (message (format "The Answer is %s." (+ 2 2)))
  165. ;;;           (sleep-for 2)))
  166. ;;;   ("Redraw         Redraw the screen." recenter)
  167. ;;;   ("Simple menu    Recurse and run this darn menu again." simple-menu)))
  168. ;;; 
  169. ;;; Run-menu will start up the menu.  ^g will abort the menu.
  170. ;;; e.g.,  (run-menu 'simple-menu)
  171. ;;; Binding this to a key makes the menu more usable.
  172. ;;; Run-menu also takes a default, a string or symbol.  If the user 
  173. ;;; types a CR, the first letter of the string or symbol's name is 
  174. ;;; used to make the choice.
  175. ;;; 
  176. ;;; (add-to-menu 
  177.  
  178. ;;; I will NOT maintain it in the traditional sense (mostly a note to myself to
  179. ;;; get back to the thesis), but I will 1) incorporate changes that are
  180. ;;; useful to me, 2) fix bugs that you notice that would bother my
  181. ;;; application, and 3) incorporate good stuff you post me.
  182. ;;; 
  183. ;;; I am willing to answer questions if things aren't clear on how to get
  184. ;;; started.  
  185. ;;; 
  186. ;;; possible bugs/misfeatures:
  187. ;;; * The command should not display a value with message as its result.
  188.  
  189.  
  190. ;;;
  191. ;;;    v.    Requires/provides/compile info
  192. ;;;
  193.  
  194. (require 'cl)
  195. (provide 'simple-menu)
  196.  
  197. ;; Compiler info for JWZ's byte compiler.
  198. ;; they add about 2k to the .elc file.
  199. (if (fboundp 'proclaim-inline)
  200.   (proclaim-inline
  201.     sm-menu-p
  202.     sm-eval-single-menu
  203.     sm-make-help
  204.     sm-find-binding
  205.     sm-find-esc-binding
  206.     sm-menu-ized-items
  207.     sm-setup-menu-item
  208.     sm-note-function-key
  209.     first-word
  210.     first-letter
  211. ))
  212.  
  213. (defmacro mapc (function alist)
  214.  (` (let ((blist (, alist)))
  215.      (while blist
  216.       (funcall (, function) (car blist))
  217.       (setq blist (cdr blist))    ))))
  218.  
  219.  
  220. ;;; 
  221. ;;;     I.    Variables and constants 
  222. ;;;
  223.  
  224. (defvar sm-default-function 'sm-cant-do-this
  225.   "*Default function to call if a menu items doesn't have a function 
  226. assigned to it.")
  227.  
  228. ;; uses main help buffer, used to be *MENU Help*
  229. (defconst help-buffer "*Help*")
  230.  
  231. (defconst simple-menu-help-string "? ")
  232. (defconst simple-menu-default-string "[%s]:")
  233.  
  234. (defconst sm-default-help-header "Commands in the")
  235. (defconst sm-default-help-for-help 
  236.   "? or ^h or space to display this text at the first prompt.")
  237. (defconst sm-default-help-footer "^G to quit this menu now.
  238.  First letter of the line to choose a command.  
  239.  CR selects the item in [] (if any).")
  240. (defconst CR "
  241. ")
  242.  
  243. ; menus have the following fields:
  244. ;  prompt - the string used as the prompt before the choices
  245. ;  full-prompt - the string put in the message line
  246. ;  items - the list of items
  247. ;  prompt-header  - header (leading string) for the command line
  248. ;  help-header - header for the help buffer
  249.  
  250.  
  251. ;;;
  252. ;;;     II.    Creating functions
  253. ;;;
  254. ;; menus are symbols, 
  255. ;; the raw items are stored under the plist 'items
  256. ;; the list that is displayed is stored in their value, 
  257. ;;    it is made by calling sm-menu-ized-items on the items, 
  258. ;; the prompt-header is under the 'prompt-header property
  259. ;; the help-header   is under the 'help-header prop.
  260.  
  261. (defun sm-menu-p (poss-menu)
  262.  "Return t if item is a simple-menu."
  263.  (and (boundp poss-menu)
  264.       poss-menu
  265.       (get poss-menu 'items)
  266.       (get poss-menu 'prompt-header)
  267.       (get poss-menu 'help-header)
  268.       t))
  269.  
  270. (defun sm-def-menu (name prompt help-header items)
  271.  "Define a menu object"
  272.  ;; check for errors on the way in and massage args
  273.  (if (not (symbolp name)) 
  274.      (error (format "%s, the first arg must be a symbol." name)))
  275.  (cond ( (get name 'items) ;it's been created already
  276.          (sm-add-to-menu name items)
  277.          (put name 'prompt-header prompt)
  278.          (put name 'help-header help-header))
  279.        (t (put name 'items items)               ; doit
  280.           (set name (sm-menu-ized-items items))
  281.           (put name 'prompt-header prompt)
  282.           (put name 'help-header help-header)
  283.           t)) )
  284.  
  285. (fset 'def-menu 'sm-def-menu)
  286.  
  287. ;; Could set here wether items go on front or back.
  288. (defun sm-add-to-menu (menu items)
  289.  "Add to NAME the list of ITEMS."
  290.  (mapc (function
  291.            (lambda (item)
  292.              (let ( (old-items (get menu 'items)) )
  293.                (cond ( (member item old-items) )
  294.                      (t (put menu 'items (append old-items items))
  295.                         (set menu (sm-menu-ized-items (get menu 'items)))
  296.                         (put menu 'full-prompt nil)))  )))
  297.           items))
  298.  
  299. (fset 'add-to-menu 'sm-add-to-menu)
  300.  
  301.  
  302. ;;;
  303. ;;;    III.    Running functions
  304. ;;;
  305. ;;; The cursor-in-echo-area doesn't work on pmaxen with X windows,
  306. ;;; we don't know why.
  307.  
  308. ;; prompt is the initial prompt
  309. ;; full prompt is what is actually shown to the user, includes choices
  310. (defun sm-run-menu (amenu &optional default)
  311.  "Present AMENU.  DEFAULT will be selected on a CR."
  312.  ;; get & present the prompt
  313.  (if (= (length (eval amenu)) 1)
  314.      (sm-eval-single-menu amenu)
  315.  (let ((raw-prompt (get amenu 'prompt-header))
  316.        (full-prompt (get amenu 'full-prompt))
  317.        (old-window (selected-window))
  318.        (items (eval amenu))
  319.        (string-default (cond ((stringp default) default)
  320.                              ((and default (symbolp default))
  321.                               (prin1-to-string default))
  322.                              (t "")))    )
  323.   (if full-prompt
  324.       (message full-prompt string-default)
  325.       (progn
  326.         ;; this makes a full prompt, & saves it for later use
  327.        (setq prompt (cond ((listp raw-prompt)
  328.                            (eval raw-prompt))
  329.                           ((and (symbolp raw-prompt) (fboundp raw-prompt))
  330.                            (funcall raw-prompt))
  331.                           ((and (symbolp raw-prompt) (boundp raw-prompt))
  332.                            (eval raw-prompt))
  333.                           ((stringp raw-prompt)
  334.                            (if (not (string= raw-prompt ""))
  335.                                (concat raw-prompt ": ")
  336.                              raw-prompt))))
  337.         (mapc (function (lambda (x) (setq prompt (concat prompt x " "))))
  338.               (mapcar 'first-word items))
  339.         (setq prompt (concat prompt simple-menu-help-string
  340.                              simple-menu-default-string))
  341.         (if (stringp raw-prompt)
  342.             (put amenu 'full-prompt prompt))
  343.         (message prompt string-default)))
  344.   ;; read it in & process char choice
  345.   (let ( (cursor-in-echo-area t)
  346.          (echo-keystrokes 0) )
  347.   (setq opt (read-char)) )
  348.   (setq opt (downcase opt))
  349.   (cond ((or (= opt ?\C-h) (= opt ??)  (= opt ? ))
  350.          (setq opt (downcase (sm-pop-up-help amenu))))
  351.         ((and (= opt ?\C-m) default)
  352.          (setq opt (downcase (string-to-char string-default)))))
  353.   (sm-eval-menu amenu opt) )))
  354.  
  355. (fset 'run-menu 'sm-run-menu)
  356.  
  357.  
  358. ;;;
  359. ;;;     IV.     Helper function s
  360. ;;; 
  361.  
  362. (defun sm-clear-menu (name)
  363.  "Completely clears out a menu."
  364.  (put name 'items nil)
  365.  (set name nil)
  366.  (put name 'prompt-header nil)
  367.  (put name 'raw-prompt nil)
  368.  (put name 'full-prompt nil)
  369.  (put name 'help-prompt nil))
  370.  
  371. (defun sm-eval-menu (amenu opt)
  372.  "Find in AMENU the command corresponding to OPT."
  373.  (let ( (items (eval amenu)) results
  374.         (current-key-map (current-local-map))
  375.         (command nil) )
  376.   (while items
  377.      (setq item (pop items))
  378.      (cond ( (and (null (third item))
  379.                   (= opt (second item)))
  380.              (setq command t)
  381.              (error "Menu item \"%c\" not implemented yet." opt))
  382.            ( (and (third item) (= opt (third item)))
  383.              (setq items nil)
  384.              (setq command (second item))
  385.              (setq results 
  386.                (cond ;; something to be returned
  387.                      ((or (stringp command) (numberp command))
  388.                       command)
  389.                      ;; its a command
  390.                      ((and (not (listp command)) (fboundp command))
  391.                       (call-interactively command)
  392.                       (sm-note-function-key command current-key-map))
  393.                      ;; it is something to eval
  394.                      ((listp command)
  395.                       (eval command))
  396.                      ((or (not (boundp command)) (not (eval command))
  397.                           (not (listp (eval command))))
  398.                       command)
  399.                      ;; it is another menu, you hope...
  400.                      (t (sm-run-menu command)))))))
  401.   (if (not command) ; no match
  402.       (progn (message (format "%c did not match a menu name" opt))
  403.              (beep)))
  404.   results))
  405.  
  406. (defun sm-eval-single-menu (amenu)
  407.  "Run in AMENU the single only command."
  408.  (let* ( (item (first (eval amenu)))
  409.          (command (second item)) 
  410.          (current-key-map (current-local-map)) )
  411.    (cond ;; its a command
  412.         ((and (not (listp command)) 
  413.               (fboundp command))
  414.          (call-interactively command)
  415.          (sm-note-function-key command current-key-map))
  416.         ;; it is something to eval
  417.         ((listp command)
  418.          (eval command))
  419.         ;; it is another menu, you hope...
  420.         (t (sm-run-menu command)))
  421.    (if (not command) ; no match
  422.        (progn (message (format "%c did not match a menu name" opt))
  423.               (beep)))     ;note we lost
  424. ))
  425.  
  426. (defun sm-make-help (help-header name items)
  427.  "Make a help string for a simple menu."
  428.  ;; this is a bit sloppy about how to make it....
  429.  (let ((header nil) (result ""))
  430.   (setq result
  431.         (concat result
  432.                (cond ((string= "" help-header)
  433.                       (format "%s %s:%s" sm-default-help-header name CR CR))
  434.                      (t (concat help-header ":" CR CR)))))
  435.   (mapc
  436.      (function 
  437.        (lambda (x) 
  438.           (let ((bind-thing (sm-find-binding (car (cdr x))))
  439.                 (help-string (car x)) )
  440.            (setq result (format "%s %s " result help-string))
  441.            (if bind-thing
  442.                (if (> (+ (length bind-thing) (length help-string)) fill-column)
  443.                    (setq result 
  444.                          (format "%s\n\t\t\t (%s)" result bind-thing))
  445.                    (setq result 
  446.                          (format "%s (%s)" result bind-thing))))
  447.            (setq result (concat result CR))           )))
  448.       items)
  449.   (setq result (concat result CR " " sm-default-help-for-help ))
  450.   (setq result (concat result CR " " sm-default-help-footer))
  451.   result))
  452.  
  453. (defun sm-find-binding (function &optional map)
  454.  "Finds a keybinding for function if it can."
  455.  (if (not (symbolp function)) 
  456.       nil
  457.  ;; else
  458.  (if (not map) (setq map (current-local-map)))
  459.  (let ((initial-result
  460.         (cond
  461.          ((car (where-is-internal function map)))
  462.          ;; check escape map too
  463.          ( (sm-find-esc-binding function) )
  464.          ( (fboundp function)
  465.            ;; this assumes that function in interactive
  466.            (format "ESC-X %s" function)))))
  467.    ;; this is an ad hoc way to clean these up....
  468.    (if (not (stringp initial-result))
  469.        nil
  470.      (if (string= "\t" initial-result)
  471.          (setq initial-result "TAB"))
  472.      (if (string= "    " initial-result)
  473.          (setq initial-result "^X^I"))
  474.      (if (string= "\C-[" (substring initial-result 0 1))
  475.          (setq initial-result (format "M-%s" (substring initial-result 1))))
  476.      initial-result))))
  477.  
  478. (defun sm-find-esc-binding (function)
  479.   "Finds a keybinding of FUNCTION just on the local escape map (if any)."
  480.   (let* ( (local-map (current-local-map))
  481.           (esc-map (if local-map
  482.                        (lookup-key (current-local-map) "")))
  483.           (esc-key (if esc-map
  484.                        (where-is-internal function esc-map))) )
  485.   (if esc-key
  486.       (concat "M-" (car esc-key)))))
  487.  
  488. (defun sm-menu-ized-items (items)
  489.  "Strips the first letter off and makes it the third item for ease and speed."
  490.  (mapcar (function (lambda (x)
  491.             (append (sm-setup-menu-item x)
  492.                     (list (string-to-char (first-letter x))))))
  493.          items))
  494.  
  495. (defun sm-setup-menu-item (x)
  496.  "Setup the menu item X, which should have a string and symbol or listp.
  497. If it doesn't, add a dummy function call."
  498.  (let ((value (car (cdr x))))
  499.  (cond ( (and (listp x)
  500.               (stringp (car x))
  501.               (or (symbolp value)
  502.                   (stringp value)
  503.                   (listp value)))
  504.           x)
  505.        ( (and (listp x)         ;given a null function
  506.               (stringp (car x))
  507.               (null (car (cdr x))))
  508.          (append x (list sm-default-function)))
  509.        (t (error "Bad menu item: %s" x)))
  510. ))
  511.  
  512. ;; this is smart enough to let user scroll, but continues on and calls
  513. ;; menu.
  514. (defun sm-pop-up-help (menu)
  515.   "Display the full documentation of MENU."
  516.   (let ((opt "") (opt-key 'beep)
  517.         (full-prompt (get menu 'full-prompt))
  518.         (help-info (cond ((get menu 'help))
  519.                          ((put menu 'help (sm-make-help (get menu 'help-header)
  520.                                                         menu
  521.                                                         (get menu 'items))))
  522.                          (t "not documented")))  )
  523.     (save-window-excursion
  524.       (switch-to-buffer help-buffer)
  525.       (erase-buffer)
  526.       (insert help-info)
  527.       (goto-char (point-min))
  528.       (while (not (string-match "[a-zA-Z0-9]" opt))
  529.         (message full-prompt)
  530.         (setq opt (read-key-sequence nil))
  531.         (setq opt-key (lookup-key (current-global-map) opt))
  532.         (if (memq opt-key 
  533.                   (append 
  534.                      (if (not (pos-visible-in-window-p (point-min)))
  535.                          '(scroll-up))
  536.                      (if (not (pos-visible-in-window-p (point-max)))
  537.                          '(scroll-down))
  538.                      '(next-line previous-line forward-line forward-char 
  539.                        backward-char keyboard-quit scroll-right scroll-left)))
  540.             (call-interactively opt-key)
  541.           (bury-buffer help-buffer))))
  542.     (string-to-char opt)))
  543.  
  544. (defun sm-note-function-key (command keymap)
  545.  "Note to the user any keybindings for Command"
  546.  (let ( (key-binding (sm-find-binding command keymap)) )
  547.   (if key-binding
  548.       (message (format "%s is also bound to \"%s\"."
  549.                     command key-binding))) ))
  550.  
  551.  
  552. ;;;
  553. ;;;     V.    Utilities
  554. ;;; 
  555.  
  556. ;; (first-word '("asdf" fun1))
  557. ;; (first-letter '("Asdf" fun1))
  558.  
  559. (defun sm-cant-do-this ()
  560.   (message "No function to do this menu item yet."))
  561.  
  562. (defun first-word (menu-item)
  563.  "Return the first word of the first part (a string) of MENU-ITEM."
  564.  (let ((string  (car menu-item)))
  565.   (substring string 0 (string-match " " string))))
  566.  
  567. (defun first-letter (menu-item)
  568.  "Return the first letter of the first part (a string) of MENU-ITEM."
  569.  (let ((string  (first-word menu-item)))
  570.     (downcase (substring string 0 1))))
  571.  
  572.  
  573. ;;;
  574. ;;;    VI.    Example menus for emacs
  575. ;;;
  576. (get 'emacs-menu 'prompt-header)
  577.  
  578. (concat "prompt" simple-menu-help-string
  579.                              simple-menu-default-string)
  580.  
  581. (def-menu 'emacs-menu
  582.   "Emacs commands"
  583.   "Menu of plain Emacs commands"
  584.  '(("Windows      Manipulate multiple window settings."   emacs-windows-menu)
  585.    ("Modify       Change your editing environment."       emacs-modify-menu)
  586.    ("Block menu   Perform operations on blocks (regions) of text." emacs-block-menu)
  587. ))
  588.  
  589. (def-menu  'emacs-block-menu
  590.   "Block Option"
  591.   "Displays menu of block commands to chose from"
  592.  '(("Align    Adjust all lines in region Left, Right, or Centered." 
  593.         emacs-align-menu)
  594.   ("Eval     Evaluate region as a Lisp expression."           eval-region)
  595.   ("Fill     Fill each paragraph in the region."              fill-region)
  596.   ("Indent   Indent region according to major mode."          indent-region)
  597.   ("Lower    Convert all characters in region to lowercase."  downcase-region)
  598.   ("Narrow   Narrow scope of edit to region."                 narrow-to-region)
  599.   ("Spell    Check spelling of all words in region."          spell-region)
  600.   ("Upcase   Convert all characters in region to uppercase."  upcase-region)
  601.   ))
  602.  
  603. (def-menu 'emacs-modify-menu
  604.   "Modify Option"
  605.   "Modify editing environment options are"
  606.  '(("Keys     Locally rebind a key to a function."      local-set-key)
  607.    ("Mode     Change current major/minor mode."         emacs-mode-menu)
  608.    ("Options  Change environmental variable values."    (edit-options))
  609.    ("Save     Save current options settings to a file."
  610.              (message "Modify Save not implemented yet."))
  611.    ("Tabs     Modify tab stop locations."               edit-tab-stops))  )
  612.  
  613. (def-menu 'emacs-windows-menu
  614.   ""
  615.   "Displays menu of window commands to chose from"
  616.  '(("Buffers  Change to buffers menu."                       emacs-buffer-menu) 
  617.   ("Compare  Compare text in current window with text in next window."
  618.     compare-windows)  
  619.   ("Delete   Remove current window from the display."               delete-window)
  620.   ("Find     Find another buffer and change current window to it."  select-window)
  621.   ("Split    Divide current window Vertically or Horizontally."
  622.    (progn
  623.     (while (not (or (= opt ?h) (= opt ?v)))
  624.       (message "Split window: Horizontally Vertically ")
  625.       (setq opt (downcase (read-char))))
  626.     (if (= opt ?h) 
  627.         (call-interactively 'split-window-horizontally)
  628.         (call-interactively 'split-window-vertically))   ))
  629.   ("Other    Change to next window."                      other-window)
  630.   ("1        Make current window the only one visible."   (delete-other-windows))
  631.   ("+        Increase lines in current window."       (do-window-sizing ?+))
  632.   ("-        Decrease lines in current window."       (do-window-sizing ?-))
  633.   ("<        Increase columns in current window."     (do-window-sizing ?<))
  634.   (">        Decrease columns in current window."     (do-window-sizing ?>))))
  635.  
  636. (defun do-window-sizing (opt)
  637.  (while (or (= opt ?+) (= opt ?-) (= opt ?>) (= opt ?<))
  638.    (message "Change window size press '+', '-', '<', '>', or space to quit.")
  639.    (if (= opt ?+) (enlarge-window 1))
  640.    (if (= opt ?-) (shrink-window 1))
  641.    (if (= opt ?>) (enlarge-window-horizontally 1))
  642.    (if (= opt ?<) (shrink-window-horizontally 1))
  643.    (setq opt (read-char))))
  644.  
  645. (def-menu 'emacs-buffer-menu
  646.   ""
  647.   "Displays menu of buffer commands to chose from"
  648.  '(("Delete   Kill current buffer."               kill-buffer)
  649.   ("Edit     Edit another buffer."               switch-to-buffer)
  650.   ("File     Change to use File menu."           files-menu)
  651.   ("List     List current buffers and status."   list-buffers)
  652.   ("Other    Switch to buffer in other window."  switch-to-buffer-other-window)
  653.   ("Spell    Check spelling for current buffer." ispell-buffer)
  654.   ("Toggle   Toggle current buffer read-only status." toggle-read-only)
  655.   ("Window   Change to Windows menu."                 windows-menu)))
  656.  
  657. (def-menu 'emacs-mode-menu
  658.   "Mode"
  659.   "Displays menu of known major and minor modes to chose from"
  660.  '(("1  [pfe-mode] Use PFE emulation and keyboard layout."   (pfe-mode))
  661.   ("A  [edit-abbrevs-mode] Major mode for editing list of abbrev definitions."
  662.      (edit-abbrevs-mode))
  663.   ("C  [c-mode] Major mode for editing C language source files."   (c-mode))
  664.   ("D  [normal-mode] Default to normal mode for current file."  (normal-mode))
  665.   ("F  [fortran-mode] Major mode for editing FORTRAN source files."  
  666.     (fortran-mode))
  667.   ("G  [emacs-lisp-mode] Major mode for editing GNU Emacs lisp source files."
  668.      (emacs-lisp-mode))
  669.   ("I  [lisp-interaction-mode] Major mode for typing/evaluating Lisp forms."
  670.      (lisp-interaction-mode))
  671.   ("L  [lisp-mode] Major mode for editing LISP code other than Emacs Lisp."
  672.     (lisp-mode))
  673.   ("O  [outline-mode] Major mode for editing outlines with selective display."
  674.      (outline-mode))
  675.   ("P  [picture-mode] Use quarter-plane screen model to edit."  (picture-mode))
  676.   ("T  [text-mode] Major mode for editing regular text files." (text-mode))
  677.   ("X  [tex-mode] Major mode for editing files of input for TeX or LaTeX."
  678.      (tex-mode))
  679.   ("Z  [fundamental-mode] Major mode not specialized for anything."
  680.     (fundamental-mode))))
  681.  
  682. (def-menu 'emacs-align-menu
  683.   "Align Option"
  684.   "Displays menu of region alignment commands to chose from:"
  685.  '(("Center   Center all lines in region between left margin and fill column."
  686.      center-region)
  687.   ("Justify  Fill each paragraph between left margin and fill column."
  688.      (fill-region (point) (mark) t))
  689.   ("Left     Adjust lines to start in a specific column."
  690.     (progn (setq opt 
  691.                  (read-input "Align left at column: " (int-to-string left-margin)))
  692.            (setq opt (string-to-int opt))
  693.            (message (format "Align left at column %d." opt))
  694.            (indent-rigidly (point) (mark) opt)))
  695.   ("Right    Ajdust lines to end in a specific column if possible."
  696.      (progn (setq opt (read-input "Align right at column: " 
  697.                                   (int-to-string left-margin)))
  698.             (setq opt (string-to-int opt))
  699.             (message (format "Align right at column %d." opt))
  700.             (right-flush-region (point) (mark) opt)))
  701.   ("Tab      Indent each line in region relative to line above it." indent-region)
  702.   ))
  703.