Author: junrue Date: Fri Sep 1 00:27:49 2006 New Revision: 245 Modified: trunk/docs/manual/event-functions.texinfo trunk/docs/manual/glossary.texinfo trunk/docs/manual/reference.texinfo trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/widgets/button.lisp trunk/src/uitoolkit/widgets/edit.lisp trunk/src/uitoolkit/widgets/event-generics.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/label.lisp trunk/src/uitoolkit/widgets/list-box.lisp trunk/src/uitoolkit/widgets/list-item.lisp trunk/src/uitoolkit/widgets/widget-constants.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp Log: implemented wrappers for list box messages, implemented list-box preferred-size method, some light refactoring of other controls Modified: trunk/docs/manual/event-functions.texinfo ============================================================================== --- trunk/docs/manual/event-functions.texinfo (original) +++ trunk/docs/manual/event-functions.texinfo Fri Sep 1 00:27:49 2006 @@ -37,7 +37,7 @@ @end defun @anchor{event-activate} -@deffn GenericFunction event-activate dispatcher widget +@deffn GenericFunction event-activate @ref{event-dispatcher} @ref{widget} Implement this method to respond to @var{widget} being activated. For a @ref{top-level} @ref{window} or @ref{dialog}, this means that @var{widget} was brought to the foreground and its trim (titlebar and @@ -64,7 +64,7 @@ @end table @end deffn -@deffn GenericFunction event-close dispatcher widget +@deffn GenericFunction event-close @ref{event-dispatcher} @ref{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. @@ -76,7 +76,7 @@ @end deffn @anchor{event-deactivate} -@deffn GenericFunction event-deactivate dispatcher widget +@deffn GenericFunction event-deactivate @ref{event-dispatcher} @ref{widget} Implement this method to respond to @var{widget} being deactivated, meaning that some other object has been made active. This event only applies to @ref{top-level} @ref{window}s or @@ -88,7 +88,21 @@ @end table @end deffn -@deffn GenericFunction event-dispose dispatcher widget +@anchor{event-default-action} +@deffn GenericFunction event-default-action @ref{event-dispatcher} @ref{widget} +Implement this method to respond to a @ref{default action}, for +example when the user double-clicks on a @ref{list-box} @ref{item}, or +presses @sc{enter} while the keyboard focus is in an @ref{edit} +control. +@table @var +@event-dispatcher-arg +@item widget +The @ref{widget} for which the default action was invoked. +@end table +@end deffn + +@anchor{event-dispose} +@deffn GenericFunction event-dispose @ref{event-dispatcher} @ref{widget} Implement this method to respond to @var{widget} being disposed (explicitly via @ref{dispose}; this event is not associated with garbage collection). This event function is called while the contents of @var{widget} are still @@ -101,7 +115,7 @@ @end deffn @anchor{event-focus-gain} -@deffn GenericFunction event-focus-gain dispatcher widget +@deffn GenericFunction event-focus-gain @ref{event-dispatcher} @ref{widget} Implement this method to respond to @var{widget} gaining keyboard focus. @table @var @event-dispatcher-arg @@ -111,7 +125,7 @@ @end deffn @anchor{event-focus-loss} -@deffn GenericFunction event-focus-loss dispatcher widget +@deffn GenericFunction event-focus-loss @ref{event-dispatcher} @ref{widget} Implement this method to respond to @var{widget} losing keyboard focus. @table @var @event-dispatcher-arg @@ -120,7 +134,7 @@ @end table @end deffn -@deffn GenericFunction event-key-down dispatcher widget keycode char +@deffn GenericFunction event-key-down @ref{event-dispatcher} @ref{widget} keycode char Implement this method to respond to a key being pressed within @var{widget}. @table @var @@ -135,7 +149,7 @@ @end table @end deffn -@deffn GenericFunction event-key-up dispatcher widget keycode char +@deffn GenericFunction event-key-up @ref{event-dispatcher} @ref{widget} keycode char Implement this method to respond to a key being released within @var{widget}. @table @var @event-dispatcher-arg @@ -150,7 +164,7 @@ @end deffn @anchor{event-modify} -@deffn GenericFunction event-modify dispatcher widget +@deffn GenericFunction event-modify @ref{event-dispatcher} @ref{widget} Implement this method to respond to changes due to user input within @ref{widget}, for example when the user types text inside an @ref{edit} @ref{control}. @@ -161,7 +175,7 @@ @end table @end deffn -@deffn GenericFunction event-mouse-double dispatcher widget point button +@deffn GenericFunction event-mouse-double @ref{event-dispatcher} @ref{widget} @ref{point} button Implement this method to respond to a mouse button double-click within @var{widget}. @table @var @event-dispatcher-arg @@ -172,7 +186,7 @@ @end table @end deffn -@deffn GenericFunction event-mouse-down dispatcher widget point button +@deffn GenericFunction event-mouse-down @ref{event-dispatcher} @ref{widget} @ref{point} button Implement this method to respond to a mouse button click within @var{widget}. @table @var @event-dispatcher-arg @@ -183,7 +197,7 @@ @end table @end deffn -@deffn GenericFunction event-mouse-move dispatcher widget point button +@deffn GenericFunction event-mouse-move @ref{event-dispatcher} @ref{widget} @ref{point} button Implement this method to respond to a mouse move event within @var{widget}. @table @var @event-dispatcher-arg @@ -194,7 +208,7 @@ @end table @end deffn -@deffn GenericFunction event-mouse-up dispatcher widget point button +@deffn GenericFunction event-mouse-up @ref{event-dispatcher} @ref{widget} @ref{point} button Implement this method to respond to a mouse button being released within @var{widget}. @table @var @@ -206,7 +220,7 @@ @end table @end deffn -@deffn GenericFunction event-move dispatcher widget point +@deffn GenericFunction event-move @ref{event-dispatcher} @ref{widget} @ref{point} Implement this method to respond to @var{widget} being moved within its @ref{parent}'s coordinate system. @table @var @@ -219,7 +233,7 @@ @end deffn @anchor{event-paint} -@deffn GenericFunction event-paint dispatcher widget gc rect +@deffn GenericFunction event-paint @ref{event-dispatcher} @ref{widget} @ref{graphics-context} @ref{rectangle} Implement this method to respond to system requests to repaint @var{widget}. @table @var @event-dispatcher-arg @@ -233,7 +247,7 @@ @end table @end deffn -@deffn GenericFunction event-resize dispatcher widget size type +@deffn GenericFunction event-resize @ref{event-dispatcher} @ref{widget} size type Implement this method to respond to @var{widget} being resized. @table @var @event-dispatcher-arg @@ -258,7 +272,7 @@ @end deffn @anchor{event-select} -@deffn GenericFunction event-select dispatcher widget +@deffn GenericFunction event-select @ref{event-dispatcher} @ref{widget} Implement this method to handle notification that @var{widget} (or some @ref{item} within @var{widget}) has been clicked on by the user in order to invoke some action. Modified: trunk/docs/manual/glossary.texinfo ============================================================================== --- trunk/docs/manual/glossary.texinfo (original) +++ trunk/docs/manual/glossary.texinfo Fri Sep 1 00:27:49 2006 @@ -40,6 +40,17 @@ accept user input and possibly generate notification events based on such input.@* +@item default action +@anchor{default action} +@cindex default action +Conceptually, a default action is a secondary event initiated by user +input that is a logical follow-up to a previous event. Examples of +such user gestures include double-clicking an item in a list box +control, or pressing @sc{enter} when an edit control has the keyboard +focus. The response to a default action makes use of context +established by the preceding event (e.g., the selection set by an +initial click becomes the context for the double-click response).@* + @item dialog @cindex dialog A dialog is a mechanism for collecting user input or showing Modified: trunk/docs/manual/reference.texinfo ============================================================================== --- trunk/docs/manual/reference.texinfo (original) +++ trunk/docs/manual/reference.texinfo Fri Sep 1 00:27:49 2006 @@ -70,7 +70,7 @@ @end macro @macro event-dispatcher-arg -@item dispatcher +@item event-dispatcher The @ref{event-dispatcher} to process this event. @end macro Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Fri Sep 1 00:27:49 2006 @@ -556,6 +556,13 @@ (defconstant +lb-multipleaddstring+ #x01B1) (defconstant +lb-getlistboxinfo+ #x01B2) +(defconstant +lbn-errspace+ -2) +(defconstant +lbn-selchange+ 1) +(defconstant +lbn-dblclk+ 2) +(defconstant +lbn-selcancel+ 3) +(defconstant +lbn-setfocus+ 4) +(defconstant +lbn-killfocus+ 5) + (defconstant +lbs-notify+ #x0001) (defconstant +lbs-sort+ #x0002) (defconstant +lbs-noredraw+ #x0004) Modified: trunk/src/uitoolkit/widgets/button.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/button.lisp (original) +++ trunk/src/uitoolkit/widgets/button.lisp Fri Sep 1 00:27:49 2006 @@ -97,7 +97,7 @@ (init-control self)) (defmethod preferred-size ((self button) width-hint height-hint) - (let ((text-size (widget-text-size self gfs::+dt-singleline+)) + (let ((text-size (widget-text-size self #'text gfs::+dt-singleline+)) (size (gfs:make-size)) (b-width (* (border-width self) 2)) (need-cb-size (intersection '(:check-box :radio-button :tri-state) (style-of self))) Modified: trunk/src/uitoolkit/widgets/edit.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/edit.lisp (original) +++ trunk/src/uitoolkit/widgets/edit.lisp Fri Sep 1 00:27:49 2006 @@ -115,7 +115,7 @@ (gfs::send-message (gfs:handle self) gfs::+wm-paste+ 0 0)) (defmethod preferred-size ((self edit) width-hint height-hint) - (let ((text-size (widget-text-size self (logior gfs::+dt-editcontrol+ gfs::+dt-noprefix+))) + (let ((text-size (widget-text-size self #'text (logior gfs::+dt-editcontrol+ gfs::+dt-noprefix+))) (size (gfs:make-size)) (b-width (* (border-width self) 2))) (if (>= width-hint 0) Modified: trunk/src/uitoolkit/widgets/event-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/event-generics.lisp Fri Sep 1 00:27:49 2006 @@ -58,6 +58,11 @@ (:method (dispatcher widget) (declare (ignorable dispatcher widget)))) +(defgeneric event-default-action (dispatcher widget) + (:documentation "Implement this to respond to the widget-specific default action.") + (:method (dispatcher widget) + (declare (ignorable dispatcher widget)))) + (defgeneric event-deiconify (dispatcher widget) (:documentation "Implement this to respond to an object being deiconified.") (:method (dispatcher widget) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Fri Sep 1 00:27:49 2006 @@ -120,10 +120,13 @@ (defun dispatch-notification (widget wparam-hi) (let ((disp (dispatcher widget))) (case wparam-hi - (0 (event-select disp widget)) - (#.gfs::+en-killfocus+ (event-focus-loss disp widget)) - (#.gfs::+en-setfocus+ (event-focus-gain disp widget)) - (#.gfs::+en-update+ (event-modify disp widget))))) + (0 (event-select disp widget)) + (#.gfs::+en-killfocus+ (event-focus-loss disp widget)) + (#.gfs::+en-setfocus+ (event-focus-gain disp widget)) + (#.gfs::+en-update+ (event-modify disp widget)) + (#.gfs::+lbn-dblclk+ (event-default-action disp widget)) + (#.gfs::+lbn-killfocus+ (event-focus-loss disp widget)) + (#.gfs::+lbn-setfocus+ (event-focus-gain disp widget))))) (defun process-ctlcolor-message (wparam lparam) (let* ((widget (get-widget (thread-context) (cffi:make-pointer lparam))) Modified: trunk/src/uitoolkit/widgets/label.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/label.lisp (original) +++ trunk/src/uitoolkit/widgets/label.lisp Fri Sep 1 00:27:49 2006 @@ -178,7 +178,7 @@ (size nil)) (if (and (= (logand bits gfs::+ss-left+) gfs::+ss-left+) (> width-hint 0)) (setf flags (logior flags gfs::+dt-wordbreak+))) - (setf size (widget-text-size self flags)) + (setf size (widget-text-size self #'text flags)) (if (>= width-hint 0) (setf (gfs:size-width size) width-hint) (incf (gfs:size-width size) b-width)) Modified: trunk/src/uitoolkit/widgets/list-box.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/list-box.lisp (original) +++ trunk/src/uitoolkit/widgets/list-box.lisp Fri Sep 1 00:27:49 2006 @@ -34,17 +34,6 @@ (in-package :graphic-forms.uitoolkit.widgets) ;;; -;;; helper functions -;;; - -(defun insert-list-item (hwnd index label hbmp) - (declare (ignore hbmp)) ; FIXME: re-enable when we support images in list-box - (let ((text (or label ""))) - (cffi:with-foreign-string (str-ptr text) - (if (< (gfs::send-message hwnd gfs::+lb-insertstring+ index str-ptr) 0) - (error 'gfs:win32-error :detail "LB_INSERTSTRING failed"))))) - -;;; ;;; methods ;;; @@ -54,7 +43,7 @@ (hcontrol (gfs:handle self)) (text (call-text-provider self thing)) (item (create-item-with-callback hcontrol 'list-item thing disp))) - (insert-list-item hcontrol -1 text (cffi:null-pointer)) + (lb-insert-item hcontrol -1 text (cffi:null-pointer)) (put-item tc item) (vector-push-extend item (items-of self)) item)) @@ -103,16 +92,41 @@ (setf (slot-value self 'gfs:handle) hwnd))) (init-control self) (if (and estimated-count (> estimated-count 0)) - (gfs::send-message (gfs:handle self) - gfs::+lb-initstorage+ - estimated-count - (* estimated-count +estimated-text-size+))) + (lb-init-storage (gfs:handle self) estimated-count (* estimated-count +estimated-text-size+))) (update-from-items self)) (defmethod (setf items-of) :after (new-items (self list-box)) (declare (ignore new-items)) (update-from-items self)) +(defmethod preferred-size ((self list-box) width-hint height-hint) + (let ((hwnd (gfs:handle self)) + (size (gfs:make-size :width width-hint :height height-hint)) + (b-width (* (border-width self) 2))) + (flet ((item-text (index) + (lb-item-text hwnd index (1+ (lb-item-text-length hwnd index))))) + (when (< width-hint 0) + (setf (gfs:size-width size) + (loop for index to (1- (lb-item-count hwnd)) + with dt-flags = (logior gfs::+dt-singleline+ gfs::+dt-noprefix+) + maximizing (widget-text-size self + (lambda () (item-text index)) + dt-flags) + into max-width + finally (return max-width))))) + (if (zerop (gfs:size-width size)) + (setf (gfs:size-width size) +default-widget-width+) + (incf (gfs:size-width size) b-width)) + (when (< height-hint 0) + (setf (gfs:size-height size) (* (lb-item-count hwnd) (lb-item-height hwnd)))) + (if (zerop (gfs:size-height size)) + (setf (gfs:size-height size) +default-widget-height+) + (incf (gfs:size-height size) b-width)) + (if (= (logand (gfs::get-window-long hwnd gfs::+gwl-style+) gfs::+ws-vscroll+) + gfs::+ws-vscroll+) + (incf (gfs:size-width size) (vertical-scrollbar-width))) + size)) + (defmethod update-from-items ((self list-box)) (let ((sort-func (sort-predicate-of self)) (items (items-of self)) @@ -123,7 +137,7 @@ (enable-redraw self nil) (unwind-protect (progn - (gfs::send-message hwnd gfs::+lb-resetcontent+ 0 0) + (lb-clear-content hwnd) (loop for item in items for index = 0 then (1+ index) do (progn Modified: trunk/src/uitoolkit/widgets/list-item.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/list-item.lisp (original) +++ trunk/src/uitoolkit/widgets/list-item.lisp Fri Sep 1 00:27:49 2006 @@ -34,6 +34,55 @@ (in-package :graphic-forms.uitoolkit.widgets) ;;; +;;; helper functions +;;; + +(defun lb-init-storage (hwnd item-count total-bytes) + (gfs::send-message hwnd gfs::+lb-initstorage+ item-count total-bytes)) + +(defun lb-clear-content (hwnd) + (gfs::send-message hwnd gfs::+lb-resetcontent+ 0 0)) + +(defun lb-insert-item (hwnd index label hbmp) + (declare (ignore hbmp)) ; FIXME: re-enable when we support images in list-box + (let ((text (or label ""))) + (cffi:with-foreign-string (str-ptr text) + (if (< (gfs::send-message hwnd gfs::+lb-insertstring+ index str-ptr) 0) + (error 'gfs:win32-error :detail "LB_INSERTSTRING failed"))))) + +(defun lb-width (hwnd) + (let ((width (gfs::send-message hwnd gfs::+lb-gethorizontalextent+ 0 0))) + (if (< width 0) + (error 'gfs:win32-error :detail "LB_GETHORIZONTALEXTENT failed")) + width)) + +(defun lb-item-count (hwnd) + (let ((count (gfs::send-message hwnd gfs::+lb-getcount+ 0 0))) + (if (< count 0) + (error 'gfs:win32-error :detail "LB_GETCOUNT failed")) + count)) + +(defun lb-item-height (hwnd) + (let ((height (gfs::send-message hwnd gfs::+lb-getitemheight+ 0 0))) + (if (< height 0) + (error 'gfs:win32-error :detail "LB_GETITEMHEIGHT failed")) + height)) + +(defun lb-item-text (hwnd index &optional buffer-size) + (if (or (null buffer-size) (<= buffer-size 0)) + (setf buffer-size (lb-item-text-length hwnd index))) + (cffi:with-foreign-pointer-as-string (str-ptr (1+ buffer-size)) + (if (< (gfs::send-message hwnd gfs::+lb-gettext+ index (cffi:pointer-address str-ptr)) 0) + (error 'gfs:win32-error :detail "LB_GETTEXT failed")) + (cffi:foreign-string-to-lisp str-ptr))) + +(defun lb-item-text-length (hwnd index) + (let ((length (gfs::send-message hwnd gfs::+lb-gettextlen+ index 0))) + (if (< length 0) + (error 'gfs:win32-error :detail "LB_GETTEXTLEN failed")) + length)) + +;;; ;;; methods ;;; Modified: trunk/src/uitoolkit/widgets/widget-constants.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-constants.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-constants.lisp Fri Sep 1 00:27:49 2006 @@ -95,5 +95,7 @@ (defconstant +vk-right-alt+ #xA5) (eval-when (:compile-toplevel :load-toplevel :execute) - (defconstant +default-child-style+ (logior gfs::+ws-child+ gfs::+ws-visible+)) - (defconstant +estimated-text-size+ 32)) ;; bytes + (defconstant +default-child-style+ (logior gfs::+ws-child+ gfs::+ws-visible+)) + (defconstant +default-widget-width+ 64) + (defconstant +default-widget-height+ 64) + (defconstant +estimated-text-size+ 32)) ; bytes Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Fri Sep 1 00:27:49 2006 @@ -190,18 +190,30 @@ (setf (gfs:size-width sz) (- gfs::windowright gfs::windowleft)) (setf (gfs:size-height sz) (- gfs::windowbottom gfs::windowtop))))) +(defun horizontal-scrollbar-height () + (gfs::get-system-metrics gfs::+sm-cyhscroll+)) + +(defun horizontal-scrollbar-arrow-width () + (gfs::get-system-metrics gfs::+sm-cxhscroll+)) + +(defun vertical-scrollbar-arrow-height () + (gfs::get-system-metrics gfs::+sm-cyvscroll+)) + +(defun vertical-scrollbar-width () + (gfs::get-system-metrics gfs::+sm-cxvscroll+)) + (defun set-widget-text (w str) (if (gfs:disposed-p w) (error 'gfs:disposed-error)) (gfs::set-window-text (gfs:handle w) str)) -(defun widget-text-size (widget dt-flags) +(defun widget-text-size (widget text-func dt-flags) (let ((hwnd (gfs:handle widget)) (hfont nil)) (gfs::with-retrieved-dc (hwnd hdc) (setf hfont (cffi:make-pointer (gfs::send-message hwnd gfs::+wm-getfont+ 0 0))) (gfs::with-hfont-selected (hdc hfont) - (gfg::text-bounds hdc (text widget) dt-flags 0))))) + (gfg::text-bounds hdc (funcall text-func widget) dt-flags 0))))) ;;; ;;; This algorithm adapted from the calculate_best_bounds() @@ -233,8 +245,8 @@ ;; use scrollbar system metric values as a rough approximation ;; (return-from check-box-size - (gfs:make-size :width (gfs::get-system-metrics gfs::+sm-cxvscroll+) - :height (gfs::get-system-metrics gfs::+sm-cyvscroll+)))) + (gfs:make-size :width (vertical-scrollbar-width) + :height (vertical-scrollbar-arrow-height)))) (unwind-protect (cffi:with-foreign-object (bm-ptr 'gfs::bitmap)