5 Pop-Up Menus

5.3 Pop-up menu code

The following code is used internally by the Window Tool Kit to implement pop-up menus. The code can be modified by experienced programmers.

(in-package 'windows)
;;; Define the inner and outer border width for menu windows.
(defparameter *menu-black-border-width* 1)
(defparameter *menu-top-white-space* .1)
(defparameter *menu-bottom-white-space* .2)
(defparameter *menu-side-white-space* .1)
(defparameter *menu-between-white-space* .1)

;;; Define the POP-UP-MENU structure. (defstruct (pop-up-menu (:constructor create-pop-up menu) (:print-function print-pop-up-menu)) viewport (state 'not-choosing) choice ; Set when an item is chosen. button ; Set the button used to choose. )

(defun print-pop-up-menu (menu stream level) "print a pop-up menu structure in a simple way" (declare (ignore level)) (format stream "#<~:(~S~) ~X>" (structure-type menu) (%pointer menu)))

(defmacro menu-complement-region (bitmap region) ;; boole-c2 is more efficient, but it doesn't work on ;; all machines. '(bitblt-region ,bitmap ,region ,bitmap ,region boole-c2)) ;;; Set up menu mouse button handling. (defvar *menu-mouse-buttons* (list :left :middle :right) "Button(s) usable to select menu items. Default is all of them.")

;;; This function gives *MENU-MOUSE-BUTTONS* read access. (defun menu-mouse-buttons () *menu-mouse-buttons*)

;;; The function SET-MENU-MOUSE-BUTTONS ensures that only ;;; left, middle, and right buttons have write access. It ;;; does not allow all of them to be disabled at once. blst ;;; is a list of button keywords. (defun set-menu-mouse-buttons (blst) (setq *menu-mouse-buttons* (or (let ((buttons nil)) (dolist (button blst) (when (memq button '(:left :middle :right)) (push button buttons))) buttons) (list :right) ; Always leave one enabled.))) (defsetf menu-mouse-buttons set-menu-mouse-buttons)

;;; The function MAKE-MENU-ITEM-SELECT-FN returns a closure for a ;;; menu item. The closure is invoked on a button click. It ;;; checks that the button is currently usable to select the item, ;;; and then it returns the item and the name of the button. (defun make-menu-item-select-fn (menu value) #'(lambda (viewport active-region mouse-char x y) (declare (ignore viewport active-region mouse-char x y)) (when (eq (pop-up-menu-state menu) 'awaiting-choice) (case mouse-char (#\mouse-right (when (memq :right *menu-mouse-buttons*) (setf (pop-up-menu-state menu) 'returning-choice (pop-up-menu-choice menu) value (pop-up-menu-button menu) :right))) (#\mouse-middle (when (memq :middle *menu-mouse-buttons*) (setf (pop-up-menu-state menu) 'returning-choice (pop-up-menu-choice menu) value (pop-up-menu-button menu) :middle))) (#\mouse-left (when (memq :left *menu-mouse-buttons*) (setf (pop-up-menu-state menu) 'returning-choice (pop-up-menu-choice menu) value (pop-up-menu-button menu) :left)))))))

;;; The function MAKE-POP-UP-MENU makes the pop-up menu. (defun make-pop-up-menu (choice-list &optional default-value font foreground background) (check-type choice-list list) (if font (unless (fontp font) (setq font (find-font font))) (setq font (find-font "ITALIC"))) (let ((max-string-width 0) item-count)

;; Run through the list to find out the number of entries ;; and the maximum width of an entry. (do ((i 0 (1+& i)) (choice-list-cdr (cdr choice-list) (cdr choice-list-cdr)) (choice (car choice-list) (car choice-list-cdr)) (string-name)) ((null choice) (setq item-count i)) (cond ((symbolp choice) (setq string-name (symbol-name choice))) ((and (consp choice) (stringp (car choice))) (setq string-name (car choice))) (t (error "The ~:R element of the choice list, ~S, ~ must be either a symbol or a cons whose car is a string" (1+& i) choice))) (setq max-string-width (max& max-string-width (string-width string-name font))))

;; Find out the size and width of the menu. (let* ((font-height (font-height font)) (black-border *menu-black-border-width*) (top-space (ceiling (* *menu-top-white-space* font-height))) (bottom-space (ceiling (* *menu-bottom-white-space* font-height))) (side-space (ceiling (* *menu-side-white-space* font-height))) (between-space (ceiling (* *menu-between-white-space* font-height))) (side-margin (+& side-space black-border)) (selection-height (+& font-height between-space between-space)) (menu-width (+& max-string-width side-margin side-margin)) (menu-height (+ (*& item-count selection-height) (*& 2 black-border) top-space bottom-space)) (root-viewport (root-viewport)) (screen-width (bitmap-width root-viewport)) (screen-height (bitmap-height root-viewport)))

(when (>& menu-width screen-width) (error "Creation of Pop-Up Menu for choice-list ~S is wider than the screen" choice-list)) (when (>& menu-height screen-height) (error "Creation of Pop-Up Menu for choice-list ~S is taller than the screen" choice-list)) (let* ((bitmap (make-bitmap :width menu-width :height menu-height)) (menu (create-pop-up-menu :viewport (make-viewport :bitmap bitmap :activate nil :viewport-foreground foreground :viewport-background background)))) ;; First put the borders in the bitmap at the top ;; and bottom. (bitblt bitmap 0 0 bitmap 0 0 menu-width black-border boole-set) (bitblt bitmap 0 0 bitmap 0 (-& menu-height black-border) menu-width black-border boole-set) ;; Now add left and right borders. (bitblt bitmap 0 0 bitmap 0 0 black-border menu-height boole-set) (bitblt bitmap 0 0 bitmap (-& menu-width black-border) 0 black-border menu-height boole-set) ;; Make an active region covering the entire bitmap. (make-active-region bitmap :bitmap bitmap :mouse-exit-region #'(lambda (viewport active-region mouse-event x y) (declare (ignore viewport active-region mouse-event x y)) (when (eq (pop-up-menu-state menu) 'awaiting-choice) ;;Region exitted, return default-value and button ;; NIL (setf (pop-up-menu-state menu) 'returning-choice (pop-up-menu-choice menu) default-value (pop-up-menu-button menu) nil))))

;; Now look at each active region in turn. (do ((choice-list-cdr (cdr choice-list) (cdr choice-list-cdr)) (choice (car choice-list) (car choice-list-cdr)) (active-region-top (+& black-border top-space) (+& active-region-top selection-height)) (inner-width (+& max-string-width side-space side-space)) ; The width minus black border. (print-offset (+& between-space (font-baseline font)))) ; Space between top of active ; region and printing baseline. ((null choice)) (let ((name (if (symbolp choice) (symbol-name choice) (car choice))) (value (if (symbolp choice) choice (cdr choice)))) ;; First write out the string. (let ((string-width (string-width name font))) (let ((baseline (+& active-region-top print-offset)) (x-offset (truncate& (-& menu-width string-width) 2))) (stringblt bitmap (make-position x-offset baseline) font name))) ;; Now make the active region. (make-active-region (make-region :x black-border :width inner-width :y active-region-top :height selection-height) :bitmap bitmap :mouse-enter-region #'(lambda (viewport active-region mouse-event x y) (declare (ignore mouse-event x y)) (menu-complement-region viewport active-region)) :mouse-exit-region #'(lambda (viewport active-region mouse-event x y) (declare (ignore mouse-event x y)) (menu-complement-region viewport active-region)) :mouse-click (make-menu-item-select-fn menu value)))) menu))))

;;; The function POP-UP-MENU-CHOOSE displays a pop-up menu and ;;; awaits a selection. It allows asynchronous method ;;; invocation. It passes back to caller both the selection and ;;; the button that was depressed. (defun pop-up-menu-choose (pop-up-menu) (declare (special *mouse-x* *mouse-y*)) (check-type pop-up-menu pop-up-menu) (let ((root (root-viewport)) (viewport (pop-up-menu-viewport pop-up-menu))) ;; Run events for this viewport only because scroll bars write ;; directly to the screen. (with-mouse-methods-preempted viewport (let ((menu-width (bitmap-width viewport)) (menu-height (bitmap-height viewport)) (root-width (bitmap-width root)) (root-height (bitmap-height root))) (let ((max-x (-& root-width menu-width)) (max-y (-& root-height menu-height)) (best-x (-& *mouse-x* (ceiling& menu-width 2))) (best-y (-& *mouse-y* (ceiling& menu-height 2)))) (let ((actual-x (min& (max& 0 best-x) max-x)) (actual-y (min& (max& 0 best-y) max-y))) (unwind-protect (progn (move-viewport viewport actual-x actual-y) (setf (pop-up-menu-state pop-up-menu) 'awaiting-choice) ;; Expose it before activating it to make sure ;; it is fully visible on the screen. (expose-viewport viewport) (activate-viewport viewport) ;; Now let them run. (process-wait "Menu Choose" #'(lambda (menu) (eq (pop-up-menu-state menu) 'returning-choice)) pop-up-menu) (values (pop-up-menu-choice pop-up-menu) (pop-up-menu-button pop-up-menu))) (setf (pop-up-menu-state pop-up-menu) 'not-choosing) (deactivate-viewport viewport))))))))

The Window Tool Kit - 9 SEP 1996

Generated with Harlequin WebMaker