[graphic-forms-cvs] r245 - in trunk: docs/manual src/uitoolkit/system src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Fri Sep 1 04:27:51 UTC 2006
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}
- at deffn GenericFunction event-activate dispatcher widget
+ at 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
- at deffn GenericFunction event-close dispatcher widget
+ at 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}
- at deffn GenericFunction event-deactivate dispatcher widget
+ at 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
- at deffn GenericFunction event-dispose dispatcher widget
+ at anchor{event-default-action}
+ at 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.
+ at table @var
+ at event-dispatcher-arg
+ at item widget
+The @ref{widget} for which the default action was invoked.
+ at end table
+ at end deffn
+
+ at anchor{event-dispose}
+ at 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}
- at deffn GenericFunction event-focus-gain dispatcher widget
+ at 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}
- at deffn GenericFunction event-focus-loss dispatcher widget
+ at 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
- at deffn GenericFunction event-key-down dispatcher widget keycode char
+ at 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
- at deffn GenericFunction event-key-up dispatcher widget keycode char
+ at 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}
- at deffn GenericFunction event-modify dispatcher widget
+ at 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
- at deffn GenericFunction event-mouse-double dispatcher widget point button
+ at 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
- at deffn GenericFunction event-mouse-down dispatcher widget point button
+ at 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
- at deffn GenericFunction event-mouse-move dispatcher widget point button
+ at 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
- at deffn GenericFunction event-mouse-up dispatcher widget point button
+ at 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
- at deffn GenericFunction event-move dispatcher widget point
+ at 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}
- at deffn GenericFunction event-paint dispatcher widget gc rect
+ at 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
- at deffn GenericFunction event-resize dispatcher widget size type
+ at 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}
- at deffn GenericFunction event-select dispatcher widget
+ at 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.@*
+ at item default action
+ at anchor{default action}
+ at 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
- at item dispatcher
+ at 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)
More information about the Graphic-forms-cvs
mailing list