| allegro-cl archives 1996-12-14 | home index prev H thread prev K thread-next J next L |
|
From: Ken Cheetham Subject: RE: aggregate widgets Date: 1996-12-14 6:48
Does the ACL/Win Common Graphics library support the creation of
aggregate widget types? I know that the tab-control widget falls
under this category, but support for that specific widget seems to be
hard-wired into the other widgets. Or is that not true?
By "aggregate widget type" I mean a widget which is a container for
other widgets, and which can support functionality that depends on the
coordinated activity of the widgets it contains.
There's no official technique provided for this, though the approach
in Matthew Haines' response looks reasonable to me from scanning over
it. By cleverly defining his dialog-item-window class as a subclass
of DIALOG, he was able to create a dialog-item that acts as a child of
an ordinary dialog and also as a parent dialog of its own
dialog-items.
Incidentally, we agree that the division of a widget into separate
dialog-item and dialog-item-window objects is an awkward early design
feature of common graphics, and we hope to combine these into one
at some point if we determine that we can make a reasonably smooth
transition.
Using an intermediate parent window as above is one way to group a
subset of widgets together logically, where the child widgets will
automatically move and shrink with their parent, etc. But they can be
grouped in other ways. The way the tab-control works, for example, is
that whenever you click a tab, common graphics exposes the widgets
that you have associated with the new tab and hides all widgets on the
other tabs. While this association and behavior is hardcoded in the
common graphics code for the tab-control win95 widget, you could
implement similar constraints in your own set-value-fn code for the
built-in widgets, or in widget-set-value methods or other methods for
widgets that you define yourself in lisp.
Below is a rather "complete" (overly detailed?) example of defining a
"vertical gauge" widget in lisp. It demonstrates setting up the
dialog-item and dialog-item-window classes using the lisp-widget
parent class that we provide for convenience (this class knows how to
shift the keyboard focus amongst the widgets, for example), how to
define methods for drawing the widget from scratch and how to respond
to mouse-clicks (including smooth dragging of the gauge value), and so
on.
While this example doesn't allow for child widgets of this widget,
presumably that sort of functionality could be added while using this
basic lisp-widget approach by using DIALOG as the parent class of your
dialog-item-window class as Mathew Haines demonstrated.
The example below is one of several new examples that are featured in
the upcoming 3.0.2 maintenance release, which is currently in beta. A
dialog will be provided that lists the examples and allows you to
easily run them and view the source code with a few clicks.
NOTE: This example is officially for 3.0.2, but it appears to
work just fine in 3.0.1 as is.
Ken Cheetham <franz.com at cheetham>
Franz Inc. Voice: (510) 548-3600
1995 University Avenue, Suite 275 Fax: (510) 548-8253
Berkeley, CA 94704 http: //www.franz.com/
ACL Windows FAQ: ftp.franz.com:/pub/acl4w-faq
ACL Unix FAQ: ftp.franz.com:/pub/faq
---------------------------------------------------------------------------
;; Copyright (c) 1996 Franz Inc, Berkeley, CA
;; All rights reserved.
;;
;; Permission is granted only to any individual or institution which has
;; current Allegro CL license(s) to use, copy, or modify this software,
;; provided any reproduction or distribution of binary versions of this
;; software are compiled with a licensed Allegro CL, and provided
;; that this complete copyright and permission notice is maintained, intact,
;; in all copies and supporting documentation.
;;
;; Franz Incorporated provides this software "as is" without
;; express or implied warranty.
;;
;; Restricted Rights Legend
;; ------------------------
;; Use, duplication, and disclosure of the software, data and information
;; contained herein by any agency, department or entity of the U.S.
;; Government are subject to restrictions of Restricted Rights for
;; Commercial Software developed at private expense as specified in FAR
;; 52.227-19 or DOD FAR Supplement 252 52.227-7013 (c) (1) (ii), as
;; applicable.
;; ------------------------------------------------------------------------
;; How to Define a Lisp Widget --- Vertical Gauge Example
;; This file implements a "vertical gauge" widget as an example
;; of defining a new widget completely in lisp. The gauge draws
;; a vertical bar beside a numeric scale, and the user can click
;; or drag to move the bar to a new value. You can use this sample
;; code as a template for defining your own widgets, using arbitrary
;; lisp code to tell the widget how to draw itself and how to
;; respond to mouse clicks and keypresses.
;; While it is possible to make a generic window act like a widget
;; by simply giving it suitable drawing and mousing behavior, we
;; have set up the classes lisp-widget and lisp-widget-window
;; that you can subclass in order to create a common graphics-style
;; widget, where a dialog-item object is associated with a window
;; object, the dialog-item's set-focus-fn is called automatically
;; at the appropriate time, and so on.
;; The steps that you must take include:
;; * Define your dialog-item and widget-window classes.
;; * Write a device-open method that sets up the widget-window initially.
;; * Define a redisplay-window method that draws the widget.
;; * Define EVENT methods to handle mouse clicks and keypresses.
;; These steps are detailed in the code below.
;; This file defines the widget for programmatic creation.
;; The file vertgagb.lsp shows how to further add it to the
;; interface builder so that the new widget may be created and
;; modified interactively.
(in-package :pc)
;; ---------------------------------------------------------------------
;; In order to use the lisp-widget and lisp-widget-window classes in
;; a runtime application, the lispwij.fsl runtime module must be loaded.
(require :lispwij (merge-pathnames #p"fsl\\lispwij.fsl"
*application-directory*))
;; ---------------------------------------------------------------------
;; Define the widget classes.
(eval-when (load compile eval)
(export '(cg::major-increment
cg::minor-increment
cg::resolution
cg::vertical-gauge
cg::vertical-gauge-test)
:cg))
;; Define the new dialog-item class. Define slots as needed to
;; hold any custom widget attributes or internal information.
(defclass vertical-gauge (lisp-widget)
;; The domain increment between major tic marks.
((major-increment :initarg :major-increment
:initform 10
:accessor major-increment)
;; The domain increment between minor tic marks
(minor-increment :initarg :minor-increment
:initform 5
:accessor minor-increment)
;; The value to round by after the user clicks or drags.
(resolution :initarg :resolution
:initform 1
:accessor resolution)
;; Internal slots below here
;; Cache the computed pixels-per-domain-unit here
(scale :initform 1)
;; The region of the widget to invalidate to force a redraw
;; of the bar but not the scale (for efficiency)
(bar-clip-box :initform (make-box 0 0 0 0))
;; A pixel value to which the bar currently extends, to use for
;; efficiently lengthening or shortening the bar during a drag.
(bar-top :initform nil)
;; Make every instance of this class use a standard margin and
;; color that could be overridden by a subclass. These could be
;; made into instance slots to allow individual widget variation.
(margin :allocation :class
:initform 10)
(bar-color :allocation :class
:initform blue)
;; Keep track of when we need to draw the focus rectangle.
(has-focus-p :initform nil)
)
(:default-initargs
;; Use the inherited range attribute that all dialog-items have
;; to specify the minimum and maximum values on the scale.
:range (list 0 100)))
;; Define the widget-window class to associate with the dialog item.
;; If your widget uses a hierarchy of windows, make them all
;; subclasses of lisp-widget-window, but make only the topmost window
;; be a subclass of lisp-widget-top-window. (Any subwindows could
;; be created in the device-open method for the topmost window.)
(defclass vertical-gauge-pane (lisp-widget-window lisp-widget-top-window)
())
;; Tell the dialog-item class which widget-window class to instantiate.
(defmethod widget-device ((widget vertical-gauge)(dialog basic-pane))
'vertical-gauge-pane)
;; ---------------------------------------------------------------------
;; Creating the widget-window instance
;; This method will be called when the lisp-widget-window stream
;; is opened (inside the call to open-dialog or add-widget).
(defmethod device-open ((widget-window vertical-gauge-pane) options)
(let* ((widget (window-dialog-item widget-window))
(border (getf options :border))
(range (getf options :range))
)
;; Point the dialog-item to the widget-window.
(setf (slot-value widget 'window) widget-window)
;; Set the initial value of the widget
(set-dialog-item-value widget
(or (getf options :value)
(first range)
0)
t) ;; Pass recursive-p to not draw the widget yet
;; Set the initial range of the widget
(when range
(set-dialog-item-range widget range
t)) ;; Pass recursive-p to not draw the widget yet
;; Create the actual window on the screen.
(open-lisp-widget-window widget-window options)
;; Force the widget to initially draw itself.
(invalidate-window widget-window)
;; Return the widget-window.
widget-window))
;; ---------------------------------------------------------------------
;; Updating the widget's value and range
;; This method will be called whenever the widget's value is changed
;; either interactively or programmatically, to invoke any needed
;; side effects.
(defmethod widget-set-value ((widget-window vertical-gauge-pane)
(widget vertical-gauge)
new-value old-value recursive-p)
;; Reject an invalid value.
(unless (numberp new-value)
#-runtime-system
(lisp-warning "~s is a bad vertical-gauge value. ~
It should be a number"
new-value)
(return-from widget-set-value nil))
(let* ((clip-box (slot-value widget 'bar-clip-box))
(range (dialog-item-range widget))
)
;; Disallow values outside the widget's range.
(unless (<= (first range)
new-value
(second range))
#-runtime-system
(lisp-warning "~a is outside the range (~a to ~a) of ~a"
new-value (first range)(second range)
(object-name-string widget))
(return-from widget-set-value nil))
;; Do nothing if the value is being restored after
;; an attempt to put in an invalid value
(unless (and (numberp old-value)
(<= (first range)
old-value
(second range)))
;; Return non-NIL to allow the old value to be restored
(return-from widget-set-value t))
;; We cache the bar-clip-box anytime we draw the widget, so
;; if this is not yet cached then there's no need for us
;; to redraw the widget to update the displayed value.
(when clip-box
;; Update the bar length to reflect the new-value.
;; Using the old value, find what section of the bar
;; needs to be drawn or erased, to avoid the flash
;; that would come by erasing and redrawing the whole bar.
(let* ((box (ncopy-box #.(make-box 0 0 0 0)
clip-box))
(new-pos (vertical-gauge-y-from-value
widget-window new-value))
(old-pos (vertical-gauge-y-from-value
widget-window old-value))
)
(setf (box-top box)(min new-pos old-pos))
(setf (box-bottom box)(max new-pos old-pos))
;; We pass the recursive-p flag internally when we
;; want to avoid redundant redrawing.
(unless recursive-p
;; Force only the changed part of the bar to redraw.
(invalidate-widget widget box))))
;; Return non-NIL to accept the new value
t))
;; This method will be called for side effects after the user
;; programmatically changes the range of the widget.
(defmethod widget-set-range ((widget-window vertical-gauge-pane)
(widget vertical-gauge)
new-value old-value recursive-p)
;; Reject an invalid range
(unless (and (consp new-value)
(numberp (first new-value))
(numberp (second new-value))
(> (second new-value)(first new-value)))
#-runtime-system
(lisp-warning "~s is a bad vertical-gauge range. ~
It should be a list of two numbers indicating minimum and maxmimum values."
new-value)
(return-from widget-set-range nil))
;; Force the current value to be within the new range
(unless (<= (first new-value)
(dialog-item-value widget)
(second new-value))
(set-dialog-item-value widget
(max (first new-value)
(min (dialog-item-value widget)
(second new-value)))
t)) ;; don't redisplay in case the new value is not in the old range
;; We use the recursive-p flag when we internally want to
;; change the range without redrawing.
(unless recursive-p
;; Force the whole widget to be redrawn to display the new
;; scale and to adjust the bar's position to that scale.
(invalidate-widget widget))
;; Return non-NIL to accept the new range
t)
;; ---------------------------------------------------------------------
;; Drawing the widget
;; This method will be called whenever part or all of the widget
;; needs to be redrawn (due to uncovering it or changing its value
;; or range).
(defmethod redisplay-window ((widget-window vertical-gauge-pane)
&optional box)
;; The default method for basic-pane will draw the blank background
(call-next-method)
;; Read parameters needed for drawing from the widget's slots
(let* ((widget (window-dialog-item widget-window))
(range (dialog-item-range widget))
(min-value (first range))
(max-value (second range))
(major-increment (major-increment widget))
(minor-increment (minor-increment widget))
(margin (slot-value widget 'margin))
(range-size (- max-value min-value))
(usable-size (i- (window-interior-height widget-window)
(i* 2 margin)))
(scale (/ usable-size range-size))
(labels nil)
(max-label-width 0)
(font (font widget-window))
(font-height (font-size font))
(half-font-height (iceiling font-height 2))
(right-margin (i- (window-interior-width widget-window)
margin))
(bottom-margin (i- (window-interior-height widget-window)
margin))
long-tic-x short-tic-x bar-x)
;; Cache this computed value away for use during click-dragging.
(setf (slot-value widget 'scale) scale)
;; Format all of the major tic labels ahead of time so that
;; we can see how wide the widest label is and reserve that
;; much of the widget width for the tic labels.
(do* ((value min-value (+ value major-increment))
label)
((> value max-value))
(setq label (format nil "~a" value))
(setq labels (nconc labels (list label)))
(setq max-label-width (max max-label-width
(stream-string-width
widget-window label))))
;; Divide the remaining width of the widget between the
;; bar width and the major tic length, and make the minor
;; tics be half the length of the major tics.
(setq long-tic-x (i+ margin max-label-width))
(setq bar-x (ifloor (i+ long-tic-x right-margin)
2))
(setq short-tic-x (ifloor (i+ long-tic-x bar-x) 2))
;; Avoid even trying to display the text and lines if the
;; clipping region that was passed in indicates that only
;; the bar needs to be redrawn, as when using the arrow
;; keys to change the value. This will speed up redraw
;; whenever the value but not the range has changed.
(when (< (box-left box) bar-x)
;; Draw each major tic mark and its label
(do* ((value min-value (+ value major-increment))
(labels labels (cdr labels))
y)
((null labels))
(setq y (i+ margin
(- usable-size
(round (* (- value min-value) scale)))))
;; Draw the label on the major tic mark
(draw-string-in-box widget-window (first labels)
0 (length (first labels))
(nmake-box #.(make-box 0 0 0 0)
margin (i- y half-font-height)
long-tic-x (i+ y half-font-height))
:right :center)
;; Draw the major tic mark itself
(draw-line widget-window
;; This #. technique is a handy way to cons a position
;; at compile time to reduce runtime consing, but you
;; must be certain that the position is not going to
;; be overwritten while its previous value is still
;; being used
(nmake-position #.(make-position 0 0)
long-tic-x y)
(nmake-position #.(make-position 0 0)
bar-x y))
;; Draw the minor tic marks between this major
;; tic mark and the next major tic mark.
(do* ((next-major-value (+ value major-increment))
(minor-value (+ value minor-increment)
(+ minor-value minor-increment))
minor-y)
((or (>= minor-value next-major-value)
(> minor-value max-value)))
(setq y (i+ margin
(- usable-size
(round (* (- minor-value min-value)
scale)))))
(draw-line widget-window
(nmake-position #.(make-position 0 0)
short-tic-x y)
(nmake-position #.(make-position 0 0)
bar-x y)))))
;; Draw the main bar that indicates the current widget value
(with-foreground-color (widget-window (slot-value widget 'bar-color))
(fill-box widget-window
(nmake-box #.(make-box 0 0 0 0)
bar-x
(max margin
(setf (slot-value widget 'bar-top)
(i+ margin
(- usable-size
(round (* (- (dialog-item-value widget)
min-value)
scale))))))
(i1+ right-margin)
(i1+ bottom-margin)
)))
;; Draw the focus rectangle near the outer edge of the widget
;; if the widget currently has the keyboard focus
(when (slot-value widget 'has-focus-p)
(vertical-gauge-draw-focus widget-window))
;; Cache the region occupied by the bar for efficient
;; lengthening and shortening of it during click-dragging
(setf (slot-value widget 'bar-clip-box)
(nmake-box (slot-value widget 'bar-clip-box)
bar-x margin
(i1+ right-margin)
(i1+ bottom-margin)))
))
;; Draw a rectangle to show when this widget has the keyboard focus.
(defun vertical-gauge-draw-focus (widget-window)
(let* ((box (nvisible-box widget-window
#.(make-box 0 0 0 0))))
;; You can always resort to calling a Windows API function
;; directly if you want. This call destructively shrinks
;; the box by 3 pixels in all four directions, to draw
;; a bit within the interior edge of the widget.
(win:InflateRect box -3 -3)
;; Use invert (xor) drawing mode to draw the focus rectangle,
;; so that it can be erased simply by drawing it again rather
;; than drawing the whole widget when the keyboard focus moves
(with-paint-operation (widget-window po-invert)
(draw-box widget-window box))))
;; ---------------------------------------------------------------------
;; Mouse clicking and dragging
;; Handle a left click to snap or drag the bar to a new position
(defmethod event ((widget-window vertical-gauge-pane)
(event (eql mouse-left-down))
buttons data time)
(let* ((widget (window-dialog-item widget-window))
(clip-box (slot-value widget 'bar-clip-box))
(bar-top (slot-value widget 'bar-top))
(left (box-left clip-box))
(top (box-top clip-box))
(right (box-right clip-box))
(bottom (box-bottom clip-box))
(previous-y nil)
y round-y)
;; Loop for each mouse-position during a drag
(loop
;; Find where the mouse cursor is within the bar's range.
;; If the user clicks or drags outside the range, constrain
;; the value to be within the bar's allowed range.
(setq y (min bottom
(max top
(position-y
(ncursor-position widget-window
#.(make-position 0 0))))))
;; To avoid consing, just loop idly if the user has not
;; moved the mouse since the previous time that we checked.
(unless (eq y previous-y)
(setq previous-y y)
;; Map the mouse pixel position to a domain value,
;; round it off by the resolution of the widget, and
;; map the rounded domain value back to a pixel value.
(setq round-y (vertical-gauge-round-y widget-window y))
;; Rather than erasing and redrawing the whole bar
;; (which would flash), draw up from the previous
;; bar value (or erase down from the previous value)
;; to draw only the changed section of the bar.
;; Draw nothing if the rounded value is the same as
;; the previous rounded value.
(cond ((< round-y top)) ;; rounded move is off the top of scale
((> round-y bar-top)
(erase-contents-box widget-window
(nmake-box #.(make-box 0 0 0 0)
left (max top bar-top) right round-y)))
((< round-y bar-top)
(with-foreground-color (widget-window
(slot-value widget 'bar-color))
(fill-box widget-window
(nmake-box #.(make-box 0 0 0 0)
left (max top round-y)
right bar-top)))))
(setq bar-top round-y))
;; Exit once the user has released the left mouse button
(unless (key-is-down-p left-mouse-button)
;; Recache the current position of the bar for next time
(setf (slot-value widget 'bar-top) round-y)
;; Store the new official value of the widget
(set-dialog-item-value widget
(vertical-gauge-value-from-y widget-window round-y)
;; Pass the recursive-p flag to tell ourselves not to
;; redraw the new value, since we've done that here
t)
(return))
))
t)
;; ---------------------------------------------------------------------
;; Utility computation functions
(defun vertical-gauge-value-from-y (widget-window y)
"Map from a domain value to a pixel value"
(let* ((widget (window-dialog-item widget-window))
(margin (slot-value widget 'margin))
(scale (slot-value widget 'scale))
(resolution (resolution widget))
(min-value (first (dialog-item-range widget)))
)
(+ (* resolution
(round (/ (i- (i- (window-interior-height widget-window) y)
margin)
scale)
resolution))
min-value)))
(defun vertical-gauge-y-from-value (widget-window value)
"Map from a pixel value to a domain value"
(let* ((widget (window-dialog-item widget-window))
(margin (slot-value widget 'margin))
(scale (slot-value widget 'scale))
(min-value (first (dialog-item-range widget)))
)
(i- (window-interior-height widget-window)
(i+ margin
(round (* (- value min-value)
scale))))))
(defun vertical-gauge-round-y (widget-window y)
"Temporarily convert a pixel-value to a domain value to round by the resolution"
(let* ((widget (window-dialog-item widget-window))
(margin (slot-value widget 'margin))
(scale (slot-value widget 'scale))
(window-height (window-interior-height widget-window))
(resolution (resolution widget))
)
(i- window-height
(i+ margin
(round (* resolution
(round (/ (i- (i- window-height y)
margin)
scale)
resolution)
scale))))))
;; ---------------------------------------------------------------------
;; Handle keypresses
(defmethod event ((widget-window vertical-gauge-pane)
(event (eql virtual-key-down))
buttons (data (eql pc:vk-down)) time)
;; Make the DOWN arrow key move the value down by
;; the resolution amount, or by the major-increment amount
;; if the control key is held down
(let* ((widget (window-dialog-item widget-window)))
(decf (dialog-item-value widget)
(if (logtest control-key buttons)
(major-increment widget)
(resolution widget)))))
(defmethod event ((widget-window vertical-gauge-pane)
(event (eql virtual-key-down))
buttons (data (eql pc:vk-up)) time)
;; Make the UP arrow key move the value up by
;; the resolution amount, or by the major-increment amount
;; if the control key is held down
(let* ((widget (window-dialog-item widget-window)))
(incf (dialog-item-value widget)
(if (logtest control-key buttons)
(major-increment widget)
(resolution widget)))))
;; ---------------------------------------------------------------------
;; Miscellaneous methods
(defmethod resize-window :after ((window vertical-gauge-pane) position)
;; Redraw the widget at its new dimensions after resizing the widget
(invalidate-window window))
(defmethod lisp-widget-draw-focus ((widget-window vertical-gauge-pane)
(widget vertical-gauge))
;; A standard approach to maintain the focus rectangle
;; only when the widget has the keyboard focus
(unless (slot-value widget 'has-focus-p)
(setf (slot-value widget 'has-focus-p) t)
(vertical-gauge-draw-focus widget-window))
t)
(defmethod lisp-widget-clear-focus ((widget-window vertical-gauge-pane)
(widget vertical-gauge))
;; A standard approach to maintain the focus rectangle
;; only when the widget has the keyboard focus
(when (slot-value widget 'has-focus-p)
(vertical-gauge-draw-focus widget-window)
(setf (slot-value widget 'has-focus-p) nil))
t)
(defmethod event ((widget-window vertical-gauge-pane)
(event (eql virtual-key-down))
buttons (data (eql pc:vk-tab)) time)
;; Make TAB move the keyboard focus to the next widget
(if (logtest alt-key buttons)
(call-next-method) ;; Let alt-tab do the usual thing
(tab-to-next-widget (window-dialog-item widget-window) nil)))
(defmethod event ((widget-window vertical-gauge-pane)
(event (eql virtual-key-down))
buttons (data (eql pc:vk-backtab)) time)
;; Make SHIFT-TAB move the keyboard focus to the previous widget
(if (logtest alt-key buttons)
(call-next-method) ;; Let alt-tab do the usual thing
(tab-to-next-widget (window-dialog-item widget-window) t)))
(defmethod pc:window-procedure ((drawing-pane vertical-gauge-pane)
(msg (eql win:wm_getdlgcode))
wparam lparam)
;; This method must be defined if we want to handle arrow keys
;; within this widget, since otherwise the OS will intercept them
;; to move the keyboard focus to another widget.
(return-value-to-windows win:dlgc_wantallkeys))
;; ---------------------------------------------------------------------
;; A tester function
;; Create a sample vertical-gauge "application" in a dialog
(defun vertical-gauge-test ()
(let* ((dialog
(open-dialog (list (make-dialog-item
:widget 'vertical-gauge
:box (make-box 10 10 90 150)
:name :gauge
:value 350
:range '(0 500)
:major-increment 100
:minor-increment 50
:resolution 25
:set-value-fn
'(lambda (widget new-value old-value)
(lisp-message "Now ~a" new-value)
t) ; accept the new value cac/kc 5oct96
:font (make-font-ex nil :arial 11)
:right-attachment :right
:bottom-attachment :bottom
)
;; Use a single-item-list to change the range
;; of the gauge above
(make-dialog-item
:widget 'single-item-list
:box (make-box 110 35 190 150)
:name :max
:value 500
:range (list 250 500 750 1000)
:set-value-fn
'(lambda (widget new-value old-value)
(setf (dialog-item-range
(sibling :gauge widget))
(list 0 new-value)))
:left-attachment :right
:right-attachment :right
:bottom-attachment :bottom)
(make-dialog-item
:widget 'static-text
:box (make-box 110 10 190 34)
:name :max-label
:value "Maximum"
:left-attachment :right
:right-attachment :right)
)
'dialog *lisp-main-window*
:pop-up-p nil
:title "Vertical Gauge"
:user-resizable t
:window-interior (make-box 100 100 300 260))))
(set-focus-widget (widget :gauge dialog))
dialog))
;; This runs the test
;; (vertical-gauge-test))
|