Re: menu items with fonts

[alice@cambridge.apple.com (Alice K. Hartley)]

At  9:42 PM 2/25/93 -0500, Mark A. Tapia wrote:
>"Dave Wroblewski" <davew@atqm.advtech.uswest.com> writes on
>Thu Feb 25 18:14:22 1993 that the system does not allow him
>to draw the menu items using the font associated with the menu
>when the mouse button is down. In fact, none of the style 
>attributes appear to work (e.g. :italic :bold etc.).
>
>The problem is that the pop-up menu display uses the toolbox trap
>#_PopUpMenuSelect which appears to ignore the font attributes of the
>view.  The proper font is displayed when the mouse button is not
>down within the popup area. The menu items appear in Chicago 12 point
>plain when items are being selected from the menu.
>
>Perhaps this problem is an attempt to enforce a menu standard 
>for popup menus.
>
>It appears that you need to define your own menu-select method
>to avoid this problem, duplicating the system defined trap.
>
>mark

Here's a version of menu-select for pop-up-menu that a) works
in system 6 and b) gets the font right. 

(in-package :ccl)


(defconstant $LastSPExtra #xB4C)                ; (long) most recent value
of space extra       
(defconstant $SysFontFam #xBA6)                 ; (word) System font family
ID or zero          
(defconstant $SysFontSize #xBA8)
 
(defmethod menu-select ((menu pop-up-menu) num
                        &aux selection
                        selected-menu
                        selected-menu-item
                        (a-rect (pop-up-menu-rect menu))
                        (pos (with-focused-view (view-container menu)
                               (%local-to-global 
                                (wptr menu)
                                (rref a-rect :rect.topleft)))))
  (declare (ignore num))
  (menu-update menu)
  (multiple-value-bind (ff ms)(view-font-codes menu)
  (let* ((handle (menu-handle menu))
         (items (menu-items menu))
         (orig (if items (menu-item-title (car items))))
         (font (lsh ff -16))
         (font-size (logand ms #xffff))
         (sysfont (%get-word (%int-to-ptr $sysfontfam)))
         (sys-size (%get-word (%int-to-ptr $sysfontsize)))
         (same-p  (and (= font sysfont)
                       (or (eq sys-size font-size)
                           (and (zerop sys-size)(eq font-size 12))))))    
    (unwind-protect
      (let ()
        (unless same-p
          (setf (%get-word (%int-to-ptr $sysfontfam)) font)
          (setf (%get-word (%int-to-ptr $sysfontsize)) font-size)
          (setf (%get-long (%int-to-ptr $LastSPExtra)) -1))
        (setq selection (#_PopUpMenuSelect
                     :ptr handle
                     :word (+ (point-v pos) (menu-display-v-offset menu))
                     :word (+ (point-h pos) (menu-display-h-offset menu))
                     :word (or (pop-up-menu-default-item menu) 0)
                     :long)
              ;we get the selected menu in case you want to break the rules
              ;and use heirarchical menus in a pop-up menu
              selected-menu (menu-object (ash (logand #xFFFF0000 selection)
-16))
              selected-menu-item (logand #x0000FFFF selection)))
      (unless  same-p
          (setf (%get-word (%int-to-ptr $sysfontfam)) sysfont)        
          (setf (%get-word (%int-to-ptr $sysfontsize)) sys-size)
          (setf (%get-long (%int-to-ptr $LastSPExtra)) -1)))
    (unless (eq selected-menu-item 0)
      (let ((items (menu-items selected-menu)))
        (when (pop-up-menu-auto-update-default menu)
          (set-pop-up-menu-default-item menu
                (if (eq selected-menu menu)
                  selected-menu-item
                  (let ((1st-level-submenu selected-menu))
                    (loop
                      (let ((owner (menu-owner 1st-level-submenu)))
                        (if (eq owner menu)
                          (return (1+ (position 1st-level-submenu
(menu-items menu)))))
                        (if (null owner)
                          (return (pop-up-menu-default-item menu)))
                        (setq 1st-level-submenu owner))))))
          (when (eq (pop-up-menu-item-display menu) :selection)
            (invalidate-view menu)))
        (menu-item-action
         (nth (- selected-menu-item 1) items)))))))

(defmethod menu-display-v-offset ((menu pop-up-menu))
  1)



(defmethod menu-display-h-offset ((menu pop-up-menu))
  1)

(defmethod set-pop-up-menu-default-item ((menu pop-up-menu) num)
  (let* ((old (pop-up-menu-default-item menu))
         (items (menu-items menu)))    
    (when (neq old num)
      (when (neq old 0)
        (set-pop-up-item-check-mark (nth (1- old) items) nil))
      (when (and num (neq num 0))
        (set-pop-up-item-check-mark (nth (1- num) items) t))
      (setf (pop-up-menu-default-item menu) num))))

(defun set-pop-up-item-check-mark (item mark)
  (let ((menu (menu-item-owner item)))
    (when (and menu (eq mark t)
               (neq (lsh (view-font-codes menu) -16)
                    (%get-word (%int-to-ptr $sysfontfam)))) 
      (setq mark #\dot)) ; or #\altCheckMark
    (set-menu-item-check-mark item mark)))

(defparameter *name-char-alist*
  '(("Null" . #\000) ("Nul" . #\000)
    ("Home" . #\001)
    ("Enter" . #\003)
    ("End" . #\004)
    ("Help" . #\005)
    ("Bell"  . #\007) ; ^G , used by Franz
    ("Delete" . #\010) ("Backspace" . #\010)("BS" . #\010)
    ("Tab" . #\011)
    ("Linefeed" . #\012) ("LF" . #\012)
    ("PageUp" . #\013)
    ("Page" . #\014)("PageDown" . #\014)("Formfeed" . #\014) ("FF" . #\014)
    ("Newline" . #\015) ("Return" . #\015) ("CR" . #\015)
    ("CommandMark" . #\021)
    ("CheckMark" . #\022)
    ("DiamondMark" . #\023)
    ("AppleMark" . #\024)
    ("ESC" .  #\033) ("Escape" . #\033) ("Clear" .  #\033)
       ("Altmode" .  #\033) ("ALT" .  #\033)
    ("BackArrow" . #\034) ("Backward-arrow" . #\034)
    ("ForwardArrow" . #\035) ("Forward-arrow" . #\035)
    ("UpArrow" . #\036) ("Up-arrow" . #\036)
    ("DownArrow" . #\037) ("Down-arrow" . #\037)
    ("Space" . #\040)
    ("Dot" . #\245)
    ("altCheckMark" . #\303)
    ("DEL" . #\177)("ForwardDelete" . #\177) ("Rubout" . #\177)
    ))