5 Pop-Up Menus

5.3 Pop-up menu code

(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))))))))

Generated with Harlequin WebMaker