home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / elisp / packages / MouseAndMenuEmacs / sun-plus.el < prev    next >
Encoding:
Text File  |  1990-05-31  |  7.0 KB  |  174 lines
  1. ;;; Additional Sun mouse & menu functionality.
  2. ;;; Augments that provided by the distribution 'sun-fns.el.'
  3.  
  4. (require 'sun-fns)
  5. (require 'sun-menus)
  6. (require 'gensym)
  7. (provide 'sun-plus)
  8.  
  9. (defun sun-mouse-select-item (window x y header items)
  10.   "Pop up a Menu at in window WINDOW at X, Y with HEADER and ITEMS.
  11. If HEADER is nil Menu should have no namestripe.
  12. Return member of ITEMS that is selected or nil."
  13.   (let ((menu-sym (gensym))
  14.     (make-menus-silently t))
  15.     (eval (append (if header
  16.               (list 'defHCImenu menu-sym (list header))
  17.             (list 'defHCImenu menu-sym))
  18.           (mapcar (function (lambda (x)
  19.                        (list (format "%s" x) 'identity x)))
  20.               items)))
  21.     (put menu-sym 'internal t)
  22.     (prog1 
  23.     (sun-menu-other-menu-display menu-sym window x y)
  24.       (setplist menu-sym nil)
  25.       (makunbound menu-sym))))
  26.  
  27. (defun sun-mouse-select-emacs-buffer (window x y &optional buffers header)
  28.   "Pop up a menu at in WINDOW at X,Y of BUFFERS (defaults to (buffer-list)).
  29. If optional 5th arg HEADER is non-nil use that instead of 
  30. \"Select a buffer\" as the namestripe of the menu to be popped up.
  31. Return selected buffer or nil."
  32.   (let ((buf-list (or buffers (buffer-list)))
  33.      buf-a-list)
  34.     (while buf-list
  35.       (let ((elt (car buf-list)))
  36.     (if (not (string-match "^ " (buffer-name elt)))
  37.         (setq buf-a-list     
  38.           (cons (cons (format "%14s   %s"
  39.                       (buffer-name elt)
  40.                       (or (buffer-file-name elt) ""))
  41.                   elt)
  42.             buf-a-list))))
  43.       (setq buf-list (cdr buf-list)))
  44.     (setq buffers (reverse buf-a-list))
  45.     (cdr (assoc
  46.       (sun-mouse-select-item
  47.        window x y (or header "Select a buffer") (mapcar 'car buffers))
  48.       buffers))))
  49.  
  50. (defun sun-mouse-switch-to-buffer (window x y)
  51.   "Switch to a buffer selected via a menu."
  52.   (eval-in-window
  53.     window
  54.     (switch-to-buffer 
  55.      (or (sun-mouse-select-emacs-buffer window x y nil "Switch to buffer: ")
  56.      (current-buffer)))))
  57.  
  58. (defun sun-mouse-switch-to-buffer-other-window (window x y)
  59.   "Switch to a buffer selected via a menu."
  60.   (eval-in-window
  61.     window
  62.     (switch-to-buffer-other-window 
  63.      (or (sun-mouse-select-emacs-buffer
  64.       window x y nil "Switch to buffer in other window: ")
  65.      (current-buffer)))))
  66.  
  67. (global-set-mouse '(shift right modeline) 'sun-mouse-switch-to-buffer-other-window)
  68. (global-set-mouse '(meta shift right modeline) 'sun-mouse-switch-to-buffer)
  69.  
  70. (defvar nil-synonym (gensym)
  71.   "Synonym for nil when it is desired that this value be explicitly selected.")
  72.  
  73. (defun sun-mouse-query (window x y question answers &optional must-select)
  74.   "In WINDOW at position X Y, ask QUESTION. Return selected item from ANSWERS.
  75. ARG is a list (x-pos y-pos).
  76. QUESTION is a string.
  77. ANSWERS is a list of strings or symbols or lists. If strings or
  78. symbols, the selected string or symbol is displayed and returned when
  79. selected. If lists, the car (which must be a string) is displayed and
  80. the cdr returned when it is selected.
  81.  
  82. If optional third arg MUST-SELECT is non-nil one of ANSWERS
  83. must be selected; querying will continue until a selection is made.
  84. See also sun-mouse-select-item."
  85.   (let* ((make-menus-silently t)
  86.      (query-menu (gensym))
  87.      (menu-items
  88.       (if (consp (car answers))
  89.           (if must-select
  90.           ;; The user may desire some options to return nil, as in the
  91.           ;; yes-or-no-p example below. Cater for this with a synonym.
  92.           (mapcar (function (lambda (x)
  93.                       (if (null (cdr x))
  94.                       (list (car x) 'identity 'nil-synonym)
  95.                     (list (car x) 'quote (cdr x)))))
  96.               answers)
  97.         (mapcar (function (lambda (x) (list (car x) 'quote (cdr x))))
  98.             answers))
  99.         (mapcar (function (lambda (x) (list (format "%s" x) 'quote x)))
  100.             answers))))
  101.     (eval (append (cons 'defHCImenu (list query-menu (list question))) menu-items))
  102.     (put query-menu 'internal t)    ; Make it invisible.
  103.     (let ((selection (sun-menu-other-menu-display query-menu window x y)))
  104.       (if must-select
  105.       (if (null selection)
  106.           (let* ((all-rev (reverse (mapcar 'car menu-items)))
  107.              (but-last (cdr all-rev))
  108.              (last (car all-rev))
  109.              (all-but-last (nreverse but-last))
  110.              (mesg (format "You must select one of: %s or %s."
  111.                    (mapconcat 'identity all-but-last ", ") last)))
  112.         (while (null selection)
  113.           (message mesg)
  114.           (ding)
  115.           (setq selection (sun-menu-other-menu-display query-menu window x y)))
  116.         (if (eq selection nil-synonym)
  117.             nil
  118.           selection))
  119.         (setplist query-menu nil)    ; Throw away it's internals.
  120.         (makunbound query-menu)    ; Throw it away in a vain attempt not to waste memory.
  121.         (if (eq selection nil-synonym)
  122.         nil
  123.           selection))
  124.     selection))))
  125.  
  126. (defun sun-mouse-yes-or-no-p (question &optional window x y)
  127.   "Ask a yes or no QUESTION in WINDOW at X, Y. Force user to explicitly select yes or no.
  128. Position args WINDOW, X and Y are optional, 
  129. defaulting to *mouse-window*, *mouse-x* and *mouse-y*."
  130.   (sun-mouse-query
  131.    (or window *mouse-window*) (or x *mouse-x*) (or y *mouse-y*)
  132.    question '(("yes" . t) ("no")) t))
  133.  
  134. (defun sun-mouse-y-or-n-p (question &optional window x y)
  135.   "Ask user a yes or no QUESTION in WINDOW at X, Y. No selection is a synonym for no.
  136. Position args WINDOW, X and Y are optional, 
  137. defaulting to *mouse-window*, *mouse-x* and *mouse-y*."
  138.  (sun-mouse-query
  139.   (or window *mouse-window*) (or x *mouse-x*) (or y *mouse-y*)
  140.   question '(("yes". t) ("no"))))
  141.  
  142. (defun sun-mouse-completing-select (prompt table predicate &optional require-match initial-input pos)
  143.   "Offer a list of possibilities for selection using the mouse under SunView.
  144. Args are PROMPT, TABLE, PREDICATE and optional args REQUIRE-MATCH, INITIAL-INPUT, WIN, X, Y.
  145. PROMPT is a string to prompt with; normally it ends in a colon and a space.
  146. TABLE is an alist whose elements' cars are strings, or an obarray (see try-completion).
  147. PREDICATE limits completion to a subset of TABLE; see try-completion for details.
  148. If REQUIRE-MATCH is non-nil, the user is not allowed to exit unless
  149. a selection from TABLE is made.
  150. If INITIAL-INPUT is non-nil, make this the default selection (the one
  151. the mouse pointer is warped to).
  152. If WIN, X and Y are non-nil, they are the WINDOW and X,Y coordinates for menu on screen.
  153. The default is *mouse-window* at *mouse-x*, *mouse-y*.
  154. Don't try to use this as a replacement for completing-read: it's too slow and 
  155. your screen is probably not big enough to list all possibilities. Think about C-h f."
  156.   (let (possibilities)
  157.     (message "Making completion list...")
  158.     (if (or (vectorp table) (arrayp table))
  159.     ;; What is the canonical test for obarray-ness?
  160.     (mapatoms (function (lambda (x)
  161.                   (if (funcall predicate x)
  162.                   (setq possibilities (append possibilities (list x))))))
  163.           table)
  164.       (if (consp table)
  165.       (mapcar (function (lambda (x)
  166.                   (if (funcall predicate x)
  167.                   (setq possibilities (append possibilities (list x))))))
  168.           table)))
  169.     (message "Making completion list...done")
  170.     (let ((selections (if initial-input
  171.               (cons initial-input (delq initial-input possibilities))
  172.             possibilities)))
  173.       (sun-mouse-query (or win *mouse-window*) (or x *mouse-x*) (or y *mouse-y*)
  174.                prompt selections require-match))))