[graphic-forms-cvs] r186 - in trunk: docs/manual src src/demos/textedit src/demos/unblocked src/tests/uitoolkit src/uitoolkit/system src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Sun Jul 9 06:35:40 UTC 2006
Author: junrue
Date: Sun Jul 9 02:35:37 2006
New Revision: 186
Modified:
trunk/docs/manual/api.texinfo
trunk/docs/manual/reference.texinfo
trunk/src/demos/textedit/textedit-window.lisp
trunk/src/demos/unblocked/double-buffered-event-dispatcher.lisp
trunk/src/demos/unblocked/tiles-panel.lisp
trunk/src/demos/unblocked/unblocked-window.lisp
trunk/src/packages.lisp
trunk/src/tests/uitoolkit/drawing-tester.lisp
trunk/src/tests/uitoolkit/event-tester.lisp
trunk/src/tests/uitoolkit/hello-world.lisp
trunk/src/tests/uitoolkit/image-tester.lisp
trunk/src/tests/uitoolkit/layout-tester.lisp
trunk/src/tests/uitoolkit/windlg.lisp
trunk/src/uitoolkit/system/system-constants.lisp
trunk/src/uitoolkit/widgets/event-generics.lisp
trunk/src/uitoolkit/widgets/event-source.lisp
trunk/src/uitoolkit/widgets/event.lisp
trunk/src/uitoolkit/widgets/widget.lisp
trunk/src/uitoolkit/widgets/window.lisp
Log:
refactored event-*** functions by removing time argument - call OBTAIN-EVENT-TIME instead now; added type argument to event-activate; significantly enhanced documentation of event functions
Modified: trunk/docs/manual/api.texinfo
==============================================================================
--- trunk/docs/manual/api.texinfo (original)
+++ trunk/docs/manual/api.texinfo Sun Jul 9 02:35:37 2006
@@ -834,112 +834,297 @@
@node event functions
@section event functions
+This chapter documents two types of functions:
+ at itemize @bullet
+ at item generic functions implemented in order to handle system events
+ at item functions provided to help implement application message pumps
+ at end itemize
+
@anchor{default-message-filter}
- at deffn Function default-message-filter gm-code msg-ptr
+ at defun default-message-filter gm-code msg-ptr
Processes messages for all @ref{window}s, non-modal @ref{dialog}s, and
@ref{control}s. Accelerator keys are also translated by this
function. Returns @sc{nil} so that @ref{message-loop} will continue,
-unless @code{gm-code} is less than or equal to zero, in which case
+unless @var{gm-code} is less than or equal to zero, in which case
@sc{t} is returned so that @ref{message-loop} will exit. When
- at code{gm-code} is zero, @code{msg-ptr} identifies a @sc{WM_QUIT}
-message indicating normal shutdown. If @code{gm-code} is -1, then the
-system has reported an error during message retrieval which should be
-handled by (hopefully) graceful shutdown.
- at end deffn
+ at var{gm-code} is zero, @var{msg-ptr} identifies a @sc{WM_QUIT}
+message indicating normal shutdown. If @var{gm-code} is -1, then the
+system has reported an error during message retrieval; in this
+situation, the application should attempt a graceful shutdown.
+ at table @var
+ at item gm-code
+The code returned by the @code{GetMessage} Win32 @sc{api} call.
+ at item msg-ptr
+A pointer to a Win32 @sc{api} @code{MSG} data structure, filled in
+by @code{GetMessage} and containing raw event data to be
+translated and dispatched.
+ at end table
+ at end defun
- at deffn GenericFunction event-activate dispatcher widget time
-Implement this to respond to an object being activated.
+ at deffn GenericFunction event-activate dispatcher widget type
+Implement this method to respond to @var{widget} being activated. For
+a @ref{top-level} @ref{window} or @ref{dialog}, this means that
+ at var{widget} was brought to the foreground and its trim (titlebar and
+border) was highlighted to indicate that it is now the active
+window. For a @ref{menu}, it means that the user has clicked on the
+ at ref{item} invoking @ref{widget} and it is about to be shown; this is
+an opportunity to update the menu's contents.
+ at table @var
+ at event-dispatcher-arg
+ at item widget
+The menu, dialog, or window that has been activated.
+ at item type
+Provides a hint as to how activation occurred, via one of the following
+keywords:
+ at table @code
+ at item :click
+Indicates that @var{widget} was activated as the result of a mouse click.
+ at item :programmatic
+Indicates that @var{widget} was activated as the result of the keyboard
+interface to select a window, or programmatically via a call to
+ at sc{activate}.
+ at end table
+ at end table
@end deffn
- at deffn GenericFunction event-arm dispatcher item time
-Implement this to respond to an object about to be selected.
+ at deffn GenericFunction event-arm dispatcher item
+Implement this method to respond to the prior notice of @var{item}
+being selected. Of course, an arm event is not necessarily always
+followed by a selection, such as if the user moves the mouse across
+items on a @ref{menu}.
+ at table @var
+ at event-dispatcher-arg
+ at item item
+The @ref{item} about to be selected.
+ at end table
@end deffn
- at deffn GenericFunction event-close dispatcher widget time
-Implement this to respond to an object being closed.
+ at deffn GenericFunction event-close dispatcher widget
+Implement this method to respond to @var{widget} being closed by the user.
+Only @ref{dialog}s and @ref{top-level} @ref{window}s receive close
+events.
+ at table @var
+ at event-dispatcher-arg
+ at item widget
+The dialog or window being closed.
+ at end table
@end deffn
- at deffn GenericFunction event-dispose dispatcher widget time
-Implement this to respond to an object being disposed (via
- at ref{dispose}, not the garbage collector).
+ at deffn GenericFunction event-dispose dispatcher widget
+Implement this method to respond to @var{widget} being disposed (explicitly
+via @ref{dispose}, not collected via the garbage collector). This
+event function is called while the contents of @var{widget} are still
+valid.
+ at table @var
+ at event-dispatcher-arg
+ at item widget
+The @ref{widget} being disposed.
+ at end table
@end deffn
@anchor{event-focus-gain}
- at deffn GenericFunction event-focus-gain dispatcher widget time
-Implement this to respond to an object gaining keyboard focus.
+ at deffn GenericFunction event-focus-gain dispatcher widget
+Implement this method to respond to @var{widget} gaining keyboard focus.
+ at table @var
+ at event-dispatcher-arg
+ at item widget
+The @ref{widget} gaining keyboard focus.
+ at end table
@end deffn
@anchor{event-focus-loss}
- at deffn GenericFunction event-focus-loss dispatcher widget time
-Implement this to respond to an object losing keyboard focus.
+ at deffn GenericFunction event-focus-loss dispatcher widget
+Implement this method to respond to @var{widget} losing keyboard focus.
+ at table @var
+ at event-dispatcher-arg
+ at item widget
+The @ref{widget} losing keyboard focus.
+ at end table
@end deffn
- at deffn GenericFunction event-key-down dispatcher widget time keycode char
-Implement this to respond to a key down event.
+ at deffn GenericFunction event-key-down dispatcher widget keycode char
+Implement this method to respond to a key being pressed within
+ at var{widget}.
+ at table @var
+ at event-dispatcher-arg
+ at item widget
+The @ref{widget} in which the key was pressed.
+ at item keycode
+The virtual key code of the key that was pressed.
+ at item char
+The character value resulting from translation of the virtual key code,
+or @sc{nil} if the key code cannot be translated.
+ at end table
@end deffn
- at deffn GenericFunction event-key-up dispatcher widget time keycode char
-Implement this to respond to a key up event.
+ at deffn GenericFunction event-key-up dispatcher widget keycode char
+Implement this method to respond to a key being released within @var{widget}.
+ at table @var
+ at event-dispatcher-arg
+ at item widget
+The @ref{widget} in which the key was released.
+ at item keycode
+The virtual key code of the key that was released.
+ at item char
+The character value resulting from translation of the virtual key code,
+or @sc{nil} if the key code cannot be translated.
+ at end table
@end deffn
@anchor{event-modify}
- at deffn GenericFunction event-modify dispatcher widget time
-Implement this to respond to changes within a @ref{widget}, for example
-when the user types text inside an @ref{edit} control.
+ at deffn GenericFunction event-modify dispatcher widget
+Implement this method to respond to changes due to user input within
+ at ref{widget}, for example when the user types text inside an
+ at ref{edit} @ref{control}.
+ at table @var
+ at event-dispatcher-arg
+ at item widget
+The @ref{widget} that was modified by the user.
+ at end table
@end deffn
- at deffn GenericFunction event-mouse-double dispatcher widget time point button
-Implement this to respond to a mouse double-click.
+ at deffn GenericFunction event-mouse-double dispatcher widget point button
+Implement this method to respond to a mouse button double-click within @var{widget}.
+ at table @var
+ at event-dispatcher-arg
+ at item widget
+The @ref{widget} inside of which the mouse was double-clicked.
+ at event-mouse-point-arg
+ at event-mouse-button-arg
+ at end table
@end deffn
- at deffn GenericFunction event-mouse-down dispatcher widget time point button
-Implement this to respond to a mouse down event.
+ at deffn GenericFunction event-mouse-down dispatcher widget point button
+Implement this method to respond to a mouse button click within @var{widget}.
+ at table @var
+ at event-dispatcher-arg
+ at item widget
+The @ref{widget} inside of which the mouse was clicked.
+ at event-mouse-point-arg
+ at event-mouse-button-arg
+ at end table
@end deffn
- at deffn GenericFunction event-mouse-move dispatcher widget time point button
-Implement this to respond to a mouse move event.
+ at deffn GenericFunction event-mouse-move dispatcher widget point button
+Implement this method to respond to a mouse move event within @var{widget}.
+ at table @var
+ at event-dispatcher-arg
+ at item widget
+The @ref{widget} inside of which the mouse was moved.
+ at event-mouse-point-arg
+ at event-mouse-button-arg
+ at end table
@end deffn
- at deffn GenericFunction event-mouse-up dispatcher widget time point button
-Implement this to respond to a mouse up event.
+ at deffn GenericFunction event-mouse-up dispatcher widget point button
+Implement this method to respond to a mouse button being released within
+ at var{widget}.
+ at table @var
+ at event-dispatcher-arg
+ at item widget
+The @ref{widget} inside of which the mouse button was released.
+ at event-mouse-point-arg
+ at event-mouse-button-arg
+ at end table
@end deffn
- at deffn GenericFunction event-move dispatcher widget time point
-Implement this to respond to an object being moved within its parent's
-coordinate system.
+ at deffn GenericFunction event-move dispatcher widget point
+Implement this method to respond to @var{widget} being moved within its
+ at ref{parent}'s coordinate system.
+ at table @var
+ at event-dispatcher-arg
+ at item widget
+The @ref{widget} being moved.
+ at item point
+The destination @ref{point} to which @var{widget} was moved.
+ at end table
@end deffn
@anchor{event-paint}
- at deffn GenericFunction event-paint dispatcher widget time gc rect
-Implement this to respond to paint requests.
+ at deffn GenericFunction event-paint dispatcher widget gc rect
+Implement this method to respond to system requests to repaint @var{widget}.
+ at table @var
+ at event-dispatcher-arg
+ at item widget
+The @ref{widget} whose contents need to be repainted.
+ at item gc
+A @ref{graphics-context} initialized for use during this paint event and
+which will be @ref{dispose}d after this method returns.
+ at item rect
+The specific @ref{rectangle} within @var{widget} needing to be repainted.
+ at end table
@end deffn
- at deffn GenericFunction event-resize dispatcher widget time size type
-Implement this to respond to an object being resized.
+ at deffn GenericFunction event-resize dispatcher widget size type
+Implement this method to respond to @var{widget} being resized.
+ at table @var
+ at event-dispatcher-arg
+ at item widget
+The @ref{widget} whose dimensions are being changed.
+ at item size
+A @ref{size} object describing @var{widget}'s new dimensions.
+ at item type
+Identifies three different kinds of resizing actions:
+ at table @code
+ at item :maximized
+Indicates that @var{widget} was expanded to its maximum size, such as
+when the user clicks on the maximize button in a @ref{window} frame.
+ at item :minimized
+Indicates that @var{widget} was minimized to the taskbar.
+ at item :restored
+Indicates that @var{widget} was either restored from a minimized
+state, or that resizing occurred while @var{widget} was already
+in a visible, non-maximized state.
+ at end table
+ at end table
@end deffn
@anchor{event-select}
- at deffn GenericFunction event-select dispatcher item time rect
-Implement this to respond to an object (or item within) being selected.
+ at deffn GenericFunction event-select dispatcher widget rect
+Implement this method to handle notification that @var{widget} (or some
+ at ref{item} within @var{widget}) has been clicked on by the user in order
+to invoke some action.
+ at table @var
+ at event-dispatcher-arg
+ at item widget
+The @ref{widget} (or item) that was selected.
+ at item rect
+The @ref{rectangle} bounding @var{widget}.
+ at end table
@end deffn
@anchor{event-timer}
- at deffn GenericFunction event-timer dispatcher timer time
-Implement this to respond to a tick from a specific timer.
+ at deffn GenericFunction event-timer dispatcher timer
+Implement this method to respond to expiration of the current
+delay configured for @var{timer}.
+ at table @var
+ at event-dispatcher-arg
+ at item timer
+The @ref{timer} that generated this event.
+ at end table
@end deffn
@anchor{message-loop}
- at deffn Function message-loop msg-filter
+ at defun message-loop msg-filter
This function retrieves messages from the system with the intent of
-passing each one to the function specified by @code{msg-filter} so
+passing each one to the function specified by @var{msg-filter} so
that it may be translated and dispatched. The return value of the
- at code{msg-filter} function determines whether @code{message-loop}
-continues or returns, and this termination condition depends on the
-context of the message loop being executed. The return value is
- at sc{nil} if @code{message-loop} should continue, or not @sc{nil} if
-the loop should exit. The pre-defined implementation
- at ref{default-message-filter} is provided.
- at end deffn
+ at var{msg-filter} function determines whether @code{message-loop}
+continues or returns. The return value must be @sc{nil} if
+ at code{message-loop} should continue, or not @sc{nil} if the
+loop should exit.
+ at table @var
+ at item msg-filter
+A @sc{function} object; see @ref{default-message-filter} for more
+details.
+ at end table
+ at end defun
+
+ at anchor{obtain-event-time}
+ at defun obtain-event-time => milliseconds
+Returns the timestamp for the event currently being processed, or
+zero if called prior to the delivery of any events.
+ at end defun
@node widget functions
Modified: trunk/docs/manual/reference.texinfo
==============================================================================
--- trunk/docs/manual/reference.texinfo (original)
+++ trunk/docs/manual/reference.texinfo Sun Jul 9 02:35:37 2006
@@ -75,6 +75,31 @@
@end quotation
@end macro
+ at macro event-dispatcher-arg
+ at item dispatcher
+The @ref{event-dispatcher} to process this event.
+ at end macro
+
+ at macro event-mouse-button-arg
+ at item button
+A keyword identifying which mouse button was used:
+ at table @code
+ at item :left-button
+ at item :middle-button
+ at item :right-button
+ at end table
+ at end macro
+
+ at macro event-mouse-point-arg
+ at item point
+The @ref{point} location of the mouse cursor.
+ at end macro
+
+ at macro event-time-arg
+ at item time
+This event's timestamp in milliseconds.
+ at end macro
+
@c Info "requires" that x-refs end in a period or comma, or ) in the
@c case of @pxref. So the following implements that requirement for
@c the "See also" subheadings that permeate this manual, but only in
Modified: trunk/src/demos/textedit/textedit-window.lisp
==============================================================================
--- trunk/src/demos/textedit/textedit-window.lisp (original)
+++ trunk/src/demos/textedit/textedit-window.lisp Sun Jul 9 02:35:37 2006
@@ -40,19 +40,19 @@
(defvar *textedit-file-filters* '(("Text Files (*.txt)" . "*.txt")
("All Files (*.*)" . "*.*")))
-(defun manage-textedit-file-menu (disp menu time)
- (declare (ignore disp time))
+(defun manage-textedit-file-menu (disp menu type)
+ (declare (ignore disp type))
(gfw:enable (elt (gfw:items menu) 2) (gfw:text-modified-p *textedit-control*)))
-(defun textedit-file-new (disp item time rect)
- (declare (ignore disp item time rect))
+(defun textedit-file-new (disp item rect)
+ (declare (ignore disp item rect))
(when *textedit-control*
(setf (gfw:text *textedit-control*) "")
(setf (gfw:text-modified-p *textedit-control*) nil)
(setf (file-path *textedit-model*) nil)))
-(defun textedit-file-open (disp item time rect)
- (declare (ignore disp item time rect))
+(defun textedit-file-open (disp item rect)
+ (declare (ignore disp item rect))
(gfw:with-file-dialog (*textedit-win*
'(:open :add-to-recent :path-must-exist)
paths
@@ -61,14 +61,14 @@
(load-textedit-doc (first paths))
(setf (file-path *textedit-model*) (namestring (first paths))))))
-(defun textedit-file-save (disp item time rect)
+(defun textedit-file-save (disp item rect)
(if (file-path *textedit-model*)
(save-textedit-doc (file-path *textedit-model*) (gfw:text *textedit-control*))
- (textedit-file-save-as disp item time rect))
+ (textedit-file-save-as disp item rect))
(setf (gfw:text-modified-p *textedit-control*) nil))
-(defun textedit-file-save-as (disp item time rect)
- (declare (ignore disp item time rect))
+(defun textedit-file-save-as (disp item rect)
+ (declare (ignore disp item rect))
(gfw:with-file-dialog (*textedit-win*
'(:save :add-to-recent)
paths
@@ -79,15 +79,15 @@
(setf (file-path *textedit-model*) (namestring (first paths)))
(setf (gfw:text-modified-p *textedit-control*) nil))))
-(defun textedit-file-quit (disp item time rect)
- (declare (ignore disp item time rect))
+(defun textedit-file-quit (disp item rect)
+ (declare (ignore disp item rect))
(setf *textedit-control* nil)
(gfs:dispose *textedit-win*)
(setf *textedit-win* nil)
(gfw:shutdown 0))
-(defun textedit-font (disp item time rect)
- (declare (ignore disp item time rect))
+(defun textedit-font (disp item rect)
+ (declare (ignore disp item rect))
(gfw:with-graphics-context (gc *textedit-control*)
(gfw:with-font-dialog (*textedit-win* '(:no-effects) font color :gc gc :initial-font (gfg:font *textedit-control*))
(if font
@@ -95,24 +95,23 @@
(defclass textedit-win-events (gfw:event-dispatcher) ())
-(defmethod gfw:event-close ((disp textedit-win-events) window time)
- (declare (ignore window time))
- (textedit-file-quit disp nil nil nil))
+(defmethod gfw:event-close ((disp textedit-win-events) window)
+ (declare (ignore window))
+ (textedit-file-quit disp nil nil))
-(defmethod gfw:event-focus-gain ((self textedit-win-events) window time)
- (declare (ignore window time))
+(defmethod gfw:event-focus-gain ((self textedit-win-events) window)
+ (declare (ignore window))
(if *textedit-control*
(gfw:give-focus *textedit-control*)))
(defclass textedit-about-dialog-events (gfw:event-dispatcher) ())
-(defmethod gfw:event-close ((disp textedit-about-dialog-events) (dlg gfw:dialog) time)
- (declare (ignore time))
+(defmethod gfw:event-close ((disp textedit-about-dialog-events) (dlg gfw:dialog))
(call-next-method)
(gfs:dispose dlg))
-(defun about-textedit (disp item time rect)
- (declare (ignore disp item time rect))
+(defun about-textedit (disp item rect)
+ (declare (ignore disp item rect))
(let* ((image (make-instance 'gfg:image :file (merge-pathnames "src/demos/textedit/about.bmp" *textedit-startup-dir*)))
(dlg (make-instance 'gfw:dialog :owner *textedit-win*
:dispatcher (make-instance 'textedit-about-dialog-events)
@@ -153,8 +152,8 @@
:spacing 0
:style '(:vertical :normalize))))
(close-btn (make-instance 'gfw:button
- :callback (lambda (disp btn time rect)
- (declare (ignore disp btn time rect))
+ :callback (lambda (disp btn rect)
+ (declare (ignore disp btn rect))
(gfs:dispose dlg))
:style '(:cancel-button)
:text "Close"
Modified: trunk/src/demos/unblocked/double-buffered-event-dispatcher.lisp
==============================================================================
--- trunk/src/demos/unblocked/double-buffered-event-dispatcher.lisp (original)
+++ trunk/src/demos/unblocked/double-buffered-event-dispatcher.lisp Sun Jul 9 02:35:37 2006
@@ -60,6 +60,6 @@
(defmethod initialize-instance :after ((self double-buffered-event-dispatcher) &key buffer-size)
(setf (image-buffer-of self) (make-instance 'gfg:image :size buffer-size)))
-(defmethod gfw:event-paint ((self double-buffered-event-dispatcher) window time gc rect)
- (declare (ignore window time rect))
+(defmethod gfw:event-paint ((self double-buffered-event-dispatcher) window gc rect)
+ (declare (ignore window rect))
(gfg:draw-image gc (image-buffer-of self) (gfs:make-point)))
Modified: trunk/src/demos/unblocked/tiles-panel.lisp
==============================================================================
--- trunk/src/demos/unblocked/tiles-panel.lisp (original)
+++ trunk/src/demos/unblocked/tiles-panel.lisp Sun Jul 9 02:35:37 2006
@@ -94,8 +94,7 @@
(setf (gethash kind table) image)
(incf kind)))))
-(defmethod gfw:event-mouse-down ((self tiles-panel-events) panel time point button)
- (declare (ignore time))
+(defmethod gfw:event-mouse-down ((self tiles-panel-events) panel point button)
(let* ((tiles (game-tiles))
(tile-pnt (window->tiles point))
(tile-kind (obtain-tile tiles tile-pnt))
@@ -114,8 +113,7 @@
(setf (shape-pnts-of self) (shape-tile-points tmp-table))
(draw-tiles-directly panel (shape-pnts-of self) +max-tile-kinds+))))
-(defmethod gfw:event-mouse-up ((self tiles-panel-events) panel time point button)
- (declare (ignore time))
+(defmethod gfw:event-mouse-up ((self tiles-panel-events) panel point button)
(gfw:release-mouse)
(let ((tile-pnt (window->tiles point))
(shape-pnts (shape-pnts-of self)))
Modified: trunk/src/demos/unblocked/unblocked-window.lisp
==============================================================================
--- trunk/src/demos/unblocked/unblocked-window.lisp (original)
+++ trunk/src/demos/unblocked/unblocked-window.lisp Sun Jul 9 02:35:37 2006
@@ -52,14 +52,14 @@
(defun get-scoreboard-panel ()
*scoreboard-panel*)
-(defun new-unblocked (disp item time rect)
- (declare (ignore disp item time rect))
+(defun new-unblocked (disp item rect)
+ (declare (ignore disp item rect))
(new-game)
(update-panel *scoreboard-panel*)
(update-panel *tiles-panel*))
-(defun restart-unblocked (disp item time rect)
- (declare (ignore disp item time rect))
+(defun restart-unblocked (disp item rect)
+ (declare (ignore disp item rect))
(restart-game)
(update-panel *scoreboard-panel*)
(update-panel *tiles-panel*))
@@ -69,8 +69,8 @@
(kind (shape-kind shape)))
(and (> size 1) (/= kind 0) (/= kind +max-tile-kinds+))))
-(defun reveal-unblocked (disp item time rect)
- (declare (ignore disp item time rect))
+(defun reveal-unblocked (disp item rect)
+ (declare (ignore disp item rect))
(let ((shape (find-shape (game-tiles) #'accept-shape-p)))
(when shape
(let ((shape-pnts (shape-tile-points shape))
@@ -80,8 +80,8 @@
(draw-tiles-directly *tiles-panel* shape-pnts +max-tile-kinds+)
(gfw:enable timer t)))))
-(defun quit-unblocked (disp item time rect)
- (declare (ignore disp item time rect))
+(defun quit-unblocked (disp item rect)
+ (declare (ignore disp item rect))
(setf *scoreboard-panel* nil)
(setf *tiles-panel* nil)
(gfs:dispose *unblocked-win*)
@@ -90,23 +90,22 @@
(defclass unblocked-win-events (gfw:event-dispatcher) ())
-(defmethod gfw:event-close ((disp unblocked-win-events) window time)
- (declare (ignore window time))
- (quit-unblocked disp nil nil nil))
+(defmethod gfw:event-close ((disp unblocked-win-events) window)
+ (declare (ignore window))
+ (quit-unblocked disp nil nil))
-(defmethod gfw:event-timer ((disp unblocked-win-events) timer time)
- (declare (ignore timer time))
+(defmethod gfw:event-timer ((disp unblocked-win-events) timer)
+ (declare (ignore timer))
(update-panel *tiles-panel*))
(defclass unblocked-about-dialog-events (gfw:event-dispatcher) ())
-(defmethod gfw:event-close ((disp unblocked-about-dialog-events) (dlg gfw:dialog) time)
- (declare (ignore time))
+(defmethod gfw:event-close ((disp unblocked-about-dialog-events) (dlg gfw:dialog))
(call-next-method)
(gfs:dispose dlg))
-(defun about-unblocked (disp item time rect)
- (declare (ignore disp item time rect))
+(defun about-unblocked (disp item rect)
+ (declare (ignore disp item rect))
(let* ((image (make-instance 'gfg:image :file (merge-pathnames "src/demos/unblocked/about.bmp" *unblocked-startup-dir*)))
(dlg (make-instance 'gfw:dialog :owner *unblocked-win*
:dispatcher (make-instance 'unblocked-about-dialog-events)
@@ -147,8 +146,8 @@
:spacing 0
:style '(:vertical :normalize))))
(close-btn (make-instance 'gfw:button
- :callback (lambda (disp btn time rect)
- (declare (ignore disp btn time rect))
+ :callback (lambda (disp btn rect)
+ (declare (ignore disp btn rect))
(gfs:dispose dlg))
:style '(:cancel-button)
:text "Close"
@@ -204,7 +203,7 @@
(setf (gfw:minimum-size *unblocked-win*) size)
(setf (gfw:maximum-size *unblocked-win*) size))
- (new-unblocked nil nil nil nil)
+ (new-unblocked nil nil nil)
(gfw:show *unblocked-win* t)))
(defun unblocked ()
Modified: trunk/src/packages.lisp
==============================================================================
--- trunk/src/packages.lisp (original)
+++ trunk/src/packages.lisp Sun Jul 9 02:35:37 2006
@@ -441,6 +441,7 @@
#:moveable-p
#:object-to-display
#:obtain-displays
+ #:obtain-event-time
#:obtain-primary-display
#:owner
#:pack
Modified: trunk/src/tests/uitoolkit/drawing-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/drawing-tester.lisp (original)
+++ trunk/src/tests/uitoolkit/drawing-tester.lisp Sun Jul 9 02:35:37 2006
@@ -42,16 +42,16 @@
(gfw:check *last-checked-drawing-item* nil))
(gfw:check item t))
-(defun find-checked-item (disp menu time)
- (declare (ignore disp time))
+(defun find-checked-item (disp menu type)
+ (declare (ignore disp type))
(dotimes (i (length (gfw:items menu)))
(let ((item (elt (gfw:items menu) i)))
(when (gfw:checked-p item)
(setf *last-checked-drawing-item* item)
(return)))))
-(defun drawing-exit-fn (disp item time rect)
- (declare (ignore disp item time rect))
+(defun drawing-exit-fn (disp item rect)
+ (declare (ignore disp item rect))
(gfs:dispose *drawing-win*)
(setf *drawing-win* nil)
(gfw:shutdown 0))
@@ -61,12 +61,12 @@
:accessor draw-func-of
:initform nil)))
-(defmethod gfw:event-close ((self drawing-win-events) window time)
- (declare (ignore window time))
- (drawing-exit-fn self nil nil 0))
+(defmethod gfw:event-close ((self drawing-win-events) window)
+ (declare (ignore window))
+ (drawing-exit-fn self nil nil))
-(defmethod gfw:event-paint ((self drawing-win-events) window time gc rect)
- (declare (ignore time rect))
+(defmethod gfw:event-paint ((self drawing-win-events) window gc rect)
+ (declare (ignore rect))
(setf (gfg:background-color gc) gfg:*color-white*)
(setf (gfg:foreground-color gc) gfg:*color-white*)
(gfg:draw-filled-rectangle gc (gfs:make-rectangle :size (gfw:client-size window)))
@@ -162,8 +162,8 @@
(setf rect (gfs:make-rectangle :location (clone-point rect-pnt) :size rect-size))
(draw-rect-start-end gc rect (clone-point start-pnt) (clone-point end-pnt) delta-x #'gfg:draw-arc nil)))
-(defun select-arcs (disp item time rect)
- (declare (ignore disp time rect))
+(defun select-arcs (disp item rect)
+ (declare (ignore disp rect))
(update-drawing-item-check item)
(setf (draw-func-of *drawing-dispatcher*) #'draw-arcs)
(gfw:redraw *drawing-win*))
@@ -185,8 +185,8 @@
(setf (gfg:pen-style gc) '(:dot :square-endcap))
(gfg:draw-poly-bezier gc (gfs:make-point :x 10 :y 110) poly-pnts))))
-(defun select-beziers (disp item time rect)
- (declare (ignore disp time rect))
+(defun select-beziers (disp item rect)
+ (declare (ignore disp rect))
(update-drawing-item-check item)
(setf (draw-func-of *drawing-dispatcher*) #'draw-beziers)
(gfw:redraw *drawing-win*))
@@ -202,8 +202,8 @@
(setf rect (gfs:make-rectangle :location (clone-point rect-pnt) :size rect-size))
(draw-rectangular gc rect nil delta-x #'gfg:draw-ellipse nil)))
-(defun select-ellipses (disp item time rect)
- (declare (ignore disp time rect))
+(defun select-ellipses (disp item rect)
+ (declare (ignore disp rect))
(update-drawing-item-check item)
(setf (draw-func-of *drawing-dispatcher*) #'draw-ellipses)
(gfw:redraw *drawing-win*))
@@ -240,8 +240,8 @@
#'gfg:draw-line
nil)))
-(defun select-lines (disp item time rect)
- (declare (ignore disp time rect))
+(defun select-lines (disp item rect)
+ (declare (ignore disp rect))
(update-drawing-item-check item)
(setf (draw-func-of *drawing-dispatcher*) #'draw-lines)
(gfw:redraw *drawing-win*))
@@ -264,8 +264,8 @@
(setf rect (gfs:make-rectangle :location (clone-point rect-pnt) :size rect-size))
(draw-rectangular gc rect nil delta-x #'gfg:draw-rectangle nil)))
-(defun select-rects (disp item time rect)
- (declare (ignore disp time rect))
+(defun select-rects (disp item rect)
+ (declare (ignore disp rect))
(update-drawing-item-check item)
(setf (draw-func-of *drawing-dispatcher*) #'draw-rects)
(gfw:redraw *drawing-win*))
@@ -314,8 +314,8 @@
(setf (gfg:foreground-color gc) gfg:*color-red*)
(draw-a-string gc pnt "text" "Arial" 12 nil '(:transparent))))
-(defun select-text (disp item time rect)
- (declare (ignore disp time rect))
+(defun select-text (disp item rect)
+ (declare (ignore disp rect))
(update-drawing-item-check item)
(setf (draw-func-of *drawing-dispatcher*) #'draw-strings)
(gfw:redraw *drawing-win*))
@@ -336,8 +336,8 @@
(setf rect (gfs:make-rectangle :location (clone-point rect-pnt) :size rect-size))
(draw-rect-start-end gc rect (clone-point start-pnt) (clone-point end-pnt) delta-x #'gfg:draw-pie-wedge nil)))
-(defun select-wedges (disp item time rect)
- (declare (ignore disp time rect))
+(defun select-wedges (disp item rect)
+ (declare (ignore disp rect))
(update-drawing-item-check item)
(setf (draw-func-of *drawing-dispatcher*) #'draw-wedges)
(gfw:redraw *drawing-win*))
Modified: trunk/src/tests/uitoolkit/event-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/event-tester.lisp (original)
+++ trunk/src/tests/uitoolkit/event-tester.lisp Sun Jul 9 02:35:37 2006
@@ -47,16 +47,16 @@
(defclass event-tester-window-events (gfw:event-dispatcher) ())
-(defmethod gfw:event-paint ((d event-tester-window-events) window time gc rect)
- (declare (ignorable time rect))
+(defmethod gfw:event-paint ((d event-tester-window-events) window gc rect)
+ (declare (ignore rect))
(setf (gfg:background-color gc) gfg:*color-white*)
(setf (gfg:foreground-color gc) gfg:*color-blue*)
(let* ((sz (gfw:client-size window))
(pnt (gfs:make-point :x 0 :y (floor (gfs:size-height sz) 2))))
(gfg:draw-text gc *event-tester-text* pnt)))
-(defmethod gfw:event-close ((d event-tester-window-events) widget time)
- (declare (ignore widget time))
+(defmethod gfw:event-close ((d event-tester-window-events) widget)
+ (declare (ignore widget))
(exit-event-tester))
(defun text-for-modifiers ()
@@ -72,7 +72,7 @@
(not (gfw:key-toggled-p gfw:+vk-num-lock+))
(not (gfw:key-toggled-p gfw:+vk-scroll-lock+))))
-(defun text-for-mouse (action time button pnt)
+(defun text-for-mouse (action button pnt)
(format nil
"~a mouse action: ~s button: ~a point: (~d,~d) time: 0x~x ~s"
(incf *event-counter*)
@@ -80,131 +80,130 @@
button
(gfs:point-x pnt)
(gfs:point-y pnt)
- time
+ (gfw:obtain-event-time)
(text-for-modifiers)))
-(defun text-for-key (action time key-code char)
+(defun text-for-key (action key-code char)
(format nil
"~a key action: ~s char: ~s code: 0x~x time: 0x~x ~s"
(incf *event-counter*)
action
char
key-code
- time
+ (gfw:obtain-event-time)
(text-for-modifiers)))
-(defun text-for-item (text time desc)
+(defun text-for-item (text desc)
(format nil
"~a ~s: ~s time: 0x~x ~s"
(incf *event-counter*)
desc
text
- time
+ (gfw:obtain-event-time)
(text-for-modifiers)))
-(defun text-for-size (type time size)
+(defun text-for-size (type size)
(format nil
"~a resize action: ~s size: (~d,~d) time: 0x~x ~s"
(incf *event-counter*)
(symbol-name type)
(gfs:size-width size)
(gfs:size-height size)
- time
+ (gfw:obtain-event-time)
(text-for-modifiers)))
-(defun text-for-move (time pnt)
+(defun text-for-move (pnt)
(format nil
"~a move point: (~d,~d) time: 0x~x ~s"
(incf *event-counter*)
(gfs:point-x pnt)
(gfs:point-y pnt)
- time
+ (gfw:obtain-event-time)
(text-for-modifiers)))
-(defun text-for-timer (time)
+(defun text-for-timer ()
(format nil
"~a timer tick id: ~d time: 0x~x ~s"
(incf *event-counter*)
(gfw:id-of *timer*)
- time
+ (gfw:obtain-event-time)
(text-for-modifiers)))
-(defmethod gfw:event-key-down ((d event-tester-window-events) window time key-code char)
- (setf *event-tester-text* (text-for-key "down" time key-code char))
+(defmethod gfw:event-key-down ((d event-tester-window-events) window key-code char)
+ (setf *event-tester-text* (text-for-key "down" key-code char))
(gfw:redraw window))
-(defmethod gfw:event-key-up ((d event-tester-window-events) window time key-code char)
- (setf *event-tester-text* (text-for-key "up" time key-code char))
+(defmethod gfw:event-key-up ((d event-tester-window-events) window key-code char)
+ (setf *event-tester-text* (text-for-key "up" key-code char))
(gfw:redraw window))
-(defmethod gfw:event-mouse-double ((d event-tester-window-events) window time pnt button)
- (setf *event-tester-text* (text-for-mouse "double" time button pnt))
+(defmethod gfw:event-mouse-double ((d event-tester-window-events) window pnt button)
+ (setf *event-tester-text* (text-for-mouse "double" button pnt))
(gfw:redraw window))
-(defmethod gfw:event-mouse-down ((d event-tester-window-events) window time pnt button)
- (setf *event-tester-text* (text-for-mouse "down" time button pnt))
+(defmethod gfw:event-mouse-down ((d event-tester-window-events) window pnt button)
+ (setf *event-tester-text* (text-for-mouse "down" button pnt))
(setf *mouse-down-flag* t)
(gfw:redraw window))
-(defmethod gfw:event-mouse-move ((d event-tester-window-events) window time pnt button)
+(defmethod gfw:event-mouse-move ((d event-tester-window-events) window pnt button)
(when *mouse-down-flag*
- (setf *event-tester-text* (text-for-mouse "move" time button pnt))
+ (setf *event-tester-text* (text-for-mouse "move" button pnt))
(gfw:redraw window)))
-(defmethod gfw:event-mouse-up ((d event-tester-window-events) window time pnt button)
- (setf *event-tester-text* (text-for-mouse "up" time button pnt))
+(defmethod gfw:event-mouse-up ((d event-tester-window-events) window pnt button)
+ (setf *event-tester-text* (text-for-mouse "up" button pnt))
(setf *mouse-down-flag* nil)
(gfw:redraw window))
-(defmethod gfw:event-move ((d event-tester-window-events) window time pnt)
- (setf *event-tester-text* (text-for-move time pnt))
+(defmethod gfw:event-move ((d event-tester-window-events) window pnt)
+ (setf *event-tester-text* (text-for-move pnt))
(gfw:redraw window)
0)
-(defmethod gfw:event-resize ((d event-tester-window-events) window time size type)
- (setf *event-tester-text* (text-for-size type time size))
+(defmethod gfw:event-resize ((d event-tester-window-events) window size type)
+ (setf *event-tester-text* (text-for-size type size))
(gfw:redraw window)
0)
(defclass event-tester-exit-dispatcher (gfw:event-dispatcher) ())
-(defmethod gfw:event-select ((d event-tester-exit-dispatcher) item time rect)
- (declare (ignorable item time rect))
+(defmethod gfw:event-select ((d event-tester-exit-dispatcher) item rect)
+ (declare (ignore item rect))
(exit-event-tester))
-(defmethod gfw:event-arm ((d event-tester-exit-dispatcher) item time)
- (declare (ignore rect))
- (setf *event-tester-text* (text-for-item (gfw:text item) time "item armed"))
+(defmethod gfw:event-arm ((d event-tester-exit-dispatcher) item)
+ (setf *event-tester-text* (text-for-item (gfw:text item) "item armed"))
(gfw:redraw *event-tester-window*))
(defclass event-tester-echo-dispatcher (gfw:event-dispatcher) ())
-(defmethod gfw:event-select ((d event-tester-echo-dispatcher) item time rect)
+(defmethod gfw:event-select ((d event-tester-echo-dispatcher) item rect)
(declare (ignore rect))
- (setf *event-tester-text* (text-for-item (gfw:text item) time "item selected"))
+ (setf *event-tester-text* (text-for-item (gfw:text item) "item selected"))
(gfw:redraw *event-tester-window*))
-(defmethod gfw:event-arm ((d event-tester-echo-dispatcher) item time)
- (declare (ignore rect))
- (setf *event-tester-text* (text-for-item (gfw:text item) time "item armed"))
+(defmethod gfw:event-arm ((d event-tester-echo-dispatcher) item)
+ (setf *event-tester-text* (text-for-item (gfw:text item) "item armed"))
(gfw:redraw *event-tester-window*))
-(defmethod gfw:event-activate ((d event-tester-echo-dispatcher) widget time)
- (setf *event-tester-text* (text-for-item (format nil "~a" widget) time "menu activated"))
+(defmethod gfw:event-activate ((d event-tester-echo-dispatcher) widget type)
+ (declare (ignore type))
+ (setf *event-tester-text* (text-for-item (format nil "~a" widget) "menu activated"))
(gfw:redraw *event-tester-window*))
-(defmethod gfw:event-timer ((disp event-tester-echo-dispatcher) timer time)
- (declare (ignore disp timer))
- (setf *event-tester-text* (text-for-timer time))
+(defmethod gfw:event-timer ((disp event-tester-echo-dispatcher) timer)
+ (declare (ignore timer))
+ (setf *event-tester-text* (text-for-timer))
(gfw:redraw *event-tester-window*))
-(defun manage-file-menu (disp menu time)
- (declare (ignore disp time))
+(defun manage-file-menu (disp menu type)
+ (declare (ignore disp type))
(let ((item (elt (gfw:items menu) 0)))
(setf (gfw:text item) (if *timer* "Sto&p Timer" "&Start Timer"))))
-(defun manage-timer (disp item time rect)
- (declare (ignore disp item time rect))
+(defun manage-timer (disp item rect)
+ (declare (ignore disp item rect))
(if *timer*
(progn
(gfw:enable *timer* nil)
Modified: trunk/src/tests/uitoolkit/hello-world.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/hello-world.lisp (original)
+++ trunk/src/tests/uitoolkit/hello-world.lisp Sun Jul 9 02:35:37 2006
@@ -37,18 +37,18 @@
(defclass hellowin-events (gfw:event-dispatcher) ())
-(defun exit-fn (disp item time rect)
- (declare (ignorable disp item time rect))
+(defun exit-fn (disp item rect)
+ (declare (ignore disp item rect))
(gfs:dispose *hello-win*)
(setf *hello-win* nil)
(gfw:shutdown 0))
-(defmethod gfw:event-close ((disp hellowin-events) window time)
+(defmethod gfw:event-close ((disp hellowin-events) window)
(declare (ignore window))
- (exit-fn disp nil time nil))
+ (exit-fn disp nil nil))
-(defmethod gfw:event-paint ((disp hellowin-events) window time gc rect)
- (declare (ignore time rect))
+(defmethod gfw:event-paint ((disp hellowin-events) window gc rect)
+ (declare (ignore rect))
(setf (gfg:background-color gc) gfg:*color-white*)
(setf (gfg:foreground-color gc) gfg:*color-white*)
(gfg:draw-filled-rectangle gc (gfs:make-rectangle :size (gfw:client-size window)))
Modified: trunk/src/tests/uitoolkit/image-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/image-tester.lisp (original)
+++ trunk/src/tests/uitoolkit/image-tester.lisp Sun Jul 9 02:35:37 2006
@@ -48,15 +48,15 @@
(gfs:dispose *true-image*)
(setf *true-image* nil))
-(defmethod gfw:event-close ((d image-events) window time)
- (declare (ignore window time))
+(defmethod gfw:event-close ((d image-events) window)
+ (declare (ignore window))
(dispose-images)
(gfs:dispose *image-win*)
(setf *image-win* nil)
(gfw:shutdown 0))
-(defmethod gfw:event-paint ((d image-events) window time gc rect)
- (declare (ignore window time rect))
+(defmethod gfw:event-paint ((d image-events) window gc rect)
+ (declare (ignore window rect))
(let ((pnt (gfs:make-point))
(pixel-pnt1 (gfs:make-point))
(pixel-pnt2 (gfs:make-point :x 0 :y 15)))
@@ -86,8 +86,8 @@
(incf (gfs:point-x pnt) 20)
(gfg:draw-image gc *true-image* pnt))))
-(defun exit-image-fn (disp item time rect)
- (declare (ignorable disp item time rect))
+(defun exit-image-fn (disp item rect)
+ (declare (ignorable disp item rect))
(dispose-images)
(gfs:dispose *image-win*)
(setf *image-win* nil)
Modified: trunk/src/tests/uitoolkit/layout-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/layout-tester.lisp (original)
+++ trunk/src/tests/uitoolkit/layout-tester.lisp Sun Jul 9 02:35:37 2006
@@ -52,14 +52,14 @@
(defclass layout-tester-events (gfw:event-dispatcher) ())
-(defmethod gfw:event-close ((d layout-tester-events) widget time)
- (declare (ignore widget time))
+(defmethod gfw:event-close ((d layout-tester-events) widget)
+ (declare (ignore widget))
(exit-layout-tester))
(defclass pack-layout-dispatcher (gfw:event-dispatcher) ())
-(defmethod gfw:event-select ((d pack-layout-dispatcher) item time rect)
- (declare (ignorable item time rect))
+(defmethod gfw:event-select ((d pack-layout-dispatcher) item rect)
+ (declare (ignore item rect))
(gfw:pack *layout-tester-win*))
(defclass layout-tester-widget-events (gfw:event-dispatcher)
@@ -71,8 +71,8 @@
:initarg :id
:initform 0)))
-(defmethod gfw:event-paint ((self layout-tester-widget-events) window time gc rect)
- (declare (ignore time rect))
+(defmethod gfw:event-paint ((self layout-tester-widget-events) window gc rect)
+ (declare (ignore rect))
(setf (gfg:background-color gc) gfg:*color-white*)
(setf (gfg:foreground-color gc) gfg:*color-white*)
(gfg:draw-filled-rectangle gc (gfs:make-rectangle :size (gfw:client-size window))))
@@ -139,8 +139,8 @@
:dispatcher be))))
(incf *widget-counter*)))
-(defmethod gfw:event-select ((d layout-tester-widget-events) btn time rect)
- (declare (ignorable time rect))
+(defmethod gfw:event-select ((d layout-tester-widget-events) btn rect)
+ (declare (ignore rect))
(setf (gfw:text btn) (funcall (toggle-fn d)))
(gfw:layout *layout-tester-win*))
@@ -154,8 +154,8 @@
:initarg :subtype
:initform :push-button)))
-(defmethod gfw:event-select ((d add-child-dispatcher) item time rect)
- (declare (ignorable item time rect))
+(defmethod gfw:event-select ((d add-child-dispatcher) item rect)
+ (declare (ignorable item rect))
(add-layout-tester-widget (widget-class d) (subtype d))
(gfw:pack *layout-tester-win*))
@@ -169,8 +169,8 @@
:initarg :sub-disp-class
:initform nil)))
-(defmethod gfw:event-activate ((d child-menu-dispatcher) menu time)
- (declare (ignore time))
+(defmethod gfw:event-activate ((d child-menu-dispatcher) menu type)
+ (declare (ignore type))
(gfw:clear-all menu)
(gfw:mapchildren *layout-tester-win*
(lambda (parent child)
@@ -192,8 +192,8 @@
(defclass remove-child-dispatcher (gfw:event-dispatcher) ())
-(defmethod gfw:event-select ((d remove-child-dispatcher) item time rect)
- (declare (ignorable time rect))
+(defmethod gfw:event-select ((d remove-child-dispatcher) item rect)
+ (declare (ignore rect))
(let ((victim (find-victim (gfw:text item))))
(unless (null victim)
(gfs:dispose victim)
@@ -201,21 +201,21 @@
(defclass visibility-child-dispatcher (gfw:event-dispatcher) ())
-(defmethod gfw:event-select ((d visibility-child-dispatcher) item time rect)
- (declare (ignorable time rect))
+(defmethod gfw:event-select ((d visibility-child-dispatcher) item rect)
+ (declare (ignore rect))
(let ((victim (find-victim (gfw:text item))))
(unless (null victim)
(gfw:show victim (not (gfw:visible-p victim)))
(gfw:layout *layout-tester-win*))))
-(defun check-flow-orient-items (disp menu time)
- (declare (ignore disp time))
+(defun check-flow-orient-items (disp menu type)
+ (declare (ignore disp type))
(let ((layout (gfw:layout-of *layout-tester-win*)))
(gfw:check (elt (gfw:items menu) 0) (find :horizontal (gfw:style-of layout)))
(gfw:check (elt (gfw:items menu) 1) (find :vertical (gfw:style-of layout)))))
-(defun set-flow-horizontal (disp item time rect)
- (declare (ignorable disp item time rect))
+(defun set-flow-horizontal (disp item rect)
+ (declare (ignorable disp item rect))
(let* ((layout (gfw:layout-of *layout-tester-win*))
(style (gfw:style-of layout)))
(setf style (remove :vertical style))
@@ -223,8 +223,8 @@
(setf (gfw:style-of layout) style)
(gfw:layout *layout-tester-win*)))
-(defun set-flow-vertical (disp item time rect)
- (declare (ignorable disp item time rect))
+(defun set-flow-vertical (disp item rect)
+ (declare (ignorable disp item rect))
(let* ((layout (gfw:layout-of *layout-tester-win*))
(style (gfw:style-of layout)))
(setf style (remove :horizontal style))
@@ -232,8 +232,8 @@
(setf (gfw:style-of layout) style)
(gfw:layout *layout-tester-win*)))
-(defun set-flow-layout-normalize (disp item time rect)
- (declare (ignorable disp item time rect))
+(defun set-flow-layout-normalize (disp item rect)
+ (declare (ignorable disp item rect))
(let* ((layout (gfw:layout-of *layout-tester-win*))
(style (gfw:style-of layout)))
(if (find :normalize style)
@@ -241,8 +241,8 @@
(setf (gfw:style-of layout) (push :normalize style)))
(gfw:layout *layout-tester-win*)))
-(defun set-flow-layout-wrap (disp item time rect)
- (declare (ignorable disp item time rect))
+(defun set-flow-layout-wrap (disp item rect)
+ (declare (ignorable disp item rect))
(let* ((layout (gfw:layout-of *layout-tester-win*))
(style (gfw:style-of layout)))
(if (find :wrap style)
@@ -250,13 +250,13 @@
(setf (gfw:style-of layout) (push :wrap style)))
(gfw:layout *layout-tester-win*)))
-(defun enable-flow-spacing-items (disp menu time)
- (declare (ignore disp time))
+(defun enable-flow-spacing-items (disp menu type)
+ (declare (ignore disp type))
(let ((spacing (gfw:spacing-of (gfw:layout-of *layout-tester-win*))))
(gfw:enable (elt (gfw:items menu) 0) (> spacing 0))))
-(defun decrease-flow-spacing (disp item time rect)
- (declare (ignore disp item time rect))
+(defun decrease-flow-spacing (disp item rect)
+ (declare (ignore disp item rect))
(let* ((layout (gfw:layout-of *layout-tester-win*))
(spacing (gfw:spacing-of layout)))
(unless (zerop spacing)
@@ -264,82 +264,82 @@
(setf (gfw:spacing-of layout) spacing)
(gfw:layout *layout-tester-win*))))
-(defun increase-flow-spacing (disp item time rect)
- (declare (ignore disp item time rect))
+(defun increase-flow-spacing (disp item rect)
+ (declare (ignore disp item rect))
(let ((layout (gfw:layout-of *layout-tester-win*)))
(incf (gfw:spacing-of layout) +spacing-delta+)
(gfw:layout *layout-tester-win*)))
-(defun enable-left-flow-margin-items (disp menu time)
- (declare (ignore disp time))
+(defun enable-left-flow-margin-items (disp menu rect)
+ (declare (ignore disp rect))
(let ((layout (gfw:layout-of *layout-tester-win*)))
(gfw:enable (elt (gfw:items menu) 0) (> (gfw:left-margin-of layout) 0))))
-(defun enable-top-flow-margin-items (disp menu time)
- (declare (ignore disp time))
+(defun enable-top-flow-margin-items (disp menu rect)
+ (declare (ignore disp rect))
(let ((layout (gfw:layout-of *layout-tester-win*)))
(gfw:enable (elt (gfw:items menu) 0) (> (gfw:top-margin-of layout) 0))))
-(defun enable-right-flow-margin-items (disp menu time)
- (declare (ignore disp time))
+(defun enable-right-flow-margin-items (disp menu rect)
+ (declare (ignore disp rect))
(let ((layout (gfw:layout-of *layout-tester-win*)))
(gfw:enable (elt (gfw:items menu) 0) (> (gfw:right-margin-of layout) 0))))
-(defun enable-bottom-flow-margin-items (disp menu time)
- (declare (ignore disp time))
+(defun enable-bottom-flow-margin-items (disp menu rect)
+ (declare (ignore disp rect))
(let ((layout (gfw:layout-of *layout-tester-win*)))
(gfw:enable (elt (gfw:items menu) 0) (> (gfw:bottom-margin-of layout) 0))))
-(defun inc-left-flow-margin (disp item time rect)
- (declare (ignore disp item time rect))
+(defun inc-left-flow-margin (disp item rect)
+ (declare (ignore disp item rect))
(let ((layout (gfw:layout-of *layout-tester-win*)))
(incf (gfw:left-margin-of layout) +margin-delta+)
(gfw:layout *layout-tester-win*)))
-(defun inc-top-flow-margin (disp item time rect)
- (declare (ignore disp item time rect))
+(defun inc-top-flow-margin (disp item rect)
+ (declare (ignore disp item rect))
(let ((layout (gfw:layout-of *layout-tester-win*)))
(incf (gfw:top-margin-of layout) +margin-delta+)
(gfw:layout *layout-tester-win*)))
-(defun inc-right-flow-margin (disp item time rect)
- (declare (ignore disp item time rect))
+(defun inc-right-flow-margin (disp item rect)
+ (declare (ignore disp item rect))
(let ((layout (gfw:layout-of *layout-tester-win*)))
(incf (gfw:right-margin-of layout) +margin-delta+)
(gfw:layout *layout-tester-win*)))
-(defun inc-bottom-flow-margin (disp item time rect)
- (declare (ignore disp item time rect))
+(defun inc-bottom-flow-margin (disp item rect)
+ (declare (ignore disp item rect))
(let ((layout (gfw:layout-of *layout-tester-win*)))
(incf (gfw:bottom-margin-of layout) +margin-delta+)
(gfw:layout *layout-tester-win*)))
-(defun dec-left-flow-margin (disp item time rect)
- (declare (ignore disp item time rect))
+(defun dec-left-flow-margin (disp item rect)
+ (declare (ignore disp item rect))
(let ((layout (gfw:layout-of *layout-tester-win*)))
(decf (gfw:left-margin-of layout) +margin-delta+)
(gfw:layout *layout-tester-win*)))
-(defun dec-top-flow-margin (disp item time rect)
- (declare (ignore disp item time rect))
+(defun dec-top-flow-margin (disp item rect)
+ (declare (ignore disp item rect))
(let ((layout (gfw:layout-of *layout-tester-win*)))
(decf (gfw:top-margin-of layout) +margin-delta+)
(gfw:layout *layout-tester-win*)))
-(defun dec-right-flow-margin (disp item time rect)
- (declare (ignore disp item time rect))
+(defun dec-right-flow-margin (disp item rect)
+ (declare (ignore disp item rect))
(let ((layout (gfw:layout-of *layout-tester-win*)))
(decf (gfw:right-margin-of layout) +margin-delta+)
(gfw:layout *layout-tester-win*)))
-(defun dec-bottom-flow-margin (disp item time rect)
- (declare (ignore disp item time rect))
+(defun dec-bottom-flow-margin (disp item rect)
+ (declare (ignore disp item rect))
(let ((layout (gfw:layout-of *layout-tester-win*)))
(decf (gfw:bottom-margin-of layout) +margin-delta+)
(gfw:layout *layout-tester-win*)))
-(defun flow-mod-callback (disp menu time)
- (declare (ignore disp time))
+(defun flow-mod-callback (disp menu type)
+ (declare (ignore disp type))
(gfw:clear-all menu)
(let ((it nil)
(margin-menu (gfw:defmenu ((:item "Left"
@@ -383,8 +383,8 @@
(setf it (gfw:append-item menu "Wrap" nil #'set-flow-layout-wrap))
(gfw:check it (find :wrap style)))))
-(defun exit-layout-callback (disp item time rect)
- (declare (ignorable disp item time rect))
+(defun exit-layout-callback (disp item rect)
+ (declare (ignorable disp item rect))
(exit-layout-tester))
(defun run-layout-tester-internal ()
Modified: trunk/src/tests/uitoolkit/windlg.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/windlg.lisp (original)
+++ trunk/src/tests/uitoolkit/windlg.lisp Sun Jul 9 02:35:37 2006
@@ -37,38 +37,37 @@
(defclass main-win-events (gfw:event-dispatcher) ())
-(defun windlg-exit-fn (disp item time rect)
- (declare (ignore disp item time rect))
+(defun windlg-exit-fn (disp item rect)
+ (declare (ignore disp item rect))
(gfs:dispose *main-win*)
(setf *main-win* nil)
(gfw:shutdown 0))
-(defmethod gfw:event-close ((self main-win-events) window time)
- (declare (ignore window time))
- (windlg-exit-fn self nil nil 0))
+(defmethod gfw:event-close ((self main-win-events) window)
+ (declare (ignore window))
+ (windlg-exit-fn self nil nil))
(defclass test-win-events (gfw:event-dispatcher) ())
-(defmethod gfw:event-paint ((d test-win-events) window time gc rect)
- (declare (ignore time rect))
+(defmethod gfw:event-paint ((d test-win-events) window gc rect)
+ (declare (ignore rect))
(setf (gfg:background-color gc) gfg:*color-white*)
(setf (gfg:foreground-color gc) gfg:*color-white*)
(gfg:draw-filled-rectangle gc (gfs:make-rectangle :size (gfw:client-size window))))
(defclass test-mini-events (test-win-events) ())
-(defmethod gfw:event-close ((d test-mini-events) window time)
- (declare (ignore time))
+(defmethod gfw:event-close ((d test-mini-events) window)
(gfs:dispose window))
(defclass test-borderless-events (test-win-events) ())
-(defmethod gfw:event-mouse-down ((d test-borderless-events) window time point button)
- (declare (ignore time point button))
+(defmethod gfw:event-mouse-down ((d test-borderless-events) window point button)
+ (declare (ignore point button))
(gfs:dispose window))
-(defun create-borderless-win (disp item time rect)
- (declare (ignore disp item time rect))
+(defun create-borderless-win (disp item rect)
+ (declare (ignore disp item rect))
(let ((window (make-instance 'gfw:top-level :dispatcher (make-instance 'test-borderless-events)
:owner *main-win*
:style '(:borderless))))
@@ -76,8 +75,8 @@
(gfw:center-on-owner window)
(gfw:show window t)))
-(defun create-miniframe-win (disp item time rect)
- (declare (ignore disp item time rect))
+(defun create-miniframe-win (disp item rect)
+ (declare (ignore disp item rect))
(let ((window (make-instance 'gfw:top-level :dispatcher (make-instance 'test-mini-events)
:owner *main-win*
:text "Mini Frame"
@@ -86,8 +85,8 @@
(setf (gfw:size window) (gfs:make-size :width 150 :height 225))
(gfw:show window t)))
-(defun create-palette-win (disp item time rect)
- (declare (ignore disp item time rect))
+(defun create-palette-win (disp item rect)
+ (declare (ignore disp item rect))
(let ((window (make-instance 'gfw:top-level :dispatcher (make-instance 'test-mini-events)
:owner *main-win*
:text "Palette"
@@ -96,8 +95,8 @@
(setf (gfw:size window) (gfs:make-size :width 150 :height 225))
(gfw:show window t)))
-(defun open-file-dlg (disp item time rect)
- (declare (ignore disp item time rect))
+(defun open-file-dlg (disp item rect)
+ (declare (ignore disp item rect))
(gfw:with-file-dialog (*main-win*
'(:open :add-to-recent :multiple-select)
paths
@@ -108,8 +107,8 @@
:text "Select Lisp-related files...")
(print paths)))
-(defun save-file-dlg (disp item time rect)
- (declare (ignore disp item time rect))
+(defun save-file-dlg (disp item rect)
+ (declare (ignore disp item rect))
(gfw:with-file-dialog (*main-win*
'(:save)
paths
@@ -118,8 +117,8 @@
:initial-directory #P"c:/")
(print paths)))
-(defun choose-font-dlg (disp item time rect)
- (declare (ignore disp item time rect))
+(defun choose-font-dlg (disp item rect)
+ (declare (ignore disp item rect))
(gfw:with-graphics-context (gc *main-win*)
(gfw:with-font-dialog (*main-win* nil font color :gc gc)
(if color
@@ -129,9 +128,7 @@
(defclass dialog-events (gfw:event-dispatcher) ())
-(defmethod gfw:event-close ((disp dialog-events) (dlg gfw:dialog) time)
- (declare (ignore time))
- (format t "dialog-events event-close called~%")
+(defmethod gfw:event-close ((disp dialog-events) (dlg gfw:dialog))
(call-next-method)
(gfs:dispose dlg))
@@ -140,16 +137,13 @@
(defun truncate-text (str)
(subseq str 0 (min (length str) 5)))
-(defmethod gfw:event-focus-gain ((disp edit-control-events) (ctrl gfw:edit) time)
- (declare (ignore time))
+(defmethod gfw:event-focus-gain ((disp edit-control-events) (ctrl gfw:edit))
(format t "gained focus: ~a...~%" (truncate-text (gfw:text ctrl))))
-(defmethod gfw:event-focus-loss ((disp edit-control-events) (ctrl gfw:edit) time)
- (declare (ignore time))
+(defmethod gfw:event-focus-loss ((disp edit-control-events) (ctrl gfw:edit))
(format t "lost focus: ~a...~%" (truncate-text (gfw:text ctrl))))
-(defmethod gfw:event-modify ((disp edit-control-events) (ctrl gfw:edit) time)
- (declare (ignore time))
+(defmethod gfw:event-modify ((disp edit-control-events) (ctrl gfw:edit))
(format t "modified: ~a...~%" (truncate-text (gfw:text ctrl))))
(defun open-dlg (title style)
@@ -204,15 +198,15 @@
:style '(:vertical :normalize))
:parent dlg))
(ok-btn (make-instance 'gfw:button
- :callback (lambda (disp btn time rect)
- (declare (ignore disp btn time rect))
+ :callback (lambda (disp btn rect)
+ (declare (ignore disp btn rect))
(gfs:dispose dlg))
:style '(:default-button)
:text "OK"
:parent btn-panel))
(cancel-btn (make-instance 'gfw:button
- :callback (lambda (disp btn time rect)
- (declare (ignore disp btn time rect))
+ :callback (lambda (disp btn rect)
+ (declare (ignore disp btn rect))
(gfs:dispose dlg))
:style '(:cancel-button)
:text "Cancel"
@@ -226,12 +220,12 @@
(gfw:show dlg t)
dlg))
-(defun open-modal-dlg (disp item time rect)
- (declare (ignore disp item time rect))
+(defun open-modal-dlg (disp item rect)
+ (declare (ignore disp item rect))
(open-dlg "Modal" '(:owner-modal)))
-(defun open-modeless-dlg (disp item time rect)
- (declare (ignore disp item time rect))
+(defun open-modeless-dlg (disp item rect)
+ (declare (ignore disp item rect))
(open-dlg "Modeless" '(:modeless)))
(defun run-windlg-internal ()
Modified: trunk/src/uitoolkit/system/system-constants.lisp
==============================================================================
--- trunk/src/uitoolkit/system/system-constants.lisp (original)
+++ trunk/src/uitoolkit/system/system-constants.lisp Sun Jul 9 02:35:37 2006
@@ -889,6 +889,10 @@
(defconstant +user-timer-maximum+ #x7FFFFFFF)
(defconstant +user-timer-minimum+ #x0000000A)
+(defconstant +wa-inactive+ 0)
+(defconstant +wa-active+ 1)
+(defconstant +wa-clickactive+ 2)
+
(defconstant +wb-left+ 0)
(defconstant +wb-right+ 1)
(defconstant +wb-isdelimiter+ 2)
Modified: trunk/src/uitoolkit/widgets/event-generics.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/event-generics.lisp (original)
+++ trunk/src/uitoolkit/widgets/event-generics.lisp Sun Jul 9 02:35:37 2006
@@ -33,162 +33,157 @@
(in-package :graphic-forms.uitoolkit.widgets)
-(defgeneric event-activate (dispatcher widget time)
+(defgeneric event-activate (dispatcher widget type)
(:documentation "Implement this to respond to an object being activated.")
- (:method (dispatcher widget time)
- (declare (ignorable dispatcher widget time))))
+ (:method (dispatcher widget type)
+ (declare (ignorable dispatcher widget type))))
-(defgeneric event-arm (dispatcher item time)
+(defgeneric event-arm (dispatcher item)
(:documentation "Implement this to respond to an object about to be selected.")
- (:method (dispatcher item time)
- (declare (ignorable dispatcher item time))))
+ (:method (dispatcher item)
+ (declare (ignorable dispatcher item))))
-(defgeneric event-close (dispatcher widget time)
+(defgeneric event-close (dispatcher widget)
(:documentation "Implement this to respond to an object being closed.")
- (:method (dispatcher widget time)
- (declare (ignorable dispatcher widget time))))
+ (:method (dispatcher widget)
+ (declare (ignorable dispatcher widget))))
-(defgeneric event-collapse (dispatcher item time rect)
+(defgeneric event-collapse (dispatcher item rect)
(:documentation "Implement this to respond to an object (or item within) being collapsed.")
- (:method (dispatcher item time rect)
- (declare (ignorable dispatcher item time rect))))
+ (:method (dispatcher item rect)
+ (declare (ignorable dispatcher item rect))))
-(defgeneric event-deactivate (dispatcher widget time)
+(defgeneric event-deactivate (dispatcher widget type)
(:documentation "Implement this to respond to an object being deactivated.")
- (:method (dispatcher widget time)
- (declare (ignorable dispatcher widget time))))
+ (:method (dispatcher widget type)
+ (declare (ignorable dispatcher widget type))))
-(defgeneric event-deiconify (dispatcher widget time)
+(defgeneric event-deiconify (dispatcher widget)
(:documentation "Implement this to respond to an object being deiconified.")
- (:method (dispatcher widget time)
- (declare (ignorable dispatcher widget time))))
+ (:method (dispatcher widget)
+ (declare (ignorable dispatcher widget))))
-(defgeneric event-dispose (dispatcher widget time)
+(defgeneric event-dispose (dispatcher widget)
(:documentation "Implement this to respond to an object being disposed (via dispose, not the GC).")
- (:method (dispatcher widget time)
- (declare (ignorable dispatcher widget time))))
+ (:method (dispatcher widget)
+ (declare (ignorable dispatcher widget))))
-(defgeneric event-expand (dispatcher item time rect)
+(defgeneric event-expand (dispatcher item rect)
(:documentation "Implement this to respond to an object (or item within) being expanded.")
- (:method (dispatcher item time rect)
- (declare (ignorable dispatcher item time rect))))
+ (:method (dispatcher item rect)
+ (declare (ignorable dispatcher item rect))))
-(defgeneric event-focus-gain (dispatcher widget time)
+(defgeneric event-focus-gain (dispatcher widget)
(:documentation "Implement this to respond to an object gaining keyboard focus.")
- (:method (dispatcher widget time)
- (declare (ignorable dispatcher widget time))))
+ (:method (dispatcher widget)
+ (declare (ignorable dispatcher widget))))
-(defgeneric event-focus-loss (dispatcher widget time)
+(defgeneric event-focus-loss (dispatcher widget)
(:documentation "Implement this to respond to an object losing keyboard focus.")
- (:method (dispatcher widget time)
- (declare (ignorable dispatcher widget time))))
+ (:method (dispatcher widget)
+ (declare (ignorable dispatcher widget))))
-(defgeneric event-hide (dispatcher widget time)
+(defgeneric event-hide (dispatcher widget)
(:documentation "Implement this to respond to an object being hidden.")
- (:method (dispatcher widget time)
- (declare (ignorable dispatcher widget time))))
+ (:method (dispatcher widget)
+ (declare (ignorable dispatcher widget))))
-(defgeneric event-iconify (dispatcher widget time)
+(defgeneric event-iconify (dispatcher widget)
(:documentation "Implement this to respond to an object being iconified.")
- (:method (dispatcher widget time)
- (declare (ignorable dispatcher widget time))))
+ (:method (dispatcher widget)
+ (declare (ignorable dispatcher widget))))
-(defgeneric event-key-down (dispatcher widget time keycode char)
+(defgeneric event-key-down (dispatcher widget keycode char)
(:documentation "Implement this to respond to a key down event.")
- (:method (dispatcher widget time keycode char)
- (declare (ignorable dispatcher widget time keycode char))))
+ (:method (dispatcher widget keycode char)
+ (declare (ignorable dispatcher widget keycode char))))
-(defgeneric event-key-traverse (dispatcher widget time keycode char type)
- (:documentation "Implement this to respond to a key traversal event.")
- (:method (dispatcher widget time keycode char type)
- (declare (ignorable dispatcher widget time keycode char type))))
-
-(defgeneric event-key-up (dispatcher widget time keycode char)
+(defgeneric event-key-up (dispatcher widget keycode char)
(:documentation "Implement this to respond to a key up event.")
- (:method (dispatcher widget time keycode char)
- (declare (ignorable dispatcher widget time keycode char))))
+ (:method (dispatcher widget keycode char)
+ (declare (ignorable dispatcher widget keycode char))))
-(defgeneric event-modify (dispatcher widget time)
+(defgeneric event-modify (dispatcher widget)
(:documentation "Implement this to respond to content (e.g., text) in an object being modified.")
- (:method (dispatcher widget time)
- (declare (ignorable dispatcher widget time))))
+ (:method (dispatcher widget)
+ (declare (ignorable dispatcher widget))))
-(defgeneric event-mouse-double (dispatcher widget time point button)
+(defgeneric event-mouse-double (dispatcher widget point button)
(:documentation "Implement this to respond to a mouse double-click.")
- (:method (dispatcher widget time point button)
- (declare (ignorable dispatcher widget time point button))))
+ (:method (dispatcher widget point button)
+ (declare (ignorable dispatcher widget point button))))
-(defgeneric event-mouse-down (dispatcher widget time point button)
+(defgeneric event-mouse-down (dispatcher widget point button)
(:documentation "Implement this to respond to a mouse down event.")
- (:method (dispatcher widget time point button)
- (declare (ignorable dispatcher widget time point button))))
+ (:method (dispatcher widget point button)
+ (declare (ignorable dispatcher widget point button))))
-(defgeneric event-mouse-enter (dispatcher widget time point button)
+(defgeneric event-mouse-enter (dispatcher widget point button)
(:documentation "Implement this to respond to a mouse passing into the bounds of an object.")
- (:method (dispatcher widget time point button)
- (declare (ignorable dispatcher widget time point button))))
+ (:method (dispatcher widget point button)
+ (declare (ignorable dispatcher widget point button))))
-(defgeneric event-mouse-exit (dispatcher widget time point button)
+(defgeneric event-mouse-exit (dispatcher widget point button)
(:documentation "Implement this to respond to a mouse leaving the bounds an object.")
- (:method (dispatcher widget time point button)
- (declare (ignorable dispatcher widget time point button))))
+ (:method (dispatcher widget point button)
+ (declare (ignorable dispatcher widget point button))))
-(defgeneric event-mouse-hover (dispatcher widget time point button)
+(defgeneric event-mouse-hover (dispatcher widget point button)
(:documentation "Implement this to respond to a mouse that stops moving for a period of time within an object.")
- (:method (dispatcher widget time point button)
- (declare (ignorable dispatcher widget time point button))))
+ (:method (dispatcher widget point button)
+ (declare (ignorable dispatcher widget point button))))
-(defgeneric event-mouse-move (dispatcher widget time point button)
+(defgeneric event-mouse-move (dispatcher widget point button)
(:documentation "Implement this to respond to a mouse move event.")
- (:method (dispatcher widget time point button)
- (declare (ignorable dispatcher widget time point button))))
+ (:method (dispatcher widget point button)
+ (declare (ignorable dispatcher widget point button))))
-(defgeneric event-mouse-up (dispatcher widget time point button)
+(defgeneric event-mouse-up (dispatcher widget point button)
(:documentation "Implement this to respond to a mouse up event.")
- (:method (dispatcher widget time point button)
- (declare (ignorable dispatcher widget time point button))))
+ (:method (dispatcher widget point button)
+ (declare (ignorable dispatcher widget point button))))
-(defgeneric event-move (dispatcher widget time point)
+(defgeneric event-move (dispatcher widget point)
(:documentation "Implement this to respond to an object being moved within its parent's coordinate system.")
- (:method (dispatcher widget time point)
- (declare (ignorable dispatcher widget time point))))
+ (:method (dispatcher widget point)
+ (declare (ignorable dispatcher widget point))))
-(defgeneric event-paint (dispatcher widget time gc rect)
+(defgeneric event-paint (dispatcher widget gc rect)
(:documentation "Implement this to respond to paint requests.")
- (:method (dispatcher widget time gc rect)
- (declare (ignorable dispatcher widget time gc rect))))
+ (:method (dispatcher widget gc rect)
+ (declare (ignorable dispatcher widget gc rect))))
-(defgeneric event-pre-modify (dispatcher widget time keycode char span new-content)
+(defgeneric event-pre-modify (dispatcher widget keycode char span new-content)
(:documentation "Implement this to respond to content (e.g., text) in an object about to be modified.")
- (:method (dispatcher widget time keycode char span new-content)
- (declare (ignorable dispatcher widget time keycode char span new-content))))
+ (:method (dispatcher widget keycode char span new-content)
+ (declare (ignorable dispatcher widget keycode char span new-content))))
-(defgeneric event-pre-move (dispatcher widget time)
+(defgeneric event-pre-move (dispatcher widget)
(:documentation "Implement this to preempt moving; return T if processed or nil if not.")
- (:method (dispatcher widget time)
- (declare (ignorable dispatcher widget time))))
+ (:method (dispatcher widget)
+ (declare (ignorable dispatcher widget))))
-(defgeneric event-pre-resize (dispatcher widget time)
+(defgeneric event-pre-resize (dispatcher widget)
(:documentation "Implement this to preempt resizing; return T if processed or nil if not.")
- (:method (dispatcher widget time)
- (declare (ignorable dispatcher widget time))))
+ (:method (dispatcher widget)
+ (declare (ignorable dispatcher widget))))
-(defgeneric event-resize (dispatcher widget time size type)
+(defgeneric event-resize (dispatcher widget size type)
(:documentation "Implement this to respond to an object being resized.")
- (:method (dispatcher widget time size type)
- (declare (ignorable dispatcher widget time size type))))
+ (:method (dispatcher widget size type)
+ (declare (ignorable dispatcher widget size type))))
-(defgeneric event-select (dispatcher item time rect)
+(defgeneric event-select (dispatcher item rect)
(:documentation "Implement this to respond to an object (or item within) being selected.")
- (:method (dispatcher item time rect)
- (declare (ignorable dispatcher item time rect))))
+ (:method (dispatcher item rect)
+ (declare (ignorable dispatcher item rect))))
-(defgeneric event-show (dispatcher widget time)
+(defgeneric event-show (dispatcher widget)
(:documentation "Implement this to respond to an object being shown.")
- (:method (dispatcher widget time)
- (declare (ignorable dispatcher widget time))))
+ (:method (dispatcher widget)
+ (declare (ignorable dispatcher widget))))
-(defgeneric event-timer (dispatcher timer time)
+(defgeneric event-timer (dispatcher timer)
(:documentation "Implement this to respond to a tick from a specific timer.")
- (:method (dispatcher timer time)
- (declare (ignorable dispatcher timer time))))
+ (:method (dispatcher timer)
+ (declare (ignorable dispatcher timer))))
Modified: trunk/src/uitoolkit/widgets/event-source.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/event-source.lisp (original)
+++ trunk/src/uitoolkit/widgets/event-source.lisp Sun Jul 9 02:35:37 2006
@@ -33,9 +33,9 @@
(in-package :graphic-forms.uitoolkit.widgets)
-(defconstant +callback-info+ '((gfw:event-activate . (gfw:event-source integer))
- (gfw:event-arm . (gfw:event-source integer))
- (gfw:event-select . (gfw:event-source integer gfs:rectangle))))
+(defconstant +callback-info+ '((gfw:event-activate . (gfw:event-source symbol))
+ (gfw:event-arm . (gfw:event-source))
+ (gfw:event-select . (gfw:event-source gfs:rectangle))))
(defun make-specializer-list (disp-class arg-info)
(let ((tmp (mapcar #'find-class arg-info)))
Modified: trunk/src/uitoolkit/widgets/event.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/event.lisp (original)
+++ trunk/src/uitoolkit/widgets/event.lisp Sun Jul 9 02:35:37 2006
@@ -102,7 +102,7 @@
(when w
(setf (gfs:point-x pnt) (lo-word lparam))
(setf (gfs:point-y pnt) (hi-word lparam))
- (funcall fn (dispatcher w) w (event-time tc) pnt btn-symbol)))
+ (funcall fn (dispatcher w) w pnt btn-symbol)))
0)
(defun get-class-wndproc (hwnd)
@@ -118,17 +118,15 @@
(error 'gfs:win32-error :detail "set-window-long failed")))
(defun dispatch-notification (widget wparam-hi)
- (let ((disp (dispatcher widget))
- (time (event-time (thread-context))))
+ (let ((disp (dispatcher widget)))
(case wparam-hi
- (0 (event-select disp widget time (gfs:make-rectangle))) ; FIXME: debug
- (#.gfs::+en-killfocus+ (event-focus-loss disp widget time))
- (#.gfs::+en-setfocus+ (event-focus-gain disp widget time))
- (#.gfs::+en-update+ (event-modify disp widget time)))))
+ (0 (event-select disp widget (gfs:make-rectangle))) ; FIXME
+ (#.gfs::+en-killfocus+ (event-focus-loss disp widget))
+ (#.gfs::+en-setfocus+ (event-focus-gain disp widget))
+ (#.gfs::+en-update+ (event-modify disp widget)))))
(defun process-ctlcolor-message (wparam lparam)
- (let* ((tc (thread-context))
- (widget (get-widget tc (cffi:make-pointer lparam)))
+ (let* ((widget (get-widget (thread-context) (cffi:make-pointer lparam)))
(hdc (cffi:make-pointer wparam))
(bkgdcolor (brush-color-of widget))
(textcolor (text-color-of widget))
@@ -141,6 +139,9 @@
(setf ret-val (cffi:pointer-address (brush-handle-of widget))))
ret-val))
+(defun obtain-event-time ()
+ (event-time (thread-context)))
+
;;;
;;; process-message methods
;;;
@@ -153,10 +154,9 @@
(defmethod process-message (hwnd (msg (eql gfs::+wm-close+)) wparam lparam)
(declare (ignore wparam lparam))
- (let* ((tc (thread-context))
- (w (get-widget tc hwnd)))
+ (let ((w (get-widget (thread-context) hwnd)))
(if w
- (event-close (dispatcher w) w (event-time tc))
+ (event-close (dispatcher w) w)
(error 'gfs:toolkit-error :detail "no object for hwnd")))
0)
@@ -172,10 +172,7 @@
(if (null item)
(warn 'gfs:toolkit-warning :detail (format nil "no menu item for id ~x" wparam-lo))
(unless (null (dispatcher item))
- (event-select (dispatcher item)
- item
- (event-time tc)
- (gfs:make-rectangle)))))) ; FIXME
+ (event-select (dispatcher item) item (gfs:make-rectangle)))))) ; FIXME
((eq wparam-hi 1)
(format t "accelerator wparam: ~x lparam: ~x~%" wparam lparam)) ; FIXME: debug
(t
@@ -193,7 +190,7 @@
(unless (null menu)
(let ((d (dispatcher menu)))
(unless (null d)
- (event-activate d menu (event-time tc))))))
+ (event-activate d menu :click))))) ; FIXME: menus can be invoked programmatically, too
0)
(defmethod process-message (hwnd (msg (eql gfs::+wm-menuselect+)) wparam lparam)
@@ -203,7 +200,7 @@
(unless (null item)
(let ((d (dispatcher item)))
(unless (null d)
- (event-arm d item (event-time tc))))))
+ (event-arm d item)))))
0)
(defmethod process-message (hwnd (msg (eql gfs::+wm-create+)) wparam lparam)
@@ -223,7 +220,7 @@
(w (get-widget tc hwnd))
(ch (code-char (lo-word wparam))))
(when w
- (event-key-down (dispatcher w) w (event-time tc) (virtual-key tc) ch)))
+ (event-key-down (dispatcher w) w (virtual-key tc) ch)))
0)
(defmethod process-message (hwnd (msg (eql gfs::+wm-keydown+)) wparam lparam)
@@ -234,7 +231,7 @@
(w (get-widget tc hwnd)))
(setf (virtual-key tc) wparam-lo)
(when (and w (zerop ch))
- (event-key-down (dispatcher w) w (event-time tc) wparam-lo (code-char ch))))
+ (event-key-down (dispatcher w) w wparam-lo (code-char ch))))
0)
(defmethod process-message (hwnd (msg (eql gfs::+wm-keyup+)) wparam lparam)
@@ -244,7 +241,7 @@
(ch (gfs::map-virtual-key wparam-lo 2))
(w (get-widget tc hwnd)))
(when w
- (event-key-up (dispatcher w) w (event-time tc) wparam-lo (code-char ch))))
+ (event-key-up (dispatcher w) w wparam-lo (code-char ch))))
(setf (virtual-key tc) 0))
0)
@@ -289,14 +286,14 @@
(w (get-widget tc hwnd)))
(when w
(outer-location w (move-event-pnt tc))
- (event-move (dispatcher w) w (event-time tc) (move-event-pnt tc))))
+ (event-move (dispatcher w) w (move-event-pnt tc))))
0)
(defmethod process-message (hwnd (msg (eql gfs::+wm-moving+)) wparam lparam)
(declare (ignore wparam lparam))
(let* ((tc (thread-context))
(w (get-widget tc hwnd)))
- (if (and w (event-pre-move (dispatcher w) w (event-time tc)))
+ (if (and w (event-pre-move (dispatcher w) w))
1
0)))
@@ -318,7 +315,7 @@
:height gfs::rcpaint-height))
(let ((gc (make-instance 'gfg:graphics-context :handle (gfs::begin-paint hwnd ps-ptr))))
(unwind-protect
- (event-paint (dispatcher widget) widget (event-time tc) gc rct)
+ (event-paint (dispatcher widget) widget gc rct)
(gfs:dispose gc)
(gfs::end-paint hwnd ps-ptr))))))
(error 'gfs:toolkit-error :detail "no object for hwnd")))
@@ -357,7 +354,7 @@
(let* ((tc (thread-context))
(widget (get-widget tc hwnd)))
(if widget
- (event-focus-loss (dispatcher widget) widget (event-time tc))))
+ (event-focus-loss (dispatcher widget) widget)))
0)
(defmethod process-message (hwnd (msg (eql gfs::+wm-setfocus+)) wparam lparam)
@@ -365,7 +362,7 @@
(let* ((tc (thread-context))
(widget (get-widget tc hwnd)))
(if widget
- (event-focus-gain (dispatcher widget) widget (event-time tc))))
+ (event-focus-gain (dispatcher widget) widget)))
0)
(defmethod process-message (hwnd (msg (eql gfs::+wm-getminmaxinfo+)) wparam lparam)
@@ -407,15 +404,14 @@
(t nil))))
(when w
(outer-size w (size-event-size tc))
- #+gf-debug-widgets (format t "about to call event-resize: ~a~%" hwnd)
- (event-resize (dispatcher w) w (event-time tc) (size-event-size tc) type)))
+ (event-resize (dispatcher w) w (size-event-size tc) type)))
0)
(defmethod process-message (hwnd (msg (eql gfs::+wm-sizing+)) wparam lparam)
(declare (ignore wparam lparam))
(let* ((tc (thread-context))
(w (get-widget tc hwnd)))
- (if (and w (event-pre-resize (dispatcher w) w (event-time tc)))
+ (if (and w (event-pre-resize (dispatcher w) w))
1
0)))
@@ -427,15 +423,15 @@
(gfs::kill-timer hwnd wparam)
(cond
((<= (delay-of timer) 0)
- (event-timer (dispatcher timer) timer (event-time tc))
+ (event-timer (dispatcher timer) timer)
(gfs:dispose timer))
((/= (delay-of timer) (initial-delay-of timer))
(let ((delay (reset-timer-to-delay timer (delay-of timer))))
(setf (slot-value timer 'delay) delay)
(setf (slot-value timer 'initial-delay) delay))
- (event-timer (dispatcher timer) timer (event-time tc)))
+ (event-timer (dispatcher timer) timer))
(t
- (event-timer (dispatcher timer) timer (event-time tc))))))
+ (event-timer (dispatcher timer) timer)))))
0)
;;;
Modified: trunk/src/uitoolkit/widgets/widget.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget.lisp Sun Jul 9 02:35:37 2006
@@ -153,7 +153,7 @@
(defmethod gfs:dispose ((w widget))
(unless (null (dispatcher w))
- (event-dispose (dispatcher w) w (event-time (thread-context))))
+ (event-dispose (dispatcher w) w))
(let ((hwnd (gfs:handle w)))
(if (not (gfs:null-handle-p hwnd))
(if (zerop (gfs::destroy-window hwnd))
Modified: trunk/src/uitoolkit/widgets/window.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/window.lisp (original)
+++ trunk/src/uitoolkit/widgets/window.lisp Sun Jul 9 02:35:37 2006
@@ -180,8 +180,8 @@
(let ((sz (client-size win)))
(perform (layout-of win) win (gfs:size-width sz) (gfs:size-height sz)))))
-(defmethod event-resize ((d event-dispatcher) (win window) time size type)
- (declare (ignorable d time size type))
+(defmethod event-resize ((d event-dispatcher) (win window) size type)
+ (declare (ignore size type))
(unless (null (layout-of win))
(let ((sz (client-size win)))
(perform (layout-of win) win (gfs:size-width sz) (gfs:size-height sz)))))
More information about the Graphic-forms-cvs
mailing list