NextPrevUpTopContentsIndex

10.5.1.2 Implementing Gadgets

The following shows how a push button gadget might be implemented.

;; A PUSH-BUTTON uses the ACTIVATE-CALLBACK, and has a label. 
;; This is the abstract class 
(defclass push-button (action-gadget labelled-gadget) ()) 
 
;; Here is a concrete implementation of a PUSH-BUTTON. 
;; The "null" frame manager create a pane of type PUSH-BUTTON-PANE when 
;; asked to create a PUSH-BUTTON. 
(defclass push-button-pane 
  (push-button leaf-pane space-requirement-mixin) 
  ((show-as-default :initarg :show-as-default 
                    :accessor push-button-show-as-default) 
   (armed :initform nil)))
 
;; General highlight-by-inverting method 
(defmethod highlight-button ((pane push-button-pane) medium) 
  (with-bounding-rectangle* (left top right bottom) (sheet-region pane)
                            (draw-rectangle*
                             medium left top right bottom 
                             :ink +flipping-ink+ :filled t))) 
 
;; Compute the amount of space required by a PUSH-BUTTON-PANE 
(defmethod compose-space ((pane push-button-pane) &key width height)
  (multiple-value-bind (width height) 
      (compute-gadget-label-size pane) 
    (make-space-requirement :width width :height height))) 
 
;; This gets invoked to draw the push button. 
(defmethod repaint-sheet ((pane push-button-pane) region) 
  (declare (ignore region)) 
  (with-sheet-medium (medium pane) 
                     (let ((text (gadget-label pane)) 
                           (text-style (slot-value pane 'text-style)) 
                           (armed (slot-value pane 'armed)) 
                           (region (sheet-region pane))) 
                       (multiple-value-call #'draw-rectangle* 
                         medium (bounding-rectangle*
                                 (sheet-region pane)) 
                         :filled nil) 
                       (draw-textmedium
                        text 
                        (clim-utils::bounding-rectangle-center region)
                        :text-style text-style 
                        :align-x ':center 
                        :align-y ':top) 
                       (when (eql armed ':button-press) 
                         (highlight-button pane medium))))) 
 
;; When we enter the push button's region, arm it. 
(defmethod handle-event ((pane push-button-pane) 
                         (event pointer-enter-event)) 
  (with-slots (armed) pane 
              (unless armed 
                (setf armed t) 
                (armed-callback
                 pane (gadget-client pane) (gadget-id pane))))) 
 
;; When we leave the push button's region, disarm it. 
(defmethod handle-event ((pane push-button-pane) 
                         (event pointer-exit-event)) 
  (with-slots (armed) pane 
              (when armed 
                (when (eql armed ':button-press) 
                  (highlight-button pane medium)) 
                (setf armed nil) 
                (disarmed-callback
                 pane (gadget-client pane) (gadget-id pane)))))
 
;; When the user presses a pointer button, ensure that the button 
;; is armed, and highlight it. 
(defmethod handle-event ((pane push-button-pane) 
                         (event pointer-button-press-event)) 
  (with-slots (armed) pane 
              (unless armed 
                (setf armed ':button-press) 
                (armed-callback
                 pane (gadget-client pane) (gadget-id pane)) 
                (with-sheet-medium (medium pane) 
                                   (highlight-button pane medium)))))
 
;; When the user releases the button and the button is still armed, 
;; call the activate callback. 
(defmethod handle-event ((pane push-button-pane) 
                         (event pointer-button-release-event)) 
  (with-slots (armed) pane 
              (when (eql armed ':button-press) 
                (activate-callback
                 pane (gadget-client pane) (gadget-id pane)) 
                (setf armed t) 
                (with-sheet-medium (medium pane) 
                                   (highlight-button pane medium)))))

CommonLisp Interface Manager 2.0 User's Guide - 30 Jul 2004

NextPrevUpTopContentsIndex