home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / elisp / packages / MouseAndMenuEmacs / x-plus.el < prev    next >
Encoding:
Text File  |  1990-05-31  |  4.4 KB  |  114 lines
  1. ;;;; X windows fripperies. Essentially just to shock the neighbours.
  2. ;;;; Russell Ritchie, Scottish HCI Centre, <russell@uk.ac.strath.hci>.
  3. ;;;; Wed Apr 19 16:30:42 1989
  4.  
  5. (require 'gensym)
  6. (provide 'x-plus)
  7.  
  8. (defvar nil-synonym (gensym)
  9.   "Synonym for nil when it is desired that this value be explicitly selected.")
  10.  
  11. (defun x-mouse-query (arg question answers &optional must-select)
  12.   "At window position ARG, ask QUESTION. Return selected item from ANSWERS.
  13. ARG is a list (x-pos y-pos).
  14. QUESTION is a string.
  15. ANSWERS is a list of strings or symbols or lists. If strings or
  16. symbols the selected string or symbol is displayed and returned when
  17. selected. If lists the car (which must be a string) is displayed and
  18. the cdr returned when it is selected.
  19.  
  20. If optional third arg MUST-SELECT is non-nil one of ANSWERS
  21. must be selected; querying will continue until a selection is made.
  22. N.b. X responds to both mouse-up and mouse-down events equally: it's not
  23. beeping twice, you've just had 2 opportunities to select the right thing.
  24. See also x-mouse-select-item."
  25.   (let* ((menu-items
  26.       (if (consp (car answers))
  27.           (if must-select
  28.           ;; The user may desire some options to return nil, as in the
  29.           ;; yes-or-no-p example below. Cater for this with a synonym.
  30.           (mapcar (function (lambda (x)
  31.                       (if (null (cdr x))
  32.                       (cons (car x) nil-synonym)
  33.                     x)))
  34.               answers)
  35.         answers)
  36.         (mapcar (function (lambda (x) (cons (format "%s" x) x)))
  37.             answers)))
  38.      (query-menu (list "Query Menu" (cons question menu-items)))
  39.      (selection (x-popup-menu arg query-menu)))
  40.     (if must-select
  41.     (if (null selection)
  42.         (let* ((all-rev (reverse (mapcar 'car menu-items)))
  43.            (but-last (cdr all-rev))
  44.            (last (car all-rev))
  45.            (all-but-last (reverse but-last))
  46.            (mesg (format
  47.               "You must select one of: %s or %s."
  48.               (mapconcat 'identity all-but-last ", ") last)))
  49.           (while (null selection)
  50.         (message mesg)
  51.         (ding)
  52.         (setq selection (x-popup-menu arg query-menu)))
  53.           (if (eq selection nil-synonym)
  54.           nil
  55.         selection))
  56.       (if (eq selection nil-synonym)
  57.           nil
  58.         selection))
  59.       selection)))
  60.  
  61. (defun x-mouse-yes-or-no-p (question &optional arg)
  62.   "Ask a yes or no question. Force user to explicitly select yes or no.
  63. Optional 2nd arg POS is a list (x y) of x and y coordinates for the query menu
  64. the default location is the current value x-mouse-pos."
  65.   (x-mouse-query (or arg x-mouse-pos) question '(("yes" . t) ("no")) t))
  66.  
  67. (defun x-mouse-y-or-n-p (question &optional pos)
  68.   "Ask user a yes or no question. No selection is a synonym for no.
  69. Optional 2nd arg POS is a list (x y) of x and y coordinates for the query menu
  70. the default location is the current value x-mouse-pos."
  71.  (x-mouse-query (or pos x-mouse-pos) question '(("yes". t) ("no"))))
  72.  
  73. (defun x-mouse-completing-select (prompt table predicate
  74.                   &optional require-match initial-input pos)
  75.   "Offer a list of possibilities for selection using the mouse under X.
  76. Args are PROMPT, TABLE, PREDICATE.
  77. Optional args are REQUIRE-MATCH, INITIAL-INPUT and POS.
  78. PROMPT is a string to prompt with; normally it ends in a colon and a space.
  79. TABLE is an alist whose elements' cars are strings, or an obarray (see
  80. try-completion).
  81. PREDICATE limits completion to a subset of TABLE; see try-completion.
  82. If REQUIRE-MATCH is non-nil, the user is not allowed to exit unless
  83. a selection from TABLE is made.
  84. If INITIAL-INPUT is non-nil, make this the default selection (the one
  85. the mouse pointer is warped to).
  86. If POS is non-nil, it is a list of (x-pos y-pos) for position on screen.
  87. Don't try to use this as a replacement for completing-read: it's too slow and 
  88. your screen is probably not big enough to list all possibilities; think about
  89. C-h f."
  90.   (let (possibilities)
  91.     (message "Making completion list...")
  92.     (if (or (vectorp table) (arrayp table))
  93.     ;; What is the canonical test for obarray-ness?
  94.     (mapatoms 
  95.      (function 
  96.       (lambda (x)
  97.         (if (funcall predicate x)
  98.         (setq possibilities (append possibilities (list x))))))
  99.           table)
  100.       (if (consp table)
  101.       (mapcar
  102.        (function
  103.         (lambda (x)
  104.           (if (funcall predicate x)
  105.           (setq possibilities (append possibilities (list x))))))
  106.           table)))
  107.     (message "Making completion list...done")
  108.     (let ((selections
  109.        (if initial-input
  110.            (cons initial-input (delq initial-input possibilities))
  111.          possibilities)))
  112.       (x-mouse-query (or pos x-mouse-pos) prompt selections require-match))))
  113.  
  114.