;; -*- MODE:LISP; Package:CLIO-OPEN; Base:10; Lowercase:T; Fonts:(CPTFONT); Syntax:Common-Lisp -*-


;;;----------------------------------------------------------------------------------+
;;;                                                                                  |
;;;                          TEXAS INSTRUMENTS INCORPORATED                          |
;;;                                  P.O. BOX 149149                                 |
;;;                                AUSTIN, TEXAS 78714                               |
;;;                                                                                  |
;;;             Copyright (C) 1989, 1990 Texas Instruments Incorporated.             |
;;;                                                                                  |
;;; Permission is granted to any individual or institution to use, copy, modify, and |
;;; distribute this software, provided that  this complete copyright and  permission |
;;; notice is maintained, intact, in all copies and supporting documentation.        |
;;;                                                                                  |
;;; Texas Instruments Incorporated provides this software "as is" without express or |
;;; implied warranty.                                                                |
;;;                                                                                  |
;;;----------------------------------------------------------------------------------+


(in-package "CLIO-OPEN")

(proclaim '(special *default-display-text-font*)) ;; defined in display-text.lisp

(EXPORT '(
	  action-button
	  button-font
	  button-label
	  button-label-alignment
	  button-switch
	  choice-item-highlight-default-p
	  choice-item-font
	  choice-item-highlight-selected-p
	  choice-item-label
	  choice-item-selected-p
	  make-action-button
	  make-action-item
	  make-toggle-button
	  action-item
	  toggle-button
	  )
	'clio-open)

;;; =================================================================================== ;;;
;;;											;;;
;;;	 C o n s t a n t s   a n d   S t r u c t u r e s   f o r   B u t t o n s	;;;
;;;											;;;
;;; =================================================================================== ;;;

(DEFUN create-filled-in-circle-image (circle-image)

  (LET ((width (image-width circle-image))
	(height (image-height circle-image))
	(circle-pixarray (image-z-pixarray circle-image))
	filled-in-pixarray next-pixel)

    (SETF filled-in-pixarray (make-array `(,height ,width) :element-type 'bit))

    (DO ((row 0 (1+ row)) first-1-pixel last-1-pixel)
	((= row height))

      ;;  Copy pixels upto the first 1-pixel found scanning from the left...
      (DO ((col 0 (1+ col)))
	  ((= col width)			; If no 1-pixels found, claim one was
	   (SETF first-1-pixel col))		;   found off right-edge of array.
	(SETF next-pixel (AREF circle-pixarray row col))
	(SETF (AREF filled-in-pixarray row col) next-pixel)
	(WHEN (= next-pixel 1)
	  (SETF first-1-pixel col)
	  (RETURN)))

      ;;  Copy pixels upto the first 1-pixel found scanning from the right...
      (DO ((col (1- width) (1- col)))
	  ((<= col first-1-pixel)		; If no 1-pixels found, use the one
	   (SETF last-1-pixel col))		;   found in left-to-right scan.
	(SETF next-pixel (AREF circle-pixarray row col))
	(SETF (AREF filled-in-pixarray row col) next-pixel)
	(WHEN (= next-pixel 1)
	  (SETF last-1-pixel col)
	  (RETURN)))

      ;;  Fill in the pixels between these two 1-pixels...
      (DO ((col (1+ first-1-pixel) (1+ col)))
	  ((>= col last-1-pixel))
	(SETF (AREF filled-in-pixarray row col) 1)))

    (create-image :width width
		  :height height
		  :data filled-in-pixarray)))


(DEFSTRUCT (button-descriptor (:conc-name "") (:type vector))
  ab-button-ends-image
  ab-clearing-stencil-image
  ab-default-ring-image
  ab-body-clearing-stencil-image
  ab-horizontal-menu-mark-image
  ab-vertical-menu-mark-image
  ab-height
  ab-default-ring-height
  ab-left-button-end-width
  ab-right-button-end-width
  ab-text-baseline				; from top of button.
  tb-min-right-margin
  ab-menu-mark-bottom-rel-to-baseline		; this includes -1 to compensate for height of
						;    menu mark.
  ab-clearing-stencil-array			; pointer to pixarray of clearing-stencil-image.
  ai-default-ring-image
  ai-body-clearing-stencil-image
  ai-height
  ai-default-ring-height
  ai-button-end-width
  ai-text-baseline
  )

;;;
;;;   A structure of this type is the value fo the :OL-button-pixmaps property of the display
;;;   plist.  It is created (if it doesn't already exist for the display) and accessed by the
;;;   function get-button-pixmaps.
;;;
(DEFSTRUCT (button-pixmaps (:conc-name ""))
  ab-button-ends-pixmap
  ab-clearing-stencil-pixmap
  ab-default-ring-pixmap
  ab-body-clearing-stencil-pixmap
  ai-default-ring-pixmap
  ai-body-clearing-stencil-pixmap
  horizontal-menu-mark-pixmap
  vertical-menu-mark-pixmap
  )

(DEFPARAMETER *button-dimensions-by-scale*
  `(:small
       ,(make-button-descriptor
	     :ab-button-ends-image		small-action-button-ends
	     :ab-clearing-stencil-image		(create-filled-in-circle-image
						   small-action-button-ends)
	     :ab-default-ring-image		small-action-button-default-ring
	     :ab-body-clearing-stencil-image	(create-filled-in-circle-image
						   small-action-button-default-ring)
	     :ab-height				18
	     :ab-default-ring-height		13
	     :ab-left-button-end-width		8
	     :ab-right-button-end-width		9
	     :ab-text-baseline			11
	     :tb-min-right-margin		7
	     :ab-horizontal-menu-mark-image	small-horizontal-menu-mark
	     :ab-vertical-menu-mark-image	small-vertical-menu-mark
	     :ab-menu-mark-bottom-rel-to-baseline -1
	     :ai-default-ring-image		small-action-item-default-ring
	     :ai-body-clearing-stencil-image	(create-filled-in-circle-image
						   small-action-item-default-ring)
	     :ai-height				17
	     :ai-default-ring-height		16
	     :ai-button-end-width		8
	     :ai-text-baseline			10
	     )
    :medium
       ,(make-button-descriptor
	     :ab-button-ends-image		medium-action-button-ends
	     :ab-clearing-stencil-image		(create-filled-in-circle-image
						   medium-action-button-ends)
	     :ab-default-ring-image		medium-action-button-default-ring
	     :ab-body-clearing-stencil-image	(create-filled-in-circle-image
						   medium-action-button-default-ring)
	     :ab-height				20
	     :ab-default-ring-height		15
	     :ab-left-button-end-width		9
	     :ab-right-button-end-width		10
	     :ab-text-baseline			12
	     :tb-min-right-margin		8
	     :ab-horizontal-menu-mark-image	medium-horizontal-menu-mark
	     :ab-vertical-menu-mark-image	medium-vertical-menu-mark
	     :ab-menu-mark-bottom-rel-to-baseline -1
	     :ai-default-ring-image		medium-action-item-default-ring
	     :ai-body-clearing-stencil-image	(create-filled-in-circle-image
						   medium-action-item-default-ring)
	     :ai-height				19
	     :ai-default-ring-height		18
	     :ai-button-end-width		9
	     :ai-text-baseline			13
	     )
    :large
       ,(make-button-descriptor
	     :ab-button-ends-image		large-action-button-ends
	     :ab-clearing-stencil-image		(create-filled-in-circle-image
						   large-action-button-ends)
	     :ab-default-ring-image		large-action-button-default-ring
	     :ab-body-clearing-stencil-image	(create-filled-in-circle-image
						   large-action-button-default-ring)
	     :ab-height				22
	     :ab-default-ring-height		17
	     :ab-left-button-end-width		11
	     :ab-right-button-end-width		12
	     :ab-text-baseline			14
	     :tb-min-right-margin		10
	     :ab-horizontal-menu-mark-image	large-horizontal-menu-mark
	     :ab-vertical-menu-mark-image	large-vertical-menu-mark
	     :ab-menu-mark-bottom-rel-to-baseline -2
	     :ai-default-ring-image		large-action-item-default-ring
	     :ai-body-clearing-stencil-image	(create-filled-in-circle-image
						   large-action-item-default-ring)
	     :ai-height				21
	     :ai-default-ring-height		20
	     :ai-button-end-width		10
	     :ai-text-baseline			13
	     )
    :extra-large
       ,(make-button-descriptor
	     :ab-button-ends-image		extra-large-action-button-ends
	     :ab-clearing-stencil-image		(create-filled-in-circle-image
						   extra-large-action-button-ends)
	     :ab-default-ring-image		extra-large-action-button-default-ring
	     :ab-body-clearing-stencil-image	(create-filled-in-circle-image
						   extra-large-action-button-default-ring)
	     :ab-height				28
	     :ab-default-ring-height		23
	     :ab-left-button-end-width		13
	     :ab-right-button-end-width		14
	     :ab-text-baseline			18
	     :tb-min-right-margin		12
	     :ab-horizontal-menu-mark-image	extra-large-horizontal-menu-mark
	     :ab-vertical-menu-mark-image	extra-large-vertical-menu-mark
	     :ab-menu-mark-bottom-rel-to-baseline -2
	     :ai-default-ring-image		extra-large-action-item-default-ring
	     :ai-body-clearing-stencil-image	(create-filled-in-circle-image
						   extra-large-action-item-default-ring)
	     :ai-height				25
	     :ai-default-ring-height		23
	     :ai-button-end-width		14
	     :ai-text-baseline			16
	     )))

;;;
;;;   Set the clear-stencil-array slot of each button-descriptor...
;;;
(EVAL-WHEN (LOAD eval)
  (DOLIST (button-dims *button-dimensions-by-scale*)
    (UNLESS (SYMBOLP button-dims)		; skip the property names...
      (SETF (ab-clearing-stencil-array button-dims)
	    (image-z-pixarray (ab-clearing-stencil-image button-dims))))))


;;;----------------------------------------------------------------------------+
;;;                                                                            |
;;;                                 Label-String                               |
;;;                                                                            |
;;;----------------------------------------------------------------------------+

(deftype label-string () 'string)

(defmethod convert (contact value (type (eql 'label-string)))
  (declare (ignore contact))
  (when (or (symbolp value) (stringp value))
    (stringable-label value)))



;;;----------------------------------------------------------------------------+
;;;                                                                            |
;;;                                  Button                                    |
;;;                                                                            |
;;;----------------------------------------------------------------------------+


(defcontact button (core contact)

  ((font 	:type 		fontable
	 	:reader         button-font			       ; setf defined below
		:initarg	:font
	 	:initform 	*default-display-text-font*)
   
   (label 	:type 		(or pixmap label-string)
	  	:reader   	button-label			       ; setf defined below
		:initarg	:label
	  	:initform 	"")

   (label-alignment
     		:type		(member :left :center :right)
		:accessor	button-label-alignment
		:initarg	:label-alignment
		:initform	:left)

   (compress-exposures
                :initform       :off
		:type           (member :off :on)		
		:reader         contact-compress-exposures
		:allocation     :class)

   (fill-color 	:type		pixel)

   (highlight-default-p
                :type	        boolean
     		:initform	nil
		:reader   	choice-item-highlight-default-p)       ; setf defined below

   ;; Selected slot values:
   ;;     1:   unselected
   ;;     2:   selected,
   ;;     -n:  select has been pressed, receipt of a release select event
   ;;          will complement the selected state
   (selected	:type		integer
		:initform	1)

   (last-displayed-as
     		:type		(member :highlighted :unhighlighted)
		:initform	:unhighlighted)

   (preferred-width
     		:type		(or null integer)
	       	:initform	nil))

  (:resources
    label
    label-alignment
    font))


(DEFGENERIC display-button-highlighted (button &optional x))
(DEFGENERIC display-button-unhighlighted (button &optional x))






;;;----------------------------------------------------------------------------+
;;;                                                                            |
;;;                             Accessors                                      |
;;;                                                                            |
;;;----------------------------------------------------------------------------+



(DEFMETHOD (SETF button-label) (new-label (button button))
  (DECLARE (VALUES (OR pixmap string)))
  (with-slots (label parent preferred-width width height border-width) button

    (let ((converted-label (convert button new-label '(or pixmap label-string))))
      (assert converted-label
	      () "Label ~s is not a stringable, pixmap, or image." new-label)
      (setf label converted-label))
    (SETF preferred-width NIL)	;Note - This forces recalculation of preferred values.

    (if (= 0 width)
	;; The *first* time we must initialize geometry
	(multiple-value-setq (width height)
	  (preferred-size button))
	;; Otherwise we change-geometry to reflect new size
	(when (realized-p button)
	  ;; We defer the change-geometry if button not realized since
	  ;; change-layout will be called when it is realized.
	  (multiple-value-bind (new-width new-height)
	      (preferred-size button)
	    ;; We don't invoke change-geometry unless size actually changed.
	    (unless    
	      (and (= width new-width) (= height new-height))
	      (change-geometry button :width new-width :height new-height :accept-p t)))))
    label))


(defmethod (setf button-font) (new-font (button button))
  (declare (values font))
  (check-type new-font fontable) 
  (with-slots (font label) button
    (setf font (find-font button new-font))
    
    ;; Save original fontname requested. Used again when changing scale.
    (setf (getf (window-plist button) 'fontname) new-font)
    
    (when label
      (setf (button-label button) label)))
  new-font)


(defmethod (setf button-label-alignment) :before (new-alignment (button button))
  (check-type new-alignment (member :left :center :right) "(MEMBER :LEFT :CENTER :RIGHT)"))



;;;----------------------------------------------------------------------------+
;;;                                                                            |
;;;                              Initialization                                |
;;;                                                                            |
;;;----------------------------------------------------------------------------+
 
(defmethod initialize-instance :after ((button button) &key &allow-other-keys)
  (with-slots (label font name fill-color border-width) button
   
    ;;  Initialize font for current scale
    (setf (button-font button) font)
    
    (UNLESS (resource button :name)
      (SETF name (stringable-keyword label)))

    ;; Initialize fill color
    (setf fill-color (contact-current-background-pixel button))

    (SETF border-width 0)

    (MULTIPLE-VALUE-BIND (p-w p-h p-b-w)
	(preferred-size button)
      (change-geometry button :height p-h :width p-w :border-width p-b-w :accept-p t))))


(defmethod rescale :before ((self button))
  ;; Find font for new scale, using original fontname requested.
  (setf (button-font self) (getf (window-plist self) 'fontname)))


;;; =================================================================================== ;;;
;;;											;;;
;;;		     C h o i c e   P r o t o c o l   M e t h o d s			;;;
;;;											;;;
;;; =================================================================================== ;;;

(defmethod (setf choice-item-highlight-default-p) (new-value (button button))
  (declare (values new-highlight-default-p-value))
  (with-slots (highlight-default-p) button
    (let ((new-value (when new-value t)))
      (unless (eq new-value highlight-default-p)
	(setf highlight-default-p new-value)
	(redisplay-button button))))
  new-value)

(DEFMETHOD choice-item-font ((button button))
  (button-font button))


(DEFMETHOD (SETF choice-item-font) (new-value (button button))
  (SETF (button-font button) new-value))


(DEFMETHOD choice-item-label ((button button))
  (button-label button))


(defmethod choice-item-highlight-selected-p ((button button))
  (declare (values highlight-selected-p))
  (with-slots (last-displayed-as) button
    (eq last-displayed-as :highlighted)))


(defmethod (setf choice-item-highlight-selected-p) (new-value (button button))
  (declare (values highlight-selected-p))
  (let ((highlight-selected-p (choice-item-highlight-selected-p button))
	(new-value            (when new-value t)))
    (unless (eq highlight-selected-p new-value)
      (if new-value
	  (display-button-highlighted button)
	  (display-button-unhighlighted button))))
  new-value)


(defmethod choice-item-selected-p ((button button))
  (with-slots (selected) button
    (= (abs selected) 2)))


(defmethod (setf choice-item-selected-p) (new-value (button button))
  (declare (values new-value))
  (let ((new-value (when new-value t)))
    (unless (eq new-value (choice-item-selected-p button))
      (with-slots (selected) button 
	(setf selected (if new-value 2 1))
	(setf (choice-item-highlight-selected-p button) new-value)
	(apply-callback button (if new-value :on :off)))))
  new-value)





;;; =================================================================================== ;;;
;;;											;;;
;;;	   U t i l i t y   F u n c t i o n s    F o r   A l l   B u t t o n s		;;;
;;;											;;;
;;; =================================================================================== ;;;

(DEFEVENT button
	  (:button-press :button-1)
  	  press-select)

(DEFEVENT button
	  (:button-release :button-1)
  	  release-select)

(DEFMETHOD redisplay-button ((button button) &optional completely-p)
  (with-slots (last-displayed-as) button
    (CASE last-displayed-as
      (:unhighlighted (display-button-unhighlighted button completely-p))
      (:highlighted   (display-button-highlighted   button completely-p)))))


(DEFMETHOD display ((button button) &optional at-x at-y at-width at-height &key)
  (DECLARE (IGNORE at-x at-y at-width at-height))
  (WHEN (realized-p button)
    ;;  Put self on the display afresh, completely redrawing everything...
    (redisplay-button button t)))


;;;
;;;   This function is used when a menu button must display the label of its menu's default
;;;   choice, which may not fit within the menu button.  It has more general usage than this,
;;;   should be moved to utilities.lisp.
;;;



(DEFUN get-button-pixmaps (button)
  
  ;;
  ;;  Look on the display's plist for an :OL-button-pixmaps property.  If any action
  ;;  button has created pixmaps from its images, they'll be here...
  ;;
  (LET* ((scale (contact-scale button))
	 (display (contact-display button))
	 (button-pixmaps (GETF (display-plist display) :OL-button-pixmaps))
	 (button-pixmaps-for-this-size-button (GETF button-pixmaps scale))
	 (dims (GETF *button-dimensions-by-scale* scale)))
    
    ;;
    ;;  If there are no pixmaps cached on the display's plist for this scale action button,
    ;;  create some, put them into a button-pixmaps structure, then put it on the display's plist...
    ;;
    (UNLESS button-pixmaps-for-this-size-button
      (SETF button-pixmaps-for-this-size-button
	    (SETF (GETF button-pixmaps scale)
		  (make-button-pixmaps
		    :ab-button-ends-pixmap
		    (image-pixmap button (ab-button-ends-image dims))
		    :ab-clearing-stencil-pixmap
		    (image-pixmap button (ab-clearing-stencil-image dims))
		    :ab-default-ring-pixmap
		    (image-pixmap button (ab-default-ring-image dims))
		    :ab-body-clearing-stencil-pixmap
		    (image-pixmap button (ab-body-clearing-stencil-image dims))
		    :ai-default-ring-pixmap
		    (image-pixmap button (ai-default-ring-image dims))
		    :ai-body-clearing-stencil-pixmap
		    (image-pixmap button (ai-body-clearing-stencil-image dims))
		    :horizontal-menu-mark-pixmap
		    (image-pixmap button (ab-horizontal-menu-mark-image dims))
		    :vertical-menu-mark-pixmap
		    (image-pixmap button (ab-vertical-menu-mark-image dims)))))
      (SETF (GETF (display-plist display) :OL-button-pixmaps) button-pixmaps))
    
    ;;
    ;;  Return the button-pixmaps structure containing the pixmaps for this button's scale...
    ;;
    button-pixmaps-for-this-size-button))


;;;----------------------------------------------------------------------------+
;;;                                                                            |
;;;                           Toggle Button                                    |
;;;                                                                            |
;;;----------------------------------------------------------------------------+



(defcontact toggle-button (button)
  ((pointer-pressed   :type      boolean
		      :initform  nil))
  (:resources
    (border-width :initform 0)
    
    (switch       :type (member :on :off)
		  :initform :off)))

(defun toggle-button-release-menu (self)
   (declare (type toggle-button self))
   (with-slots (pointer-pressed) self
     (when pointer-pressed
       (choice-item-release self)
       (setq pointer-pressed nil))))

(defun toggle-button-leave-with-menu-pressed (self)
   (declare (type toggle-button self))
   (with-slots (pointer-pressed) self
     (with-event (mode)
       (when (and pointer-pressed
		  (eq mode :normal))
	 (choice-item-leave self)
	 (setq pointer-pressed nil)))))

(DEFMETHOD toggle-button-enter-with-menu-pressed ((self toggle-button))
   (with-event (x y state)
     (when (and (inside-contact-p self x y)
		(NOT (ZEROP (LOGAND #.(make-state-mask :button-3) state))))
       ;; The pointer has been dragged over this button w/menu button
       ;; pressed. This has the same side effects as pressing the
       ;; select button so we go ahead and use the press procedure
       ;; to take care of visuals and approve the transition.
       (when (choice-item-press self)
	 ;; Transition was approved and button is now highlighted.
	 ;; We set a flag so :button-release and :leave-notify events
	 ;; will be handled.
	 (with-slots (pointer-pressed) self
	   (setq pointer-pressed t))))))


(DEFEVENT toggle-button
	  :enter-notify
   toggle-button-enter-with-menu-pressed)

(defevent toggle-button
	  :leave-notify
   toggle-button-leave-with-menu-pressed)

(defevent toggle-button
	  (:button-release :button-1)
   tb-maybe-release-select)

;;  These two translations are for Open Look menus, which allow item selection
;;  on both button-1 and button-3 presses.
(DEFEVENT toggle-button
	  (:button-press :button-3)
   press-select)

(DEFEVENT toggle-button
	  (:button-release :button-3)
   toggle-button-release-menu)

(defun tb-maybe-release-select (button)
   (with-slots (pointer-pressed) (the toggle-button button)
     (when pointer-pressed
       (release-select button))))


(defun make-toggle-button (&rest initargs)
  (apply #'make-contact 'toggle-button initargs))




(defmethod initialize-instance :after ((toggle-button toggle-button)
				       &key switch &allow-other-keys)
  (with-slots (selected) toggle-button

    (when (eq switch :on)
	(setf selected 2)
	  (display-button-highlighted toggle-button))))


;;; ========================================================================== ;;;
;;;									       ;;;
;;;        ( T o g g l e )   B u t t o n   P r o t o c o l   M e t h o d s     ;;;
;;;									       ;;;
;;; ========================================================================== ;;;

(defmethod button-switch ((toggle-button toggle-button))
  (with-slots (selected) toggle-button
    (if (= 1 (abs selected)) :off :on)))

(DEFMETHOD (SETF button-switch) (new-state (toggle-button toggle-button))
  (ASSERT (member new-state '( :on :off)) nil
	  "~a is an illegal button state.  Must be :ON or :OFF." new-state)
  (LET ((current-state (button-switch toggle-button)))
    (WHEN (NOT (EQ current-state new-state))
      ;; We simulate a button press and release to implement identical
      ;; semantics whether done via API or via gesture.
      (WHEN (choice-item-press toggle-button)
	;; When toggle press succeeded we follow it
	;; with a release.
	(choice-item-release toggle-button)))
    (button-switch toggle-button)))

(DEFMETHOD leave ((toggle-button toggle-button))
  (with-event (state mode)
    (when (eq mode :normal)
      (with-slots (selected pointer-pressed) toggle-button
	(WHEN (AND (< selected 0)
		   (NOT (ZEROP (LOGAND (make-state-mask :button-1) state))))
	  (choice-item-leave toggle-button)
	  (setq pointer-pressed nil))))))


(DEFMETHOD preferred-size ((toggle-button toggle-button) &key width height border-width)
    (declare (ignore width height border-width))

  (DECLARE (VALUES preferred-width preferred-height
		   preferred-border-width))

  ;;  A toggle-button must draw its border within its window so it can be dimmed if the button
  ;;  becomes insensitive.  So its border-width is zero.
  ;;  Its preferred height is that dictated by its scale slot.
  ;;  Its preferred width is the width of its label plus the right/left margins plus the border
  ;;  width.

  (with-slots (label font preferred-width) toggle-button
    (LET*
      ((scale (contact-scale toggle-button))
       (dims (GETF *button-dimensions-by-scale* scale))
       p-width)

      ;;  Since an Action Button's min-right-margin is 2 more than the interior margin a
      ;;  Toggle Button should have, and since the border width of a Toggle Button is 1, we can
      ;;  just use the Action Button's min-right-margin...
      (SETF p-width (OR preferred-width
			(SETF preferred-width
			      (+ (label-width toggle-button label)
				 (tb-min-right-margin dims) (tb-min-right-margin dims)))))

      ;;  Since an Action Button's height is exactly that of a Toggle Button...

      (VALUES p-width
	      (ab-height dims)
	      0))))


;;;----------------------------------------------------------------------------+
;;;                                                                            |
;;;                            Choice Item Protocol                            |
;;;                                                                            |
;;;----------------------------------------------------------------------------+


(defmethod choice-item-press ((toggle-button toggle-button))
  (with-slots (selected) toggle-button
    (let ((to-selected-p (= selected 1)))
      (when (apply-callback-else (toggle-button :change-allowed-p to-selected-p) t)
	(setf selected (- selected))
	(if to-selected-p
	    (display-button-highlighted toggle-button)
	    (display-button-unhighlighted toggle-button))
	(apply-callback toggle-button :changing to-selected-p)
	t))))

(defmethod choice-item-release ((toggle-button toggle-button))
  (with-slots (selected) toggle-button
    (apply-callback toggle-button (IF (= 2 (SETF selected (+ 3 selected))) :on :off))))

(DEFMETHOD choice-item-leave ((toggle-button toggle-button))
  (with-slots (selected) toggle-button
    (IF (= 2 (SETF selected (- selected)))
	(PROGN
	  (display-button-highlighted toggle-button)
	  (apply-callback toggle-button :canceling-change NIL))
	(PROGN
	  (display-button-unhighlighted toggle-button)
	  (apply-callback toggle-button :canceling-change T)))))

(DEFMETHOD press-select ((toggle-button toggle-button))
   (WHEN (choice-item-press toggle-button)
     (with-slots (pointer-pressed) toggle-button
       (setq pointer-pressed t))))

(DEFMETHOD release-select ((toggle-button toggle-button))
  (with-event (state)
    (with-slots (selected pointer-pressed) toggle-button
      (WHEN (> 0 selected)
	(UNWIND-PROTECT 
	    (choice-item-release toggle-button)
	  (setq pointer-pressed nil))))))


(DEFMETHOD (SETF choice-item-selected-p) (new-value (toggle-button toggle-button))
  ;; Identical to (SETF button-switch) except returns boolean on/off indicator.
  (DECLARE (VALUES new-value))
  (EQ (SETF (button-switch toggle-button) (if new-value :on :off)) :on))




;;; =================================================================================== ;;;
;;;											;;;
;;;	            The Two Ways to Display a Toggle Button...				;;;
;;;											;;;
;;; =================================================================================== ;;;

(DEFUN display-toggle-button (toggle-button mode &optional completely-p)
  (declare (type toggle-button toggle-button))
  (with-slots (font fill-color foreground highlight-default-p width height)
	      toggle-button 
    (WHEN (realized-p toggle-button)
      (LET ((tb-foreground foreground) (tb-fill-color fill-color) (tb-font font)
	    (tb-width width) (tb-height height)
	    stroke-width two-stroke-widths four-stroke-widths
	    (sensitive-p (sensitive-p toggle-button)))
	
	(SETF stroke-width 1
	      two-stroke-widths (* 2 stroke-width)
	      four-stroke-widths (* 2 two-stroke-widths))
	(using-gcontext (gc
			  :drawable 	toggle-button
			  :foreground 	tb-foreground
			  :background 	tb-fill-color
			  :font 	tb-font
			  :line-width	stroke-width
			  :fill-style	(IF sensitive-p :solid :stippled)
			  :stipple	(UNLESS sensitive-p
					  (contact-image-mask toggle-button 50%gray :depth 1)))
	  
	  (WHEN completely-p
	    (clear-area toggle-button
			:x 0
			:y 0
			:width tb-width
			:height tb-height)

	    ;;  Draw our rectangular OL UI border...
	    (DOTIMES (i stroke-width)
		 (draw-rectangle toggle-button gc i i
				 (- tb-width 1 i i)
				 (- tb-height 1 i i)))

	    (display-button-label toggle-button gc))


	  ;;  Draw/erase the highlight indicator...
	  (flet
	    ((draw/erase-default-indicator ()
	       (DOTIMES (i stroke-width)
		 (draw-rectangle toggle-button gc (+ two-stroke-widths i) (+ two-stroke-widths i)
				 (- tb-width four-stroke-widths 1 i i)
				 (- tb-height four-stroke-widths 1 i i))))				   
	     (draw/erase-highlight ()
	       (DOTIMES (i stroke-width)
		 (draw-rectangle toggle-button gc (+ stroke-width i) (+ stroke-width i)
				 (- tb-width two-stroke-widths 1 i i)
				 (- tb-height two-stroke-widths 1 i i))))
	     )
#+ansi-common-lisp (declare (inline draw/erase-default-indicator draw/erase-highlight))
	    ;;  Draw the default indicator if necessary...
	    (if highlight-default-p
	        (draw/erase-default-indicator)
		(with-gcontext (gc :foreground tb-fill-color :background tb-foreground)
		  (draw/erase-default-indicator)))
	    (IF (EQ mode :unhighlighted)
		(with-gcontext (gc :foreground tb-fill-color :background tb-foreground)
		  (draw/erase-highlight))
		(draw/erase-highlight)))

	  )))))


(DEFMETHOD display-button-highlighted ((toggle-button toggle-button) &optional completely-p)
  (with-slots (last-displayed-as) toggle-button
    (display-toggle-button toggle-button :highlighted completely-p)
    (SETF last-displayed-as :highlighted)))


(DEFMETHOD display-button-unhighlighted ((toggle-button toggle-button) &optional completely-p)
  (with-slots (last-displayed-as) toggle-button
    (display-toggle-button toggle-button :unhighlighted completely-p)
    (SETF last-displayed-as :unhighlighted)))



;;; =================================================================================== ;;;
;;;											;;;
;;;	      D i s p l a y   a   T o g g l e   B u t t o n ' s   L a b e l		;;;
;;;											;;;
;;; =================================================================================== ;;;

(DEFMETHOD display-button-label ((self toggle-button) gc)
  (display-any-buttons-label self gc 1 -2))

(defgeneric label-width (button label)
  (:documentation "Return the width of the button LABEL in pixels."))

(defmethod label-width ((button button) (label string))
  (with-slots (font) button
    (text-width font label)))

(defmethod label-width ((button button) (label pixmap)) 
  (or (getf (pixmap-plist label) :width)
      (with-state (label)
	(setf (getf (pixmap-plist label) :width)  (drawable-width label)
	      (getf (pixmap-plist label) :height) (drawable-height label)))))
 
(defun display-any-buttons-label (button gc top-border-thickness left-border-adjustment)
  (with-slots (label label-alignment width height) (the button button)
    (let*
      ((dims        (getf *button-dimensions-by-scale* (contact-scale button)))
       (label-width (label-width button label))
       (margin      (- (ab-left-button-end-width dims) left-border-adjustment)) 
       (left-margin (max margin
			 (case label-alignment
			   (:left   0)
			   (:center (pixel-round (- width label-width) 2))
			   (:right  (- width margin label-width)))))) 
      
      (if (stringp label)
	  (draw-glyphs
	    button gc
	    left-margin (+ top-border-thickness (ab-text-baseline dims))
	    label)
	  
	  ;; Else display pixmap label...
	  (let ((label-height (getf (pixmap-plist label) :height)))
	    (with-gcontext (gc :fill-style :tiled :tile label)
	      (draw-rectangle
		button gc
		left-margin (max 0 (pixel-round (- height label-height) 2))
		label-width label-height t)))))))


;;;----------------------------------------------------------------------------+
;;;                                                                            |
;;;                           Action Button                                    |
;;;                                                                            |
;;;----------------------------------------------------------------------------+


(defcontact action-button (button) ()
  (:resources (border-width :initform 0)))

(defun make-action-button (&rest initargs)
  (apply #'make-contact 'action-button initargs))


(DEFUN circular-list-of-one-item (item)
  "Return a circular list whose elements are ITEM (over and over again)."
  (LET ((tem (LIST item)))
    (RPLACD tem tem)
    TEM))


(defmethod choice-item-press ((action-button action-button))
  
  ;; choice-item-press does the necessary tasks to reflect
  ;; an action-button press provided that the :change-allowed-p
  ;; callback (if any) allows the state change.  The returned
  ;; value indicates whether the press was allowed or not.
  
  (when (apply-callback-else (action-button :change-allowed-p t) t)
    (display-button-highlighted action-button)
    (apply-callback action-button :press)
    (apply-callback action-button :changing t)
    t))

(DEFMETHOD choice-item-release ((action-button action-button))
  
  ;; choice-item-release does the necessary tasks to reflect
  ;; an action-button release.  It is assumed that a press has
  ;; occurred and that the press action was allowed; thus, we
  ;; don't invoke the :change-allowed-p callback again here.

  (with-slots (selected) action-button			     
    (display-action-button-busy action-button)
    (display-force-output (contact-display action-button))

    ;; Ensure highlight is cleaned up in case :release callback performs a throw.
    (unwind-protect
	(apply-callback action-button :release)
      (SETF selected 2)
      (apply-callback action-button :on)
      (SETF selected 1)
      (display-button-unhighlighted action-button)
      (apply-callback action-button :changing NIL)
      (apply-callback action-button :off))))

(DEFMETHOD choice-item-leave ((action-button action-button))
  (display-button-unhighlighted action-button)
  (apply-callback action-button :canceling-change T))

(DEFMETHOD press-select ((action-button action-button))
  (with-event (x y)
    (WHEN (inside-contact-p action-button x y)
      ;;  Choice-item-press will set last-displayed-as if the
      ;;  transition is allowed.
      (choice-item-press action-button))))

(DEFMETHOD release-select ((action-button action-button))
  (with-slots (last-displayed-as) action-button
    ;;  Do nothing unless highlighted/selected already...
    (WHEN (EQ last-displayed-as :highlighted)
      (choice-item-release action-button))))


(DEFMETHOD (SETF choice-item-selected-p) (new-value (action-button action-button))
  (DECLARE (VALUES new-value))
  (with-slots (last-displayed-as) action-button
    ;; For an unselected action button and a new-value of T, this method must act like a button
    ;; press followed immediately by a button release.  If the button is already
    ;; selected, this method does nothing.  Note that to prevent strange behavior if the
    ;; application calls us with a new-value of T from within the action-button's :release
    ;; callback, we do not check the button's selected-p slot.  Instead, we check the button's
    ;; last-displayed-as slot, only doing something if the button is completely inactive.
    (WHEN (and new-value (EQ last-displayed-as :unhighlighted))
      (WHEN (choice-item-press action-button)
	;; When press action was allowed we proceed with
	;; ersatz release.
	(choice-item-release action-button)))
    
    ;; else the application is trying to unselect an action button.  This is meaningful only when
    ;; the action button is selected, which is a momentary state for an action button.  A
    ;; "selected" action button by definition is in the process of transitioning to "unselected".
    ;; As a part of this transition all callbacks will be applied.  So in this case it seems
    ;; reasonable for the method to do nothing
    
    new-value))


(DEFMETHOD leave ((action-button action-button))
  (with-event (state mode)
    (when (eq mode :normal)
      (with-slots (last-displayed-as) action-button
	(WHEN (AND (EQ last-displayed-as :highlighted)
		   (NOT (ZEROP (LOGAND (make-state-mask :button-1) state))))
	  (choice-item-leave action-button))))))

(defevent action-button
	  :leave-notify
   leave)



;;;
;;;	The three basic ways to display an action button...
;;;

(DEFMETHOD redisplay-button ((action-button action-button) &optional completely-p)
  (with-slots (last-displayed-as) action-button
    (CASE last-displayed-as
      (:unhighlighted (display-button-unhighlighted action-button completely-p))
      (:highlighted   (display-button-highlighted   action-button completely-p))
      (:busy	    (display-action-button-busy   action-button completely-p)))))
 
(DEFMETHOD display-button-unhighlighted ((action-button action-button) &optional completely-p)
  (with-slots (font fill-color foreground highlight-default-p last-displayed-as) action-button
    
    (when (realized-p action-button)
      (LET ((ab-foreground foreground) (ab-fill-color fill-color) (ab-font font)
	    (sensitive-p (sensitive-p action-button)))
	
	;;  If displaying a dimmed (insensitive) button, always redraw the entire thing...
	(UNLESS sensitive-p
	  (SETF completely-p t))
	
	(using-gcontext (gc
			  :drawable 	action-button
			  :foreground 	ab-foreground
			  :background 	ab-fill-color
			  :font		ab-font
			  :fill-style	(IF sensitive-p :solid :stippled)
			  :stipple	(UNLESS sensitive-p
					  (contact-image-mask action-button 50%gray :depth 1)))
	  
	  (with-gcontext (gc :foreground ab-fill-color :background ab-foreground)
	    (IF completely-p
		(clear-button-and-display-border action-button gc)
		(just-clear-body-of-button action-button gc)))
	  
	  (display-button-label action-button gc)
	  
	  (WHEN highlight-default-p
	    (display-default-indicator action-button gc)))))
	  
    (SETF last-displayed-as :unhighlighted)))


(DEFMETHOD display-button-highlighted ((action-button action-button) &optional completely-p)

  (with-slots (font fill-color foreground last-displayed-as) action-button
    
    (when (realized-p action-button)
      (LET ((ab-foreground foreground) (ab-fill-color fill-color) (ab-font font))
	
	;;  An insensitive action button can never be busy, so sensitive-p is not checked
	;;  or handled here...
	(using-gcontext (gc
			  :drawable 	action-button
			  :foreground 	ab-fill-color
			  :background 	ab-foreground
			  :font 	ab-font)
	  
	  (with-gcontext (gc :foreground ab-foreground :background ab-fill-color)
	    (IF completely-p
		(clear-button-and-display-border action-button gc)
		(just-clear-body-of-button action-button gc)))
	  
	  (display-button-label action-button gc))))
    (SETF last-displayed-as :highlighted)))



(defmethod display-action-button-busy ((action-button action-button) &optional completely-p)  
  (with-slots (font fill-color foreground last-displayed-as) action-button
    
    (when (realized-p action-button)
      (let ((ab-foreground foreground) (ab-fill-color fill-color) (ab-font font))
	
	;;  An insensitive action button can never be busy, so sensitive-p is not checked
	;;  or handled here...
	 
	  ;;  Clear out the non-margin, non-border part of the button with the busy-pixmap
	  ;;  stipple pattern...
	  (using-gcontext
	    (gc
	      :drawable   action-button
	      :foreground ab-fill-color
	      :background ab-foreground
	      :stipple    (contact-image-mask action-button 88%gray :depth 1)
	      :fill-style :opaque-stippled)
	    (if completely-p
		(clear-button-and-display-border action-button gc)
		(just-clear-body-of-button action-button gc)))

	  ;;  Draw the text label in the foreground color...
	  (using-gcontext
	    (gc
	      :drawable 	action-button
	      :foreground 	ab-foreground
	      :background 	ab-fill-color
	      :font 		ab-font) 
	  (display-button-label action-button gc))))
    
    (setf last-displayed-as :busy)))


(DEFMETHOD display-default-indicator ((action-button action-button) gc)
  ;;  Draws the 1-2 pixel wide default indicator in the foreground color of GC...
  (with-slots (width height) action-button
    (LET* ((scale (contact-scale action-button)) interior-width
	   (dims (GETF *button-dimensions-by-scale* scale))
	   (top-border-thickness (IF (TYPEP action-button 'action-item) 0 1))
	   (button-pixmaps (get-button-pixmaps action-button)))
      
      (SETF interior-width
	    (- width (ab-left-button-end-width dims) (ab-right-button-end-width dims)))

      ;;  Draw the left-end of the default indicator...
      (with-gcontext (gc :clip-x 0 :clip-y top-border-thickness
			 :clip-mask (ab-default-ring-pixmap button-pixmaps))
	(draw-rectangle action-button gc
			0 top-border-thickness
			(ab-left-button-end-width dims) height t))

      ;;  Draw the top horizontal line of the default indicator...
      (draw-rectangle action-button gc
		      (ab-left-button-end-width dims)
		      (+ top-border-thickness 1)
		      interior-width 0)

      ;;  Draw the bttom horizontal line of the default indicator...
      (draw-rectangle action-button gc
		      (ab-left-button-end-width dims)
		      (+ top-border-thickness (ab-default-ring-height dims))
		      interior-width 0)

      ;;  Draw the right-end of the default indicator...
      (with-gcontext (gc :clip-x interior-width :clip-y top-border-thickness
			 :clip-mask (ab-default-ring-pixmap button-pixmaps))
	(draw-rectangle action-button gc
			(+ (ab-left-button-end-width dims) interior-width)
			top-border-thickness
			(ab-right-button-end-width dims) (contact-height action-button) t)))))


(DEFMETHOD just-clear-body-of-button ((action-button action-button) gc)
  (with-slots (width height) action-button
    (LET* ((scale (contact-scale action-button))
	   interior-width body-clear-stencil
	   (dims (GETF *button-dimensions-by-scale* scale))
	   (top-border-thickness (IF (TYPEP action-button 'action-item) 0 1))
	   (button-pixmaps (get-button-pixmaps action-button))
	   (fill-style (gcontext-fill-style gc)))

      (SETF interior-width
	    (- width (ab-left-button-end-width dims) (ab-right-button-end-width dims)))
      
      (when (< interior-width 0)
	(setq interior-width 0))

      (SETF body-clear-stencil (ab-body-clearing-stencil-pixmap button-pixmaps))

      (with-gcontext (gc :fill-style (IF (EQ fill-style :stippled) :solid fill-style))
	
	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	;;   Clear out the button's non-border, non-margin pixels to
	;;	the foreground color of GC...
	
	;;   Start by clearing the left end of the button...
	(with-gcontext (gc :clip-x 0 :clip-y top-border-thickness
			   :clip-mask body-clear-stencil)
	  (draw-rectangle action-button gc 0 top-border-thickness
			  (ab-left-button-end-width dims) (contact-height action-button) t))
	
	;;   Clear out the background for the label...
	(draw-rectangle action-button gc
			(ab-left-button-end-width dims)
			(+ top-border-thickness 1)
			interior-width (ab-default-ring-height dims) t)
	
	;;   Clear out the drawable pixels of the right button end...
	(with-gcontext (gc :clip-x interior-width
			   :clip-y top-border-thickness
			   :clip-mask body-clear-stencil)
	  (draw-rectangle action-button gc
			  (+ (ab-left-button-end-width dims) interior-width)
			  top-border-thickness
			  (ab-right-button-end-width dims) height t))))))


(DEFMETHOD clear-button-and-display-border ((action-button action-button) gc)
  (with-slots (foreground fill-color width height) action-button
    (LET* ((scale (contact-scale action-button))
	   (ab-fill-color fill-color) (ab-foreground foreground) interior-width
	   clear-stencil border-stencil
	   (dims (GETF *button-dimensions-by-scale* scale))
	   (button-pixmaps (get-button-pixmaps action-button))
	   (fill-style (gcontext-fill-style gc)))

      (SETF interior-width
	    (- width (ab-left-button-end-width dims) (ab-right-button-end-width dims)))
      
      (when (< interior-width 0)
	(setq interior-width 0))

      (SETF clear-stencil (ab-clearing-stencil-pixmap button-pixmaps)
	    border-stencil (ab-button-ends-pixmap button-pixmaps))
      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
      ;;   Clear out all the button's pixels to fill-color...
      
      (with-gcontext (gc :fill-style (IF (EQ fill-style :stippled) :solid fill-style))
	
	;;   Start by clearing the left end of the button...
	(with-gcontext (gc :clip-x 0 :clip-y 0 :clip-mask clear-stencil)
	  (draw-rectangle action-button gc 0 0
			  (ab-left-button-end-width dims) height t))
	;;   Clear out the background for the label...
	(draw-rectangle action-button gc
			(ab-left-button-end-width dims) 0
			interior-width height t)
	;;   Clear out the drawable pixels of the right button end...
	(with-gcontext (gc :clip-x interior-width :clip-y 0 :clip-mask clear-stencil)
	  (draw-rectangle action-button gc
			  (+ (ab-left-button-end-width dims) interior-width) 0
			  (ab-right-button-end-width dims) height t)))
      
      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
      ;;   Draw in the button's border in foreground...
      (with-gcontext (gc :foreground ab-foreground :background ab-fill-color
			 :fill-style (IF (EQ fill-style :opaque-stippled) :solid fill-style))
	
	;;   Start by drawing the border on the left end of the button...
	(with-gcontext (gc :clip-x 0 :clip-y 0 :clip-mask border-stencil)
	  (draw-rectangle action-button gc 0 0
			  (ab-left-button-end-width dims)
			  height t))
	
	;;   Draw the top and bottom borders for the label...
	(draw-rectangle action-button gc
			(ab-left-button-end-width dims) 0 interior-width 0)
	
	(draw-rectangle action-button gc
			(ab-left-button-end-width dims) (- (ab-height dims) 2)
			interior-width 1)
	
	;;   Finish by drawing the border on the right end of the button...
	(with-gcontext (gc :clip-x interior-width :clip-y 0 :clip-mask border-stencil)
	  (draw-rectangle action-button gc
			  (+ (ab-left-button-end-width dims) interior-width) 0
			  (ab-right-button-end-width dims) height t)))
      )))


(DEFMETHOD display-button-label ((self action-button) gc)
  (display-any-buttons-label self gc 1 0))


(DEFMETHOD preferred-size ((action-button action-button) &key width height border-width)
    (declare (ignore width height border-width))

  (DECLARE (VALUES preferred-width preferred-height
		   preferred-border-width))

  ;;  An action button always wants a border-width of zero.
  ;;  Its preferred height is that dictated by its scale slot.
  ;;  Given a text label, its preferred width is the width of its label in the font
  ;;    corresponding to the scale plus the widths of its button ends.
  ;;  Given an image or pixmap label, use its width.

  (with-slots (label font preferred-width width height) action-button
    (LET* ((scale (contact-scale action-button))
	  (dims (GETF *button-dimensions-by-scale* scale))
	  p-width p-height)

      (SETF p-width
	    (OR preferred-width
		(SETF preferred-width (+ (ab-left-button-end-width dims)
					 (ab-right-button-end-width dims)
					 (label-width action-button label)))))
      
      (SETF p-height (ab-height dims))

      (VALUES p-width (ab-height dims) 0))))


(DEFMETHOD inside-contact-p ((action-button action-button) x y)
  "Returns T iff the point (X,Y) is within the rounded borders of ACTION-BUTTON."
  (with-slots (width height) action-button
    (LET* ((scale (contact-scale action-button))
	   (dims (GETF *button-dimensions-by-scale* scale)))
      (AND (< -1 x width) (< -1 y height)
	   (OR (<= (ab-left-button-end-width dims)
		   x
		   (- width (ab-right-button-end-width dims) 1))
	       (LET* ((clearing-stencil-array (ab-clearing-stencil-array dims)))	    
		 (WHEN (> x (ab-left-button-end-width dims))
		   (DECF x (- width (ab-left-button-end-width dims) (ab-right-button-end-width dims))))
		 (NOT (ZEROP (AREF clearing-stencil-array x y)))))))))





;;;----------------------------------------------------------------------------+
;;;                                                                            |
;;;                            Action Item                                     |
;;;                                                                            |
;;;----------------------------------------------------------------------------+

;;; An ACTION-ITEM is a specialization of an ACTION-BUTTON and is intended for use
;;; in OL compliant menus.  It differs from an ACTION-BUTTON in appearance as well
;;; as in its sensitivity to various mouse gestures depending on the mode of the
;;; menu which contains it.

(defcontact action-item (action-button) ()
  (:resources
    (label-alignment :initform :left)))

(defun action-item-release-menu (self)
   (declare (type action-item self))
   (with-slots (last-displayed-as) self
     (when (eq last-displayed-as :highlighted)
       (choice-item-release self))))

(defun action-item-leave-with-menu-pressed (self)
  (declare (type action-item self))
  (with-slots (last-displayed-as) self
    (with-event (mode)
      (unless (eq mode :grab)
	(when (eq last-displayed-as :highlighted)
	  (choice-item-leave self))))))

(defun action-item-enter-with-menu-pressed (self)
  (with-slots (last-displayed-as) self
    (when (eq last-displayed-as :unhighlighted)
      (with-event (x y state)
	(when (and (inside-contact-p self x y)
		   (not (zerop (logand #.(make-state-mask :button-3) state))))
	  ;; The pointer has been dragged over this button w/menu button
	  ;; pressed. This has the same side effects as pressing the
	  ;; select button so we go ahead and use the press procedure
	  ;; to take care of visuals and approve the transition.
	  ;; The last-displayed-as slot is set inside choice-item-press
	  ;; if the transition is approved.
	  (choice-item-press self))))))

(DEFEVENT action-item
	  :enter-notify
   action-item-enter-with-menu-pressed)

(defevent action-item
	  :leave-notify
   action-item-leave-with-menu-pressed)

(defevent action-item
	  (:button-release :button-3)
   action-item-release-menu)

;;  This translation is for Open Look menus, which allow item selection
;;  on both button-1 and button-3 presses.
(DEFEVENT action-item
	  (:button-press :button-3)
   press-select)

(defun make-action-item (&rest initargs)
  (apply #'make-contact 'action-item initargs))


;;;
;;;	New drawing methods for an action-item...
;;;

(DEFMETHOD inside-contact-p ((self action-item) x y)
  "Returns T iff the point (X,Y) is within an action-item."
  (with-slots (width height) self
    (AND (< -1 x width) (< -1 y height))))


(defmethod display-button-label ((self action-item) gc)
  (with-slots (label label-alignment font width height) self
    (let*
      ((label-width (label-width self label))
       (dims        (getf *button-dimensions-by-scale* (contact-scale self)))
       (left-margin (max (ai-button-end-width dims)
			 (case label-alignment
			   (:left   0)
			   (:center (pixel-round (- width label-width) 2))
			   (:right  (- width (ai-button-end-width dims) label-width)))))) 
      
      (if (stringp label)
	  (draw-glyphs self gc left-margin (ai-text-baseline dims) label)
	  
	  ;; Else draw pixmap label...
	  (let ((label-height (getf (pixmap-plist label) :height)))
	    (with-gcontext (gc :fill-style :tiled :tile label)
	      (draw-rectangle
		self gc
		left-margin (max 0 (pixel-round (- height label-height) 2))
		label-width label-height t)))))))


(DEFMETHOD display-default-indicator ((action-item action-item) gc)
  ;;  Draws the 1-2 pixel wide default indicator in the foreground color of GC...
  (with-slots (width height) action-item
    (LET* ((scale (contact-scale action-item)) interior-width
	   (dims (GETF *button-dimensions-by-scale* scale))
	   (button-pixmaps (get-button-pixmaps action-item))
	   (button-end-width (ai-button-end-width dims))
	   (default-ring-height (ai-default-ring-height dims)))
      
      (SETF interior-width
	    (- width button-end-width button-end-width))

      ;;  Draw the left-end of the default indicator...
      (with-gcontext (gc :clip-x 0 :clip-y 0
			 :clip-mask (ai-default-ring-pixmap button-pixmaps))
	(draw-rectangle action-item gc
			0  0
			button-end-width default-ring-height t))

      ;;  Draw the top horizontal line of the default indicator...
      (draw-rectangle action-item gc button-end-width 0 interior-width 0)

      ;;  Draw the bottom horizontal line of the default indicator...
      (draw-rectangle action-item gc button-end-width (1- default-ring-height) interior-width 0)

      ;;  Draw the right-end of the default indicator...
      (with-gcontext (gc :clip-x interior-width :clip-y 0
			 :clip-mask (ai-default-ring-pixmap button-pixmaps))
	(draw-rectangle action-item gc
			(+ button-end-width interior-width) 0
			button-end-width default-ring-height t)))))


(DEFMETHOD just-clear-body-of-button ((action-item action-item) gc)
  (with-slots (width height) action-item
    (LET* ((scale (contact-scale action-item)) interior-width body-clear-stencil
	   (dims (GETF *button-dimensions-by-scale* scale))
	   (button-pixmaps (get-button-pixmaps action-item))
	   (button-end-width (ai-button-end-width dims))
	   (default-ring-height (ai-default-ring-height dims))
	   (fill-style (gcontext-fill-style gc)))
      
      (SETF interior-width
	    (- width button-end-width button-end-width))
      
      (when (< interior-width 0)
	(setq interior-width 0))
      
      (SETF body-clear-stencil (ai-body-clearing-stencil-pixmap button-pixmaps))

      (with-gcontext (gc :fill-style (IF (EQ fill-style :stippled) :solid fill-style))
	
	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	;;   Clear out the button's non-border, non-margin pixels to
	;;	the foreground color of GC...
	
	;;   Start by clearing the left end of the button...
	(with-gcontext (gc :clip-x 0 :clip-y 0 :clip-mask body-clear-stencil)
	  (draw-rectangle action-item gc 0 0
			  button-end-width default-ring-height t))
	
	;;   Clear out the background for the label...
	(draw-rectangle action-item gc
			button-end-width 0
			interior-width default-ring-height t)
	
	;;   Clear out the drawable pixels of the right button end...
	(with-gcontext (gc :clip-x interior-width :clip-y 0 :clip-mask body-clear-stencil)
	  (draw-rectangle action-item gc
			  (+ button-end-width interior-width) 0
			  button-end-width default-ring-height t))))))


(DEFMETHOD clear-button-and-display-border ((action-item action-item) gc)
  (with-slots (foreground fill-color width height) action-item

      (clear-area action-item)

      (just-clear-body-of-button action-item gc)))


(DEFMETHOD preferred-size ((action-item action-item) &key width height border-width)
    (declare (ignore width height border-width))

  (DECLARE (VALUES preferred-width preferred-height
		   preferred-border-width))

  ;;  An action button always wants a border-width of zero.
  ;;  Its preferred height is that dictated by its scale slot.
  ;;  Given a text label, its preferred width is the width of its label in the font
  ;;    corresponding to the scale plus the widths of its button ends.
  ;;  Given an image or pixmap label, use its width.

  (with-slots (label font preferred-width width height) action-item
    (LET* ((scale (contact-scale action-item))
	  (dims (GETF *button-dimensions-by-scale* scale))
	  (button-end-width (ai-button-end-width dims))
	  p-width)

      (SETF p-width
	    (OR preferred-width
		(SETF preferred-width (+ button-end-width
					 (label-width action-item label)
					 button-end-width))))

      (VALUES p-width (ai-height dims) 0))))