home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / cl-nd-cl.lha / clue / clio / dlog-button.lisp < prev    next >
Encoding:
Text File  |  1990-07-31  |  44.6 KB  |  1,105 lines
  1. ;;;  -*- Mode:Lisp; Package:CLIO-OPEN; Base:10; Lowercase:T; Syntax:Common-Lisp -*-
  2.  
  3. ;;;----------------------------------------------------------------------------------+
  4. ;;;                                                                                  |
  5. ;;;                          TEXAS INSTRUMENTS INCORPORATED                          |
  6. ;;;                                  P.O. BOX 149149                                 |
  7. ;;;                                AUSTIN, TEXAS 78714                               |
  8. ;;;                                                                                  |
  9. ;;;             Copyright (C) 1989, 1990 Texas Instruments Incorporated.             |
  10. ;;;                                                                                  |
  11. ;;; Permission is granted to any individual or institution to use, copy, modify, and |
  12. ;;; distribute this software, provided that  this complete copyright and  permission |
  13. ;;; notice is maintained, intact, in all copies and supporting documentation.        |
  14. ;;;                                                                                  |
  15. ;;; Texas Instruments Incorporated provides this software "as is" without express or |
  16. ;;; implied warranty.                                                                |
  17. ;;;                                                                                  |
  18. ;;;----------------------------------------------------------------------------------+
  19.  
  20. ;;;
  21. ;;;  Dialog-button and dialog-item, buttons and items that bring up general
  22. ;;;  dialogs when messed with.  Dialogs include menus, property-sheets, commands,
  23. ;;;  and confirms.  Also defined here is the menu protocol event translations,
  24. ;;;  for press-drag-release and click-move-click.
  25.  
  26.  
  27. (in-package "CLIO-OPEN")
  28.  
  29. (export '(
  30.       dialog-button
  31.       dialog-item
  32.       make-dialog-item
  33.       make-dialog-button
  34.       button-dialog
  35.       present-dialog            ; As good a place as any.
  36.       )
  37.     'clio-open)
  38.  
  39.  
  40. ;;;
  41. ;;;  Contact definitions and interface functions.
  42.  
  43. (defcontact dialog-button (action-button)
  44.   ((dialog     :type         (or null list function contact)
  45.            :reader         button-dialog    ; Note (setf button-dialog) below.
  46.            :initarg      :dialog
  47.            :initform     nil))
  48.    (:resources
  49.      (dialog :initform nil
  50.          :type (or null list function contact))))
  51.  
  52. (defun make-dialog-button (&rest initargs)
  53.   (apply #'make-contact 'dialog-button initargs))
  54.  
  55. (defmethod (setf button-dialog) (new-dialog (button dialog-button))
  56.    (check-type new-dialog (or null contact))
  57.    (with-slots (preferred-width dialog) button
  58.      ;;  (LG) Force preferred-size to recalculate width.
  59.      (setq preferred-width nil)
  60.      (when (and dialog
  61.         (not (eq dialog new-dialog)))
  62.        (disassociate-dialog-from-button dialog button)))
  63.    (associate-dialog-with-button new-dialog button))
  64.  
  65.  
  66. ;;  A DIALOG-ITEM is a specialization of an ACTION-ITEM and is intended for use
  67. ;;  in OL compliant menus.  It differs from a DIALOG-BUTTON in appearance as well
  68. ;;  as in its sensitivity to various mouse gestures depending on the mode of the
  69. ;;  menu which contains it.
  70. (defcontact dialog-item (action-item)
  71.    ((dialog     :type         (or null list function contact)
  72.         :reader          button-dialog    ; Note (setf button-dialog) below.
  73.         :initarg      :dialog
  74.         :initform     nil)
  75.     (last-x    :type          integer        ; For drag-right checking.
  76.         :initform     0)
  77.     (active-x   :type          (or null integer)    ; Ditto.
  78.         :initform     nil))
  79.    (:resources
  80.      (dialog :initform nil
  81.          :type (or null list function contact))))
  82.  
  83. (defun make-dialog-item (&rest initargs)
  84.   (apply #'make-contact 'dialog-item initargs))
  85.  
  86. (defmethod (setf button-dialog) (new-dialog (item dialog-item))
  87.    (check-type new-dialog (or null contact))
  88.    (with-slots (preferred-width dialog) item
  89.      ;;  (LG) Force preferred-size to recalculate width.
  90.      (setq preferred-width nil)
  91.      (when (and dialog
  92.         (not (eq dialog new-dialog)))
  93.        (disassociate-dialog-from-button dialog item)))
  94.    (associate-dialog-with-button new-dialog item))
  95.  
  96. (defmethod resize :after ((item dialog-item) width height border-width)
  97.    (declare (ignore width height border-width))
  98.    (with-slots (active-x) item
  99.      (setq active-x nil)))
  100.  
  101. ;;;
  102. ;;;  Other definitions.
  103.  
  104. ;;  A way to get from the dialog back to the button.
  105. (defmacro button-owning-dialog (contact)
  106.    `(getf (window-plist ,contact) 'button-owning-dialog))
  107.  
  108. (defun pointer-inside-menu-p (button menu)
  109.    (declare (ignore button))
  110.    (multiple-value-bind (pointer-x pointer-y same-screen-p)
  111.        (pointer-position menu)
  112.      (and same-screen-p (inside-contact-p menu pointer-x pointer-y))))
  113.  
  114. ;;  A handy place to put the state (nil, press-drag-release, or click-move-click).
  115. (defmacro menu-state (menu)
  116.    `(getf (window-plist ,menu) 'menu-state))
  117.  
  118. ;;  Flag used to handle off-menu presses and releases.
  119. (defmacro menu-button-press-p (menu)
  120.    `(getf (window-plist ,menu) 'menu-button-press-p))
  121.  
  122. (defparameter *menu-item-drag-right-distance* 5
  123.    "Distance in pixels to drag the pointer rightward over a menu item
  124. to bring up a submenu.")
  125.  
  126. (defparameter *menu-cursor-index* top-left-arrow-cursor    ; (That's 132.)
  127.    "Index of glyph used for pointer cursor when grabbed by menu.")
  128.  
  129. ;;  Flag used to prevent multiple drag-mode submenus from appearing.
  130. (defmacro menu-present-in-progress (container)
  131.    `(getf (window-plist ,container) 'present-dialog-in-progress))
  132.  
  133. ;;;
  134. ;;;  Initialisation code.
  135.  
  136. ;;  Allow for a class-name-symbol or list of class-name and initargs by
  137. ;;  parsing the :dialog initarg and making it a contact before passing it
  138. ;;  on to the rest of the init method.
  139. (defmethod initialize-instance :around ((self dialog-button) &rest initargs &key dialog parent)
  140.    (let ((new-dialog (parse-dialog-spec dialog parent)))
  141.      (apply #'call-next-method self :dialog new-dialog initargs)))
  142.  
  143. (defmethod initialize-instance :around ((self dialog-item) &rest initargs &key dialog parent)
  144.    (let ((new-dialog (parse-dialog-spec dialog parent)))
  145.      (apply #'call-next-method self :dialog new-dialog initargs)))
  146.  
  147. (defun parse-dialog-spec (spec parent)
  148.    (etypecase spec
  149.      ((or contact null)    spec)
  150.      ((or symbol function) (funcall spec :parent parent))
  151.      (list           (apply (car spec) :parent parent (cdr spec)))))
  152.  
  153. (defmethod initialize-instance :after ((self dialog-button) &key &allow-other-keys)
  154.    (associate-dialog-with-button (button-dialog self) self))
  155.  
  156. (defmethod initialize-instance :after ((item dialog-item) &key &allow-other-keys)
  157.    (associate-dialog-with-button (button-dialog item) item))
  158.  
  159. (defmethod associate-dialog-with-button ((new-dialog t) button)
  160.    (with-slots (dialog) (the dialog-button button)
  161.      (setq dialog new-dialog)))
  162.  
  163. (defmethod associate-dialog-with-button :after ((new-dialog menu) button)
  164.    (associate-menu-with-dialog-button new-dialog button))
  165.  
  166. ;;  These dialogs use callback instead of event because the action is supposed to happen on release,
  167. ;;  while pressing just highlights.  The callback works, because that's what action-button
  168. ;;  is doing.
  169. (defmethod associate-dialog-with-button :after ((new-dialog command) button)
  170.    (add-callback button :release #'(lambda ()
  171.                      (present-dialog (button-dialog button)))))
  172.  
  173. (defmethod associate-dialog-with-button :after ((new-dialog confirm) button)
  174.    ;;  A bit of a hack for confirm:  We don't want the menu to dismiss until the
  175.    ;;  the confirm does, so if there's a dismiss-menu callback (indicating that
  176.    ;;  our owning button is within a menu), we remove it, extracting its menu
  177.    ;;  argument, and put it on the confirm's :accept and :cancel callbacks instead.
  178.    (let* ((off-callbacks (callback-p button :off))
  179.       (dismiss-callback (assoc #'dismiss-menu off-callbacks)))
  180.      (when dismiss-callback
  181.        (delete-callback button :off #'dismiss-menu)    ; Move from here ...
  182.        (when (typep button 'toggle-button)
  183.      (delete-callback button :off #'dismiss-menu))
  184.        (add-callback new-dialog :cancel #'dismiss-menu (second dismiss-callback))    ; ... to here.
  185.        (add-callback new-dialog :accept #'dismiss-menu (second dismiss-callback))))
  186.    (setf (button-owning-dialog new-dialog) button)
  187.    (add-callback button :release #'(lambda ()
  188.                      (setf (confirm-near (button-dialog button))
  189.                        (viewable-ancestor button))
  190.                      (present-dialog (button-dialog button)))))
  191.  
  192. (defmethod associate-dialog-with-button :after ((new-dialog property-sheet) button)
  193.    (add-callback button :release #'(lambda ()
  194.                      (present-dialog (button-dialog button)))))
  195.  
  196. (defun associate-menu-with-dialog-button (menu button)
  197.    (declare (type menu menu)
  198.         (type (or dialog-button dialog-item) button))
  199.    ;;  Make-menu handles associating dismiss-menu with :on and :off callbacks
  200.    ;;  on each item.  This :unmap callback handles taking down submenus and
  201.    ;;  doing choice-item-release when the menu is withdrawn by dismiss-menu.
  202.    (add-callback menu :unmap #'dismiss-menu-group menu button)
  203.    ;;  Remember owning button for later use in event-handlers.
  204.    (setf (button-owning-dialog menu) button))
  205.  
  206.  
  207. (defmethod disassociate-dialog-from-button ((dialog menu) button)
  208.    (disassociate-menu-from-dialog-button dialog button))
  209.  
  210. (defmethod disassociate-dialog-from-button ((dialog command) button)
  211.    (delete-callback button :release))
  212.  
  213. (defmethod disassociate-dialog-from-button ((dialog confirm) button)
  214.    (add-callback dialog :cancel #'dismiss-menu)
  215.    (add-callback dialog :accept #'dismiss-menu)
  216.    (setf (button-owning-dialog dialog) nil)
  217.    (delete-callback button :release))
  218.  
  219. (defmethod disassociate-dialog-from-button ((dialog property-sheet) button)
  220.    (delete-callback button :release))
  221.  
  222. (defmethod disassociate-dialog-from-button ((dialog null) button)
  223.    (declare (ignore button))
  224.    nil)
  225.  
  226. (defun disassociate-menu-from-dialog-button (menu button)
  227.    (declare (type menu menu)
  228.         (ignore button))
  229.    (setf (button-owning-dialog menu) nil)
  230.    (delete-callback menu :unmap #'dismiss-menu-group))
  231.  
  232. ;;  Hook for an off-menu-press problem:  when leaving an item, turn off the
  233. ;;  off-menu-press flag so an off-menu-release won't dismiss the menu, because
  234. ;;  the press was within an item, not off the menu.  Also a hook for a confirm-
  235. ;;  related grab problem:  when firing an action-item, ungrab the pointer and
  236. ;;  set the menu-state to a special state, finishing, that just ignores enter
  237. ;;  and leave events on the menu.  We need to do this for items whose callbacks
  238. ;;  call confirm-p or some similar dialog-presenting function, so the dialog
  239. ;;  gets a chance to get button presses and releases.
  240. (defmethod add-menu-item-callbacks :after (item menu)
  241.    (add-callback item :canceling-change
  242.          #'(lambda (to-selected-p)
  243.              (declare (ignore to-selected-p))
  244.              (setf (menu-button-press-p menu) nil)))
  245.    (add-callback item :release #'(lambda ()
  246.                    (setf (menu-state menu) 'finishing)
  247.                    (ungrab-pointer (contact-display menu))
  248.                    )))
  249.  
  250. (defun viewable-ancestor (contact)
  251.    (let ((parent (typecase contact
  252.            (menu
  253.             (button-owning-dialog contact))
  254.            (shell
  255.             (shell-owner contact))
  256.            (otherwise
  257.             (contact-parent contact)))))
  258.      (if (typep parent 'root)
  259.      contact
  260.      (let ((ancestor (viewable-ancestor parent)))
  261.        (if (and (mapped-p contact)
  262.             (eq ancestor parent))
  263.            contact
  264.            ancestor)))))
  265.  
  266.  
  267. ;;;
  268. ;;;  Action functions for dialog-button and dialog-item.
  269.  
  270. ;;  Present-dialog methods for other dialogs are in their respective files.
  271. ;;  This method starts the menu protocol defined below in the event handlers,
  272. ;;  and sets position according to the complicated Open Look rules.
  273. (defmethod present-dialog ((menu menu) &key x y button state)
  274.    (declare (type (or card16 null) x y))
  275.    (declare (ignore x y))            ; Stick to Open Look positioning rules.
  276.    (check-type button (or (member :button-1 :button-2 :button-3 :button-4 :button-5) null))
  277.    (check-type state (or mask16 null))
  278.    (let ((owning-button (button-owning-dialog menu)))
  279.      (cond (owning-button
  280.         (set-menu-position owning-button menu
  281.                    (and button state
  282.                     (not (logtest (make-state-mask button) state)))))
  283.        (:else
  284.         ;;  No button, this is a pop-up menu.
  285.         (set-menu-position nil menu
  286.                    (and button state
  287.                     (not (logtest (make-state-mask button) state))))
  288.         (associate-menu-with-dialog-button menu nil)
  289.         ;;  Need this to do the initial grab-handoff to the menu so we can
  290.         ;;  start popups in press-drag-release -- a quick enough button-release
  291.         ;;  will switch to click-move-click, but I'm not sure of the mechanism.
  292.         ;;  Need to do it as a callback because we can't grab until we're mapped,
  293.         ;;  and that doesn't happen immediately.
  294.         (add-callback menu :map
  295.               #'(lambda ()
  296.                   (ungrab-pointer (contact-display menu))
  297.                   (grab-pointer menu #.(make-event-mask :button-release :enter-window :leave-window)
  298.                         :owner-p t
  299.                         :cursor (contact-glyph-cursor menu *menu-cursor-index*))))))
  300.      (setf (contact-state menu) :mapped)
  301.      (setf (menu-state menu) nil)))
  302.  
  303. ;;  Default case, just position it and map it (this method handles commands and
  304. ;;  property-sheets, but not confirms or menus).
  305. (defmethod present-dialog ((contact contact) &key x y button state)
  306.    (declare (type (or (member :button-1 :button-2 :button-3 :button-4 :button-5) null) button)
  307.         (type (or mask16 null) state))
  308.    (declare (ignore button state))
  309.    (check-type x (or card16 null))
  310.    (check-type y (or card16 null))
  311.    (unless (or x y)
  312.      (multiple-value-setq (x y)
  313.        (pointer-position (contact-parent contact))))
  314.    (change-geometry contact :x x :y y :accept-p t)
  315.    (setf (contact-state contact) :mapped))
  316.  
  317.  
  318. ;;  This function is called in the :unmap callback of a menu, which dismiss-menu
  319. ;;  causes to happen by withdrawing the menu.  Other cleanup, like taking down any
  320. ;;  submenus and releasing the button or item, happens here.
  321. (defun dismiss-menu-group (menu button)
  322.    ;;  If there are any submenus up, take them down, too.
  323.    (mapc #'dismiss-submenu-item
  324.      (composite-children (menu-choice menu)))
  325.  
  326.    (when button
  327.      (setf (menu-present-in-progress (contact-parent button)) nil))
  328.  
  329.    (when (and button                ; Button will be NIL for pop-up.
  330.           ;;  Special state, only during leave-notify of menu when exiting
  331.           ;;  to left, which means take down the menu but not any superiors.
  332.           (not (eq (menu-state menu) 'exiting-to-left)))
  333.      ;; NOTE we defer the "release" of the button until the associated
  334.      ;; menu is dismissed.  We do this because the menu button will
  335.      ;; normally never see the actual release event.  Note also that,
  336.      ;; as an action button, the :ON callback is not invoked until the
  337.      ;; release method is invoked.
  338.      (choice-item-release button)
  339.      (release-select button)))
  340.  
  341. (defmethod dismiss-submenu-item (item)
  342.    (declare (ignore item))
  343.    nil)
  344.  
  345. (defmethod dismiss-submenu-item ((item dialog-item))
  346.    (with-slots (dialog) item
  347.      (when (and (typep dialog 'menu)
  348.         (mapped-p dialog))
  349.        (dismiss-menu dialog))))
  350.  
  351. ;;  Used to dismiss any dialogs active under a given menu, when bringing
  352. ;;  up a different dialog from that menu.
  353. (defmethod dismiss-active-dialogs (item)
  354.    (declare (ignore item))
  355.    nil)
  356.  
  357. (defmethod dismiss-active-dialogs ((item dialog-item))
  358.    (with-slots (dialog) item
  359.      (when (mapped-p dialog)
  360.        ;;  This flag, originally used when taking down drag-mode menus by
  361.        ;;  exiting to the left, here is used to prevent superior menus of this
  362.        ;;  one from being taken down.
  363.        (when (typep dialog 'menu)
  364.      (setf (menu-state dialog) 'exiting-to-left))
  365.        (setf (contact-state dialog) :withdrawn)
  366.        (display-button-unhighlighted item))))
  367.  
  368.  
  369. ;;  Special methods for dialog-button because we need to display the default
  370. ;;  on press and select it on release.  The special stuff will only be called
  371. ;;  when the dialog is a menu, the others will just call the next method and
  372. ;;  get the action-button normal stuff.  I'd like to do this in an :after
  373. ;;  method or some other cleaner way, but I need to do this all inside the
  374. ;;  conditional, and I'm not sure how to tell whether it was true.
  375. (DEFMETHOD press-select ((dialog-button dialog-button))
  376.    (with-slots (dialog) dialog-button
  377.      (if (typep dialog 'menu)
  378.      (press-select-show-default dialog-button dialog)
  379.      (call-next-method))))
  380.  
  381. (DEFMETHOD press-select ((dialog-item dialog-item))
  382.    (with-slots (dialog) dialog-item
  383.      (if (typep dialog 'menu)
  384.      (press-select-show-default dialog-item dialog)
  385.      (call-next-method))))
  386.  
  387. (defun press-select-show-default (dialog-button dialog)
  388.   (declare (type action-button dialog-button))           ; Both dialog-item and dialog-button are.
  389.   (with-event (x y)
  390.     (WHEN (and (inside-contact-p dialog-button x y)
  391.            (choice-item-press dialog-button))
  392.       ;;  Show the default value in the button.
  393.       (with-slots (font label fill-color foreground last-displayed-as width height) dialog-button
  394.     (LET* ((scale (contact-scale dialog-button))
  395.            (choice (menu-choice dialog))
  396.            (default (or (choice-default choice)    ; Could be NIL, but Open Look insists.
  397.                 (first (composite-children choice))))
  398.            (ab-foreground foreground)
  399.            (ab-fill-color fill-color)
  400.            (ab-font font)
  401.            (dims (getf *button-dimensions-by-scale* scale))
  402.            (text-x (ab-left-button-end-width dims))
  403.            (text-y (1+ (ab-text-baseline dims))))  ; 0+ for dialog-item.
  404.       
  405. ;;  Experiment:  try changing the label and redisplaying.  Problems:  doesn't
  406. ;;  suppress the menu mark, doesn't show the more-text-to-right gray arrow.
  407. ;       (with-slots (label) dialog-button
  408. ;         (let ((old-label label))
  409. ;           (unwind-protect
  410. ;           (progn (setq label (button-label default))
  411. ;              (redisplay-button dialog-button))
  412. ;         (setq label old-label))))
  413.       
  414.       ;;  Avoid error on abbreviated buttons -- interior width ends up negative.
  415.       ;;  This way, we just highlight and don't even try to show the default.
  416.       (unless (< width (+ (ab-left-button-end-width dims)
  417.                   (ab-right-button-end-width dims)))
  418.         
  419.         (using-gcontext
  420.           (gc
  421.         :drawable   dialog-button
  422.         :foreground ab-foreground
  423.         :background ab-fill-color
  424.         :font        ab-font) 
  425.           (just-clear-body-of-button dialog-button gc))
  426.         
  427.         (using-gcontext
  428.           (gc
  429.         :drawable    dialog-button
  430.         :foreground  ab-fill-color
  431.         :background  ab-foreground
  432.         :font         ab-font)
  433.           
  434.           (let ((default-label (button-label default)))
  435.         (if (stringp default-label)
  436.             (display-constrained-text
  437.               dialog-button gc default-label ab-font
  438.               (label-width dialog-button label)
  439.               :x text-x :y text-y)
  440.             
  441.             (let*
  442.               ((label-width  (label-width dialog-button default-label))
  443.                (label-height (getf (pixmap-plist default-label) :height)))
  444.               (with-gcontext (gc :fill-style :tiled :tile default-label)
  445.             (draw-rectangle
  446.               dialog-button gc
  447.               text-x (max 0 (pixel-round (- height label-height) 2))
  448.               label-width label-height t))))))))))))
  449.  
  450. (DEFUN display-constrained-text (contact gc text font available-width &key (x 0) (y 0))
  451.   (LET* ((more-arrow (GETF *more-text-arrows-by-scale* (contact-scale contact)))
  452.      (more-arrow-image (more-text-arrow-image more-arrow))
  453.      (more-arrow-width (image-width more-arrow-image))
  454.     )
  455.     (FLET
  456.       ((get-displayable-width-of-text (text font available-width)
  457.      ;;  Returns (<#-of-chars-in-text>) if entire text fits.
  458.      ;;  Returns (<#-of-displayable-chars> <npixels-displayable>) if not.
  459.         (IF (<= (text-width font text) available-width)
  460.         (LENGTH text)
  461.       ;;  else we gotta figure out how many chars will fit.
  462.       ;;  Since text-width is a very expensive function we're going to try to get an estimate
  463.       ;;  for where in the text we get too wide to fit before we start calling it.
  464.       
  465.       (DO* ((reduced-space-for-text (- available-width more-arrow-width))
  466.         (est-displayable-length (FLOOR reduced-space-for-text (max-char-width font)))
  467.         (i (1+ est-displayable-length) (1+ i))
  468.         (test-width)
  469.         (last-test-width (text-width font text :end est-displayable-length) test-width)
  470.         )
  471.            ((>= i (LENGTH text)))
  472.         (SETF test-width (text-width font text :end i))
  473.         (WHEN (> test-width reduced-space-for-text)
  474.           (RETURN  (VALUES (1- i) last-test-width))))))
  475.        )
  476.  
  477.     ;;  Get the # of characters that fit (and their width if truncating)...
  478.     (MULTIPLE-VALUE-BIND (displayable-length-of-text displayable-width-of-text)
  479.     (get-displayable-width-of-text text font available-width)
  480.       
  481.       ;;  Draw the characters that we can...
  482.       (draw-glyphs contact gc x y text :end displayable-length-of-text)
  483.       
  484.       ;;  If the entire label would not fit, place a More Text Arrow to the right of it...
  485.       ;;  We assume here that the pixmap for this scale's More Text Arrow has already been
  486.       ;;     cached so contact-mask can pick it up...
  487.       (WHEN displayable-width-of-text
  488.     (LET* ((more-arrow-x (+ x displayable-width-of-text
  489.                 (more-text-arrow-offset-from-text more-arrow)))
  490.            (more-arrow-y (+ y (more-text-arrow-offset-from-baseline more-arrow)))
  491.            (more-arrow-pixmap (contact-image-mask contact more-arrow-image :depth 1)))
  492.       (with-gcontext (gc :clip-x more-arrow-x
  493.                  :clip-y more-arrow-y
  494.                  :clip-mask more-arrow-pixmap)
  495.         (draw-rectangle contact gc more-arrow-x more-arrow-y
  496.                 more-arrow-width (image-height more-arrow-image) t))))))))
  497.  
  498. (DEFMETHOD release-select ((dialog-button dialog-button))
  499.    (with-slots (dialog) dialog-button
  500.      (if (typep dialog 'menu)
  501.      (release-select-choose-default dialog-button dialog)
  502.      (call-next-method))))
  503.  
  504. (DEFMETHOD release-select ((dialog-item dialog-item))
  505.    (with-slots (dialog) dialog-item
  506.      (if (typep dialog 'menu)
  507.      (release-select-choose-default dialog-item dialog)
  508.      (call-next-method))))
  509.  
  510. (defun release-select-choose-default (dialog-button dialog)
  511.    (with-slots (last-displayed-as) (the dialog-button dialog-button)
  512.      ;;  Do nothing unless highlighted/selected already...
  513.      (WHEN (EQ last-displayed-as :highlighted)
  514.        (let ((ultimate-default (find-ultimate-default (menu-choice dialog))))
  515.      (choice-item-press   ultimate-default)
  516.      (choice-item-release ultimate-default)
  517.      (choice-item-release dialog-button)))))
  518.  
  519. (defun find-ultimate-default (choice)
  520.    (let ((default (or (choice-default choice)    ; Could be NIL, but Open Look insists on a default.
  521.               (first (composite-children choice)))))
  522.      (typecase default
  523.        ((or dialog-button dialog-item)
  524.     (let ((dialog (button-dialog default)))
  525.       (if (typep dialog 'menu)
  526.           (find-ultimate-default (menu-choice dialog))
  527.           default)))
  528.        (otherwise
  529.     default))))
  530.  
  531. ;;;
  532. ;;;  Event translations for dialog-button/item and menus.
  533. ;;;
  534. ;;;  These implement a sort of state machine.  The components of the current state
  535. ;;;  are the state of dialog (:mapped or not), the type of the dialog (menus behave
  536. ;;;  differently than other dialogs), and the menu-state of the menu (nil,
  537. ;;;  press-drag-release, or click-move-click).  Mostly they use the type to decide
  538. ;;;  their sensitivity to the event, the state of the dialog to determine whether
  539. ;;;  this is the first time for this event (for example, startup should only happen
  540. ;;;  once), and the menu-state to differentiate between modes for grabbing purposes.
  541. ;;;
  542. ;;;  Dialog button translations.
  543.  
  544. (defevent dialog-button
  545.       (:button-press :button-3)
  546.    dialog-button-do-startup)
  547.  
  548. (defun dialog-button-do-startup (button)
  549.    (let ((dialog (button-dialog button)))
  550.      (when (and (typep dialog 'menu)
  551.         (not (mapped-p dialog))
  552.         (choice-item-press button))
  553.        ;;  Present-dialog on menu sets menu-state to nil.
  554.        (present-dialog dialog :button :button-3 :state (with-event (state) state)))))
  555.  
  556.  
  557. (defevent dialog-button
  558.       (:button-release :button-3)
  559.    dialog-button-button-3-release)
  560.  
  561. (defun dialog-button-button-3-release (button)
  562.   (let ((dialog (button-dialog button)))
  563.     (when (and (typep dialog 'menu)
  564.            (mapped-p dialog)
  565.            (null (menu-state dialog)))
  566.       ;;  Menu just brought up by preceding press, go into click-move-click mode.
  567.       (display-action-button-busy button)
  568.       (grab-pointer dialog #.(make-event-mask :button-press :button-release :enter-window)
  569.             :owner-p t
  570.             :cursor (contact-glyph-cursor dialog *menu-cursor-index*))
  571.       (setf (menu-state dialog) 'click-move-click))))
  572.  
  573.  
  574. (defevent dialog-button
  575.       :leave-notify
  576.    dialog-button-leave-notify)
  577.  
  578. (defun dialog-button-leave-notify (button)
  579.    (declare (type dialog-button button))
  580.    (let ((dialog (button-dialog button)))
  581.      (if (and (typep dialog 'menu)
  582.           (mapped-p dialog)
  583.           (null (menu-state dialog)))
  584.      (with-event (time mode kind root-x root-y)
  585.        (when (eq mode :normal)
  586.          ;; We ungrab the pointer independent of its current location since
  587.          ;; the menu will be responsible for fielding any release event.
  588.          (ungrab-pointer (contact-display button) :time time)
  589.          
  590.          (multiple-value-bind (dialog-x dialog-y)
  591.          (contact-translate (contact-root button) root-x root-y dialog)
  592.            (if (inside-contact-p dialog dialog-x dialog-y) ; Avoid server round-trip.
  593.            (grab-pointer dialog #.(make-event-mask :button-release :enter-window :leave-window)
  594.                  :owner-p t
  595.                  :cursor (contact-glyph-cursor dialog *menu-cursor-index*))
  596.            (grab-pointer dialog #.(make-event-mask :button-release :enter-window)
  597.                  :cursor (contact-glyph-cursor dialog *menu-cursor-index*))))
  598.          (setf (menu-state dialog) 'press-drag-release)))
  599.      
  600.      (with-slots (last-displayed-as) button
  601.        ;;  Do nothing unless highlighted/selected already...
  602.        (WHEN (EQ last-displayed-as :highlighted)
  603.          (leave button))))))
  604.  
  605.  
  606. ;;;
  607. ;;;  Menu translations.
  608.  
  609. (defevent menu
  610.       :button-press
  611.    dialog-button-button-press)
  612.  
  613. (defun dialog-button-button-press (menu)
  614.    (setf (menu-button-press-p menu) t))
  615.  
  616.  
  617. (defevent menu
  618.       :button-release
  619.    dialog-button-dismiss-menu-group)
  620.  
  621. (defun dialog-button-dismiss-menu-group (menu)
  622.    (cond ((null (menu-state menu))
  623.       (setf (menu-state menu) 'click-move-click))
  624.      ((or (menu-button-press-p menu)
  625.           (eq (menu-state menu) 'press-drag-release))
  626.       (dismiss-menu menu)))
  627.    (setf (menu-button-press-p menu) nil))
  628.  
  629.  
  630. (defevent menu
  631.       :enter-notify
  632.    dialog-button-menu-enter-notify)
  633.  
  634. (defun dialog-button-menu-enter-notify (menu)
  635.    (with-event (time mode state)
  636.      (flet ((pdr-enter ()
  637.           ;; First we ungrab the pointer so choice items will get proper
  638.           ;; event notifications
  639.           (ungrab-pointer (contact-display menu) :time time)
  640.           (grab-pointer menu #.(make-event-mask :button-release :enter-window :leave-window)
  641.                 :owner-p t
  642.                 :cursor (contact-glyph-cursor menu *menu-cursor-index*)))
  643.         (cmc-enter ()
  644.           (ungrab-pointer (contact-display menu) :time time)
  645.           (grab-pointer menu #.(make-event-mask :button-press :button-release)
  646.                 :owner-p t
  647.                 :cursor (contact-glyph-cursor menu *menu-cursor-index*))))
  648.        (ecase (menu-state menu)
  649.      ((nil)
  650.       ;;  Pop-up menu, a la SCIFI.  Choose mode based on button state.
  651.       ;;  The test below will be T if button-3 is down, meaning we've entered
  652.       ;;  the menu with the button pressed, hence press-drag-release mode.  If
  653.       ;;  the button is up, we go to click-move-click.
  654.       (cond ((logtest #.(make-state-mask :button-3) state)
  655.          (setf (menu-state menu) 'press-drag-release)
  656.          (pdr-enter))
  657.         (:else
  658.          (setf (menu-state menu) 'click-move-click)
  659.          (cmc-enter))))
  660.      (press-drag-release
  661.       (when (eq mode :normal)
  662.         (pdr-enter)))
  663.      (click-move-click
  664.       (when (eq mode :normal)
  665.         (cmc-enter)))
  666.      (finishing
  667. ;      (when (eq mode :normal)
  668. ;        (setf (menu-state menu) 'click-move-click)
  669. ;        (cmc-enter))
  670.       )
  671.      (exiting-to-left
  672.       ;;  May happen if we leave a dialog-item before the menu's up
  673.       ;;  and have to take it down again.
  674.       nil)))))
  675.  
  676.  
  677. (defevent menu
  678.       :leave-notify
  679.    dialog-button-menu-leave-notify)
  680.  
  681. (defun dialog-button-menu-leave-notify (menu)
  682.    (with-event (time mode x y)
  683.      (when (eq mode :normal)
  684.        (ecase (menu-state menu)
  685.      (press-drag-release
  686.       (ungrab-pointer (contact-display menu) :time time)
  687.       (let ((button (button-owning-dialog menu)))
  688.         (cond ((and (typep button 'dialog-item)
  689.             (< x 0))        ; A crude leave-left-edge test for items.
  690.            (setf (menu-state menu) 'exiting-to-left)    ; Flag for dismiss-menu-group.
  691.            (setf (contact-state menu) :withdrawn)
  692. ;;  +++ I want to do choice-item-leave if the new position isn't within the button.
  693. ;;      The event coordinates are relative to the menu, though, so how exactly do
  694. ;;      I translate them?  In the meantime, it seems to be better to leave always.
  695.            (choice-item-leave button)
  696.            )
  697.           (:else
  698.            (grab-pointer menu #.(make-event-mask :button-release :enter-window)
  699.                  :cursor (contact-glyph-cursor menu *menu-cursor-index*))))))
  700.      (click-move-click
  701.       (ungrab-pointer (contact-display menu) :time time)
  702.       (grab-pointer menu #.(make-event-mask :button-press :button-release :enter-window)
  703.             :cursor (contact-glyph-cursor menu *menu-cursor-index*)))
  704.      (exiting-to-left
  705.       ;;  Need this because there'll be another leave-notify during the unmapping.
  706.       nil)
  707.      (finishing
  708.       nil)))))
  709.  
  710.  
  711. ;;;
  712. ;;;  Dialog item translations.
  713.  
  714. (defevent dialog-item
  715.       (:button-press :button-3)
  716.    choice-item-press)
  717.  
  718.  
  719. (defevent dialog-item
  720.       (:button-release :button-3)
  721.    dialog-item-start-cmc-mode)
  722.  
  723. (defun dialog-item-start-cmc-mode (item)
  724.    (let ((dialog (button-dialog item)))
  725.      (when (not (mapped-p dialog))
  726.        (cond ((typep dialog 'menu)
  727.           ;;  If there are any dialogs up at this level, take them down.
  728.           (mapc #'dismiss-active-dialogs
  729.             (composite-children (contact-parent item)))
  730.           ;;  Dialog-item, superior menu in stay-up mode, we fire on the release
  731.           ;;  and bring up the submenu in stay-up mode.
  732.           (present-dialog dialog :button :button-3 :state 0)
  733.           ;;  This is dialog-button-button-3-release without the grab-pointer.
  734.           (display-action-button-busy item)
  735.           (setf (menu-state dialog) 'click-move-click))
  736.          (:else
  737.           (choice-item-release item))))))
  738.  
  739.  
  740. (defevent dialog-item
  741.       :leave-notify
  742.    leave-dialog-item)
  743.  
  744. (defun leave-dialog-item (item)
  745.   (declare (type dialog-item item))
  746.   (with-event (state mode)
  747.     (cond ((and (logtest #.(make-state-mask :button-3) state)
  748.         (not (mapped-p (button-dialog item))))
  749.        ;;  We set last-x to the right-hand end of the item to force recalculation
  750.        ;;  when we re-enter.
  751.        (with-slots (last-x width) (the dialog-item item)
  752.          (setq last-x width))
  753.        ;; We ungrab the pointer independent of its current location since
  754.        ;; the menu will be responsible for fielding any release event.
  755.        (with-event (time mode)
  756.          (with-slots (last-displayed-as) item
  757.            (when (and (eq mode :normal)
  758.               (eq last-displayed-as :highlighted))
  759.          (ungrab-pointer (contact-display item) :time time)
  760.          (choice-item-leave item)))))
  761.       (:else
  762.        (with-slots (last-displayed-as) item
  763.          ;;  Do nothing unless highlighted/selected already...
  764.          (when (eq last-displayed-as :highlighted)
  765.            (leave item)))))))
  766.  
  767.  
  768. (defevent dialog-item
  769.       :enter-notify
  770.    dialog-item-enter-notify)
  771.  
  772. (defmethod dialog-item-enter-notify ((item dialog-item))
  773.    (with-slots (dialog last-x active-x width last-displayed-as) item
  774.      (when (and (not (mapped-p dialog)) (eq last-displayed-as :unhighlighted))
  775.        (with-event (x y state)
  776.      (if (and (inside-contact-p item x y)    ; +++ Inactive items don't get enter-notify, remove this?
  777.           (logtest #.(make-state-mask :button-3) state)
  778.           (or (not (typep dialog 'menu))
  779.               (not (menu-present-in-progress (contact-parent item))))    ; Don't allow multiple PDR menus.
  780.           ;;  The pointer has been dragged over this button w/menu button
  781.           ;;  pressed. This has the same side effects as pressing the
  782.           ;;  select button so we go ahead and use the press procedure
  783.           ;;  to take care of visuals and approve the transition.
  784.           (choice-item-press item))
  785.          ;;  Transition was approved and button is now highlighted.
  786.          ;;  The choice-item-press is enough for non-menus, but menus have more:
  787.          (when (typep dialog 'menu)
  788.            (when (null active-x)
  789.          (let ((dims (getf *button-dimensions-by-scale* (contact-scale item))))
  790.            (setq active-x (- width
  791.                      (ab-right-button-end-width dims)
  792.                      (image-width (ab-horizontal-menu-mark-image dims))))))
  793.            (setq last-x x)
  794.            (when (>= x active-x)
  795.          ;;  Entered in the "submenu region," which is that area from the
  796.          ;;  left edge of the menu mark to the right edge of the item.
  797.          ;;  If there are any dialogs up at this level, take them down.
  798.          (mapc #'dismiss-active-dialogs
  799.                (composite-children (contact-parent item)))
  800.          ;;  Bring up the menu and go into the submenu protocol.
  801.          (present-dialog dialog :button :button-3 :state state)
  802.          (setf (menu-present-in-progress (contact-parent item)) t)
  803. ;         (setf (menu-state dialog) 'press-drag-release)
  804.          ))
  805.          ;;  Transition not approved, so inhibit the drag-right check on :motion-notify.
  806.          (when (typep dialog 'menu)
  807.            (setq last-x width)))))))
  808.  
  809.  
  810. (defevent dialog-item
  811.       :motion-notify
  812.    dialog-item-drag-right)
  813.  
  814. (defmethod dialog-item-drag-right ((item dialog-item))
  815.    (with-slots (dialog last-x active-x width) item
  816.      (when (and (typep dialog 'menu)
  817.         (not (mapped-p dialog))
  818.         (not (menu-present-in-progress (contact-parent item)))
  819.         active-x)            ; Paranoia check.
  820.        (with-event (x y state)
  821.      (when (and (inside-contact-p item x y)
  822.             (logtest #.(make-state-mask :button-3) state))
  823.        (cond ((or (>= x active-x)
  824.               (> (- x last-x) *menu-item-drag-right-distance*))
  825.           ;;  If there are any dialogs up at this level, take them down.
  826.           (mapc #'dismiss-active-dialogs
  827.             (composite-children (contact-parent item)))
  828.           ;;  Dragged right far enough, or into active area, bring up menu.
  829.           (present-dialog dialog :button :button-3 :state state)
  830.           (setq last-x width)        ; Force recalculation on later entries.
  831.           (setf (menu-state dialog) 'press-drag-release))
  832.          ((< x last-x)            ; Moving left, save leftmost.
  833.           (setq last-x x))
  834.          (:else                ; Moving right, keep old left.
  835.           nil)))))))
  836.  
  837.  
  838. ;;;
  839. ;;;  Display code.  Dialog-buttons and dialog-items show a menu mark or
  840. ;;;  window mark to the right of the item.  These functions and methods
  841. ;;;  allow space for it and do the drawing.
  842.  
  843. (defvar *inside-display-window-mark* nil)    ; Don't do it inside internal routine.
  844.  
  845. ;; Daemons on the Dialog Button's label manipulation methods to adjust the width
  846. ;; of the label for the menu mark and the display the menu mark.
  847. (defmethod label-width :around ((button dialog-button) label)
  848.   (if *inside-display-window-mark*
  849.       (call-next-method)
  850.       (with-slots (dialog) button
  851.     (let ((dims (getf *button-dimensions-by-scale* (contact-scale button))))
  852.       (+ (call-next-method)
  853.          (additional-label-width dialog button dims)
  854.          (- (ab-right-button-end-width dims)
  855.         2))))))                ; Right border thickness
  856.  
  857. (defmethod label-width :around ((button dialog-item) label)
  858.   (if *inside-display-window-mark*
  859.       (call-next-method)
  860.       (with-slots (dialog) button
  861.     (let ((dims (getf *button-dimensions-by-scale* (contact-scale button))))
  862.       (+ (call-next-method)
  863.          (additional-label-width dialog button dims)
  864.          (- (ab-right-button-end-width dims)
  865.         2))))))                ; Right border thickness
  866.  
  867.  
  868. (defmethod additional-label-width ((dialog null) button dims)
  869.    (declare (ignore button dims))
  870.    0)
  871.  
  872. (defmethod additional-label-width ((dialog menu) (button dialog-button) dims)
  873.    (image-width (ab-vertical-menu-mark-image dims)))
  874.  
  875. (defmethod additional-label-width ((dialog menu) (button dialog-item) dims)
  876.    (image-width (ab-horizontal-menu-mark-image dims)))
  877.  
  878. (defmethod additional-label-width ((dialog command) button dims)
  879.    (declare (ignore dims))
  880.    (text-extents (button-font button) "..."))
  881.  
  882. (defmethod additional-label-width ((dialog confirm) button dims)
  883.    (declare (ignore dims))
  884.    (text-extents (button-font button) "..."))
  885.  
  886. (defmethod additional-label-width ((dialog property-sheet) button dims)
  887.    (declare (ignore dims))
  888.    (text-extents (button-font button) "..."))
  889.  
  890.  
  891. (DEFMETHOD display-button-label :after ((button dialog-button) gc)
  892.   ;;  Now draw in the menu-mark at the right end of the button, just to the left of the
  893.   ;;  right-button-end (which leaves right-margin pixels to the right of the mark)
  894.   (with-slots (dialog) button
  895.     (after-display-button-label dialog button gc)))
  896.  
  897. (DEFMETHOD display-button-label :after ((item dialog-item) gc)
  898.   ;;  Now draw in the menu-mark at the right end of the button, just to the left of the
  899.   ;;  right-button-end (which leaves right-margin pixels to the right of the mark)
  900.   (with-slots (dialog) item
  901.     (after-display-button-label dialog item gc)))
  902.  
  903. (defmethod after-display-button-label ((dialog null) button gc)
  904.    (declare (ignore button gc))
  905.    nil)
  906.  
  907. (defmethod after-display-button-label ((dialog menu) (button dialog-button) gc)
  908.    (display-menu-mark button gc :below))
  909.  
  910. (defmethod after-display-button-label ((dialog menu) (item dialog-item) gc)
  911.    (display-menu-mark item gc :to-the-right))
  912.  
  913. (defun display-menu-mark (button gc direction)
  914.    (let ((width (contact-width button)))
  915.      (LET* ((scale          (contact-scale button))
  916.         (dims          (getf *button-dimensions-by-scale* scale))
  917.         (button-pixmaps   (get-button-pixmaps button))
  918.         (menu-mark-image  (ecase direction
  919.                 (:to-the-right
  920.                  (ab-horizontal-menu-mark-image dims))
  921.                 (:below
  922.                  (ab-vertical-menu-mark-image dims))))
  923.         (menu-mark-pixmap (ecase direction
  924.                 (:to-the-right
  925.                  (horizontal-menu-mark-pixmap button-pixmaps))
  926.                 (:below
  927.                  (vertical-menu-mark-pixmap button-pixmaps))))
  928.         (menu-mark-x      (- width
  929.                  (ecase direction
  930.                    (:below
  931.                     (ab-right-button-end-width dims))
  932.                    (:to-the-right
  933.                     (ai-button-end-width dims)))
  934.                  (image-width menu-mark-image)))
  935.         (menu-mark-y      (- (ecase direction
  936.                    (:below      (ab-text-baseline dims))
  937.                    (:to-the-right (1- (ai-text-baseline dims))))
  938.                  (image-height menu-mark-image)
  939.                  ;;  The 1- for :to-the-right is correction to this.
  940.                  (ab-menu-mark-bottom-rel-to-baseline dims))))
  941.        (with-gcontext (gc :clip-x menu-mark-x
  942.               :clip-y menu-mark-y
  943.               :clip-mask menu-mark-pixmap)
  944.      (draw-rectangle button gc
  945.              menu-mark-x menu-mark-y
  946.              (image-width menu-mark-image) (image-height menu-mark-image)
  947.              t)))))
  948.  
  949.  
  950. (defmethod after-display-button-label ((dialog command) button gc)
  951.    (display-window-mark button gc))
  952.  
  953. (defmethod after-display-button-label ((dialog property-sheet) button gc)
  954.    (display-window-mark button gc))
  955.  
  956. (defmethod after-display-button-label ((dialog confirm) button gc)
  957.    (display-window-mark button gc))
  958.  
  959. ;;  Draw the window mark flush against the right end of the label, using
  960. ;;  similar computations to those from display-button-label.
  961. (defmethod display-window-mark ((button dialog-button) gc)
  962.    (with-slots (font label-alignment label width) button
  963.      (let* ((scale (contact-scale button))
  964.         (dims (GETF *button-dimensions-by-scale* scale))
  965.         (label-width (let ((*inside-display-window-mark* t))
  966.                (label-width button label)))
  967.         (margin (ab-left-button-end-width dims))
  968.         (left-margin (max margin
  969.                   (case label-alignment
  970.                 (:left   0)
  971.                 (:center (pixel-round (- width label-width) 2))
  972.                 (:right  (- width margin label-width)))))
  973.         (window-mark-x (+ left-margin label-width 1))    ; Extra pixel looks better.
  974.         (window-mark-y (1+ (ab-text-baseline dims))))
  975.        (with-gcontext (gc :font font)
  976.      (draw-glyphs button gc window-mark-x window-mark-y "...")))))
  977.  
  978. (defmethod display-window-mark ((item dialog-item) gc)
  979.    (with-slots (font label-alignment label width) item
  980.      (let* ((scale (contact-scale item))
  981.         (dims (GETF *button-dimensions-by-scale* scale))
  982.         (label-width (let ((*inside-display-window-mark* t))
  983.                (label-width item label)))
  984.         (margin (ai-button-end-width dims))
  985.         (left-margin (max margin
  986.                   (case label-alignment
  987.                 (:left   0)
  988.                 (:center (pixel-round (- width label-width) 2))
  989.                 (:right  (- width margin label-width)))))
  990.         (window-mark-x (+ left-margin label-width 1))    ; Extra pixel looks better.
  991.         (window-mark-y (ai-text-baseline dims)))
  992.        (with-gcontext (gc :font font)
  993.      (draw-glyphs item gc window-mark-x window-mark-y "...")))))
  994.  
  995. ;;;
  996. ;;;  Position the menu according to the Open Look rules:
  997. ;;;  For a button, centered horizontally with the top edge against the bottom
  998. ;;;  edge of the button.  For an item, with the default item centered vertically
  999. ;;;  relative to the item itself.  In press-drag-release mode (release-p NIL),
  1000. ;;;  positioned horizontally so the left end of the default item is over the
  1001. ;;;  mouse;  in click-move-click mode (release-p T), positioned horizontally so
  1002. ;;;  the left edge of the menu is a pixel away from right edge of the item.
  1003. ;;;
  1004. ;;;  For pop-ups (not yet implemented), the button will be NIL.  In that case,
  1005. ;;;  we align the default item vertically with the mouse, and place the menu so
  1006. ;;;  that the mouse is a pixel or two to the left of the left edge of the default.
  1007.  
  1008. (DEFMETHOD set-menu-position ((self dialog-button) menu &optional release-p)
  1009.   (declare (ignore release-p))
  1010.   (with-slots (width height x y border-width parent) self
  1011.     (unless (realized-p menu)
  1012.       (initialize-geometry menu))
  1013.     
  1014.     (let ((menu-width (contact-width (contact-parent (menu-choice menu)))))
  1015.     ;; We use the width of the *container* so menu will be
  1016.     ;; centered without considering the drop shadow.
  1017.       (multiple-value-bind (menu-x menu-y)
  1018.       (contact-translate      
  1019.         (contact-parent self)
  1020.         (- (+ x (round width 2)) (round menu-width 2))
  1021.         (+ y border-width border-width height 1)
  1022.         (contact-parent menu))
  1023.     (SETF menu-x (MIN (MAX 0 menu-x)
  1024.               (- (contact-width (contact-parent menu)) menu-width)))
  1025.     (change-geometry menu
  1026.              :x menu-x
  1027.              :y menu-y
  1028.              :accept-p t)))))
  1029.  
  1030. ;;  For a dialog-item, the menu comes up to the right, with the default item aligned with
  1031. ;;  the item, center to center.  In pdr mode, the X coordinate is such that the left end of the
  1032. ;;  default item is under the pointer;  in cmc mode, the left edge of the menu is one pixel
  1033. ;;  to the right of the item.
  1034. (DEFMETHOD set-menu-position ((self dialog-item) menu &optional release-p)
  1035.   (initialize-geometry menu)            ; Needed to get correct sizes for Y coord.
  1036.   (with-slots (width height x y border-width parent) self
  1037.     (let* ((choice (menu-choice menu))
  1038.        (default (or (choice-default choice)    ; Could be NIL, but Open Look insists on a default.
  1039.             (first (composite-children choice))))
  1040.        (default-scale (contact-scale default))
  1041.        (dims (GETF *button-dimensions-by-scale* default-scale))
  1042.        (container (contact-parent choice))
  1043.        (menu-width (contact-width container))
  1044.        (menu-height (contact-height container)))
  1045.       ;; We use the width of the *container* so menu will be
  1046.       ;; centered without considering the drop shadow.
  1047.       (multiple-value-bind (default-x default-y)
  1048.       ;;  Translate default-item position into offset from menu 0,0.
  1049.       (contact-translate (contact-parent default)
  1050.                  (contact-x default)
  1051.                  (contact-y default)
  1052.                  menu)
  1053.     (multiple-value-bind (menu-x menu-y)
  1054.         (contact-translate (contact-parent self)
  1055.                    (if release-p
  1056.                    (+ x width border-width border-width 2)    ; I think that's 1 + 1 for default-ring.
  1057.                    (- (+ (pointer-position self)    ; Should be the pointer X.
  1058.                      x)
  1059.                       (ab-left-button-end-width dims)
  1060.                       default-x))
  1061.                    (- (+ y (round height 2))    ; Align the centers in Y.
  1062.                   (+ default-y (round (contact-height default) 2)))
  1063.                    (contact-parent menu))
  1064.       (setq menu-x (MIN (MAX 0 menu-x)
  1065.                 (- (contact-width (contact-parent menu)) menu-width))
  1066.         menu-y (MIN (MAX 0 menu-y)
  1067.                 (- (contact-height (contact-parent menu)) menu-height)))
  1068.       (change-geometry menu
  1069.                :x menu-x
  1070.                :y menu-y
  1071.                :accept-p t))))))
  1072.  
  1073. ;;  For a pop-up menu, there is no item.  Bring it up under the mouse, with the default
  1074. ;;  item centered vertically and its left edge a couple of pixels to the right of the mouse.
  1075. (defmethod set-menu-position ((self null) menu &optional release-p)
  1076.    (declare (ignore release-p))
  1077.    (initialize-geometry menu)            ; Needed to get correct sizes for Y coord.
  1078.    (let* ((choice (menu-choice menu))
  1079.       (default (or (choice-default choice)    ; Could be NIL, but Open Look insists on a default.
  1080.                (first (composite-children choice))))
  1081.       (container (contact-parent choice))
  1082.       (menu-width  (contact-width container))
  1083.       (menu-height (contact-height container)))
  1084.      ;; We use the width of the *container* so menu will be
  1085.      ;; centered without considering the drop shadow.
  1086.      (multiple-value-bind (pointer-x pointer-y)
  1087.      (pointer-position (contact-parent menu))
  1088.        (multiple-value-bind (default-x default-y)
  1089.        ;;  Translate default-item position into offset from menu 0,0.
  1090.        (contact-translate (contact-parent default)
  1091.                   (contact-x default)
  1092.                   (contact-y default)
  1093.                   menu)
  1094.      (let ((menu-x (- pointer-x (- default-x 2)))
  1095.            (menu-y (- pointer-y default-y (round (contact-height default) 2))))
  1096.        (setq menu-x (MIN (MAX 0 menu-x)
  1097.                  (- (contact-width (contact-parent menu)) menu-width))
  1098.          menu-y (MIN (MAX 0 menu-y)
  1099.                  (- (contact-height (contact-parent menu)) menu-height)))
  1100.        (change-geometry menu
  1101.                 :x menu-x
  1102.                 :y menu-y
  1103.                 :accept-p t))))))
  1104.  
  1105.