graphic-forms-cvs

graphic-forms-cvs@common-lisp.net

461 discussions

[graphic-forms-cvs] r258 - in trunk: docs/manual src/tests/uitoolkit src/uitoolkit/system src/uitoolkit/widgets
by junrue＠common-lisp.net 12 Sep '06

12 Sep '06

Author: junrue Date: Mon Sep 11 23:04:31 2006 New Revision: 258 Modified: trunk/docs/manual/event-functions.texinfo trunk/docs/manual/reference.texinfo trunk/docs/manual/widget-types.texinfo trunk/src/tests/uitoolkit/widget-tester.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/widgets/event-generics.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/list-box.lisp Log: implemented and documented event-scroll generic function as first stage of implementing general scrolling support; renamed list-box style :vertical-scrollbar to :scrollbar-always to reflect that this is a policy style Modified: trunk/docs/manual/event-functions.texinfo ============================================================================== --- trunk/docs/manual/event-functions.texinfo (original) +++ trunk/docs/manual/event-functions.texinfo Mon Sep 11 23:04:31 2006 @@ -271,6 +271,62 @@ @end table @end deffn +@anchor{event-scroll} +@deffn GenericFunction event-scroll @ref{event-dispatcher} @ref{widget} axis detail +Implement this method to handle scrolling notifications for @var{widget}. +@table @var +@event-dispatcher-arg +@item widget +The @ref{widget} that was scrolled. +@item axis +The scrolling orientation, identified by one of the following +keyword symbols:@*@* +@table @code +@item :horizontal +Indicates that scrolling is occurring in the horizontal axis. +@item :vertical +Indicates that scrolling is occurring in the vertical axis. +@end table +@item detail +The specific scrolling request, identified by one of the +following keyword symbols:@*@* +@table @code +@item :end +The bottom or right-most content is revealed. +@item :page-back +The viewport is moved backward towards content start by +an amount equal to the viewport's height or width, or +the amount remaining between the viewport's origin +and the start, whichever is smaller. +@item :page-forward +The viewport is moved forward towards content end by +an amount equal to the viewport's height or width, or +the amount remaining between the viewport's origin +and the end, whichever is smaller. +@item :start +The viewport is moved such that the top or left-most +content edge is revealed. +@item :step-back +The viewport is moved backward towards content start by +an application-defined increment, or the amount +remaining between the viewport's origin and the start, +whichever is smaller. +@item :step-forward +The viewport is moved forward towards content end by an +application-defined increment, or the amount +remaining between the viewport's origina and the end, +whichever is smaller. +@item :thumb-position +Indicates an absolute position to which the viewport origin +is moved, as when the user releases the mouse button from a +scrollbar thumb. +@item :thumb-track +Indicates that the user is adjusting the position of the +viewport continuously, as when dragging a scrollbar thumb. +@end table +@end table +@end deffn + @anchor{event-select} @deffn GenericFunction event-select @ref{event-dispatcher} @ref{widget} Implement this method to handle notification that @var{widget} (or some Modified: trunk/docs/manual/reference.texinfo ============================================================================== --- trunk/docs/manual/reference.texinfo (original) +++ trunk/docs/manual/reference.texinfo Mon Sep 11 23:04:31 2006 @@ -136,6 +136,27 @@ @end deftp @end macro +@macro begin-primary-style-choices{defaultdesc} +The @code{:style} initarg is a list of keywords that define the +look-and-feel of the widget being created. \defaultdesc\ +Applications may choose from one of the following primary styles: +@table @code +@end macro + +@macro end-primary-style-choices +@end table +@end macro + +@macro begin-optional-style-choices +One or more of the following optional style keyword(s) may be +specified in the style keyword list: +@table @code +@end macro + +@macro end-optional-style-choices +@end table +@end macro + @c ==========================End Macros ============================= @copying Modified: trunk/docs/manual/widget-types.texinfo ============================================================================== --- trunk/docs/manual/widget-types.texinfo (original) +++ trunk/docs/manual/widget-types.texinfo Mon Sep 11 23:04:31 2006 @@ -185,7 +185,8 @@ @end deffn @control-parent-initarg{button} @deffn Initarg :style -@table @code +@begin-primary-style-choices{The @code{:push-button} style is the +default.} @item :cancel-button Placing a @code{:cancel-button} in a @ref{dialog} enables the @sc{escape} key @ref{accelerator} for dismissing the dialog. This @@ -218,7 +219,7 @@ This style specifies a control that looks similar to a @code{:check-box}, but the box can be grayed as well as checked or cleared. The grayed look is used to indicate an undetermined state. -@end table +@end-primary-style-choices @end deffn @deffn Initarg :text Supplies the text for the button label. @@ -279,7 +280,7 @@ @control-callback-initarg{edit,event-modify} @control-parent-initarg{edit} @deffn Initarg :style -@table @code +@begin-optional-style-choices @item :auto-hscroll Specifies that the edit control will scroll text content to the right by 10 characters when the user types a character at the end @@ -323,7 +324,7 @@ style is also specified. Without this style, within a dialog the act of typing @sc{enter} has the same effect as pressing the dialog's default button. -@end table +@end-optional-style-choices @end deffn @deffn Initarg :text Supplies the initial text for the edit control. @@ -394,7 +395,8 @@ @end deffn @control-parent-initarg{list-box} @deffn Initarg :style -@table @code +@begin-primary-style-choices{By default\, a single item may be +selected at a time.} @item :extend-select This style keyword causes the list-box to allow multiple items to be selected by use of the @sc{shift} key and the mouse or special @@ -405,20 +407,19 @@ @item :no-select This style keyword means that the list-box will display items but not allow any selections. -@item :single-select -This style keyword means that the list-box only allows one item at a -time to be selected. This is the default selection style. +@end-primary-style-choices +@begin-optional-style-choices +@item :scrollbar-always +This style keyword causes the list-box to show a disabled vertical +scrollbar when it does not contain enough items to scroll. Otherwise +in such a case, the scrollbar will be hidden until needed. @item :tab-stops This style keyword configures the list-box to to expand tab characters when rendering item strings. @item :want-keys This style keyword allows the application to perform special processing when the list-box has focus and the user presses a key. -@item :want-scrollbar -This style keyword causes the list-box to show a disabled vertical -scrollbar when it does not contain enough items to scroll. Otherwise -in such a case, the scrollbar will be hidden. -@end table +@end-optional-style-choices @end deffn @end-control-subclass @@ -453,8 +454,8 @@ @ref{window} or a dialog. @end deffn @deffn Initarg :style -This initarg accepts a list of keyword symbols: -@table @code +@begin-primary-style-choices{By default\, the dialog does not +show the custom colors interface.} @item :allow-custom-colors This configures the dialog to enable the Define Custom Color button, which when clicked reveals additional controls for @@ -462,7 +463,7 @@ @item :display-solid-only This configures the dialog to only display solid colors in the set of basic colors. -@end table +@end-primary-style-choices @end deffn @end deftp @@ -484,7 +485,7 @@ @sc{nil} for the owner. @end deffn @deffn Initarg :style -@table @code +@begin-primary-style-choices{} @item :application-modal Specifies that the dialog is @emph{modal} with respect to all @ref{top-level} windows and @ref{dialog}s created by the application @@ -498,7 +499,7 @@ Specifies that the dialog is @emph{modal} only in relation to its @ref{owner} (which could be a window or another dialog). This style is the default if no style keywords are specified. -@end table +@end-primary-style-choices @end deffn @deffn Initarg :text Specifies the dialog's title. @@ -566,31 +567,32 @@ @ref{window} or a @ref{dialog}. @end deffn @deffn Initarg :style -This initarg accepts a list of keyword symbols: -@table @code +@begin-primary-style-choices{} +@item :open +This configures the dialog to be used to select one or more files +for loading data. +@item :save +This configures the dialog to be used to specify a destination file +for data to be saved. +@end-primary-style-choices +@begin-optional-style-choices @item :add-to-recent This enables the system to add a link to the selected file in the directory that contains the user's most recently used documents. @item :multiple-select This configures the dialog to accept multiple selections. -@item :open -This configures the dialog to be used to select one or more files -for loading data. @item :path-must-exist This keyword enables a validation check that constrains the user's selection to file paths that actually exist. A warning dialog will be displayed if the user supplies a non-existent path. -@item :save -This configures the dialog to be used to specify a destination file -for data to be saved. @item :show-hidden This keyword enables the dialog to display files marked @sc{hidden} by the system. @strong{Note:} files marked both @sc{hidden} and @sc{system} will not be displayed in any case. Also, be aware that using this keyword effectively overrides the user's preference settings. -@end table +@end-optional-style-choices @end deffn @deffn Initarg :text This initarg accepts a string that will become the title of the file @@ -636,8 +638,7 @@ @ref{window} or a @ref{dialog}. @end deffn @deffn Initarg :style -This initarg accepts a list of keyword symbols: -@table @code +@begin-primary-style-choices{} @item :all-fonts This is a convenience style, used by default if no other font criteria are specified, that enables the dialog to offer all @@ -659,7 +660,7 @@ Enables the dialog to offer the intersection of the sets of fonts available on the screen and the printer associated with the graphics-context specified by the @code{:gc} initarg. -@end table +@end-primary-style-choices @end deffn @end deftp @@ -728,8 +729,9 @@ @anchor{top-level} @deftp Class top-level Base class for @ref{window}s that are self-contained and parented to -the @ref{root-window}. Except for the @code{:palette} style, they are -normally resizable and have title bars (also called 'captions'). +the @ref{root-window}. Except when created with the @code{:borderless} +or @code{:palette} styles, they are resizable and have title bars +(also called @samp{captions}). @deffn Initarg :maximum-size Sets the maximum @ref{size} to which the user may adjust the boundaries of the window. @@ -739,10 +741,7 @@ boundaries of the window. @end deffn @deffn Initarg :style -The @code{:style} initarg is a list of keywords that define the overall -look-and-feel of the window being created. Applications may choose -from one of the following primary styles: -@table @code +@begin-primary-style-choices{} @item :borderless Specifies a window with a one-pixel border (so not really @emph{borderless} in the strictest sense); no frame icon, system menu, minimize/maximize @@ -764,13 +763,12 @@ and minimize/maximize buttons; this window type is resizable; it differs from the @code{:frame} style in that the system paints the background using the @sc{color_appworkspace} Win32 color scheme. -@end table -The following style keyword(s) may also be included: -@table @code +@end-primary-style-choices +@begin-optional-style-choices @item :keyboard-navigation Enables keyboard traversal of controls within the @code{window} as if it were a @ref{dialog}. -@end table +@end-optional-style-choices @end deffn @end deftp Modified: trunk/src/tests/uitoolkit/widget-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/widget-tester.lisp (original) +++ trunk/src/tests/uitoolkit/widget-tester.lisp Mon Sep 11 23:04:31 2006 @@ -191,7 +191,7 @@ (make-instance 'gfw:label :text "Extended Select:" :parent lb2-panel) (setf lb2 (make-instance 'gfw:list-box :parent lb2-panel :callback lb2-callback - :style '(:extend-select :want-scrollbar) + :style '(:extend-select :scrollbar-always) :items (subseq *list-box-test-data* 4))) (gfw:pack lb2-panel) Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Mon Sep 11 23:04:31 2006 @@ -834,6 +834,22 @@ (defconstant +ps-geometric+ #x00010000) (defconstant +ps-type-mask+ #x000f0000) +(defconstant +sb-lineup+ 0) +(defconstant +sb-lineleft+ 0) +(defconstant +sb-linedown+ 1) +(defconstant +sb-lineright+ 1) +(defconstant +sb-pageup+ 2) +(defconstant +sb-pageleft+ 2) +(defconstant +sb-pagedown+ 3) +(defconstant +sb-pageright+ 3) +(defconstant +sb-thumbposition+ 4) +(defconstant +sb-thumbtrack+ 5) +(defconstant +sb-top+ 6) +(defconstant +sb-left+ 6) +(defconstant +sb-bottom+ 7) +(defconstant +sb-right+ 7) +(defconstant +sb-endscroll+ 8) + (defconstant +size-restored+ 0) (defconstant +size-minimized+ 1) (defconstant +size-maximized+ 2) Modified: trunk/src/uitoolkit/widgets/event-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/event-generics.lisp Mon Sep 11 23:04:31 2006 @@ -174,10 +174,15 @@ (declare (ignorable dispatcher widget)))) (defgeneric event-resize (dispatcher widget size type) - (:documentation "Implement this to respond to an object being resized.") + (:documentation "Implement this to respond to widget being resized.") (:method (dispatcher widget size type) (declare (ignorable dispatcher widget size type)))) +(defgeneric event-scroll (dispatcher widget axis detail) + (:documentation "Implement this to respond to scrolling within widget.") + (:method (dispatcher widget axis detail) + (declare (ignorable dispatcher widget axis detail)))) + (defgeneric event-select (dispatcher item) (:documentation "Implement this to respond to an object (or item within) being selected.") (:method (dispatcher item) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Mon Sep 11 23:04:31 2006 @@ -117,7 +117,7 @@ (cffi:pointer-address (cffi:get-callback 'subclassing_wndproc)))) (error 'gfs:win32-error :detail "set-window-long failed"))) -(defun dispatch-notification (widget wparam-hi) +(defun dispatch-control-notification (widget wparam-hi) (let ((disp (dispatcher widget))) (case wparam-hi (0 (event-select disp widget)) @@ -143,6 +143,24 @@ (setf ret-val (cffi:pointer-address (brush-handle-of widget)))) ret-val)) +(defun dispatch-scroll-notification (widget axis wparam-hi) + (let ((disp (dispatcher widget))) + (case wparam-hi + (#.gfs::+sb-top+ (event-scroll disp widget axis :start)) +; (#.gfs::+sb-left+ (event-scroll disp widget axis :start)) + (#.gfs::+sb-bottom+ (event-scroll disp widget axis :end)) +; (#.gfs::+sb-right+ (event-scroll disp widget axis :end)) + (#.gfs::+sb-lineup+ (event-scroll disp widget axis :step-back)) +; (#.gfs::+sb-lineleft+ (event-scroll disp widget axis :step-back)) + (#.gfs::+sb-linedown+ (event-scroll disp widget axis :step-forward)) +; (#.gfs::+sb-lineright+ (event-scroll disp widget axis :step-forward)) + (#.gfs::+sb-pageup+ (event-scroll disp widget axis :page-back)) +; (#.gfs::+sb-pageleft+ (event-scroll disp widget axis :page-back)) + (#.gfs::+sb-pagedown+ (event-scroll disp widget axis :page-forward)) +; (#.gfs::+sb-pageright+ (event-scroll disp widget axis :page-forward)) + (#.gfs::+sb-thumbposition+ (event-scroll disp widget axis :thumb-position)) + (#.gfs::+sb-thumbtrack+ (event-scroll disp widget axis :thumb-track))))) + (defun obtain-event-time () (gfs::get-message-time)) @@ -191,7 +209,7 @@ (event-select (dispatcher item) item)))) (let ((widget (get-widget tc (cffi:make-pointer lparam)))) (when (and widget (dispatcher widget)) - (dispatch-notification widget wparam-hi)))) + (dispatch-control-notification widget wparam-hi)))) (warn 'gfs:toolkit-warning :detail "no object for hwnd"))) 0) @@ -329,10 +347,23 @@ 1 0))) +(defmethod process-message (hwnd (msg (eql gfs::+wm-hscroll+)) wparam lparam) + (declare (ignore lparam)) + (let ((widget (get-widget (thread-context) hwnd))) + (if widget + (dispatch-scroll-notification widget :horizontal (hi-word wparam)))) + 0) + +(defmethod process-message (hwnd (msg (eql gfs::+wm-vscroll+)) wparam lparam) + (declare (ignore lparam)) + (let ((widget (get-widget (thread-context) hwnd))) + (if widget + (dispatch-scroll-notification widget :vertical (hi-word wparam)))) + 0) + (defmethod process-message (hwnd (msg (eql gfs::+wm-paint+)) wparam lparam) (declare (ignore wparam lparam)) - (let* ((tc (thread-context)) - (widget (get-widget tc hwnd))) + (let ((widget (get-widget (thread-context) hwnd))) (if widget (let ((rct (gfs:make-rectangle))) (cffi:with-foreign-object (ps-ptr 'gfs::paintstruct) Modified: trunk/src/uitoolkit/widgets/list-box.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/list-box.lisp (original) +++ trunk/src/uitoolkit/widgets/list-box.lisp Mon Sep 11 23:04:31 2006 @@ -189,16 +189,16 @@ do (ecase sym ;; primary list-box styles ;; - (:extend-select (setf std-flags (lb-extend-select-flags std-flags))) - (:multiple-select (setf std-flags (lb-multi-select-flags std-flags))) - (:no-select (setf std-flags (lb-no-select-flags std-flags))) - (:single-select (setf std-flags (lb-single-select-flags std-flags))) + (:extend-select (setf std-flags (lb-extend-select-flags std-flags))) + (:multiple-select (setf std-flags (lb-multi-select-flags std-flags))) + (:no-select (setf std-flags (lb-no-select-flags std-flags))) + (:single-select (setf std-flags (lb-single-select-flags std-flags))) ;; styles that can be combined ;; - (:tab-stops (setf std-flags (logior std-flags gfs::+lbs-usetabstops+))) - (:want-keys (setf std-flags (logior std-flags gfs::+lbs-wantkeyboardinput+))) - (:want-scrollbar (setf std-flags (logior std-flags gfs::+lbs-disablenoscroll+))))) + (:tab-stops (setf std-flags (logior std-flags gfs::+lbs-usetabstops+))) + (:scrollbar-always (setf std-flags (logior std-flags gfs::+lbs-disablenoscroll+))) + (:want-keys (setf std-flags (logior std-flags gfs::+lbs-wantkeyboardinput+))))) (values std-flags 0))) (defmethod delete-all ((self list-box))

1 0

[graphic-forms-cvs] r257 - in trunk: docs/manual src/uitoolkit/graphics src/uitoolkit/system src/uitoolkit/widgets
by junrue＠common-lisp.net 11 Sep '06

11 Sep '06

Author: junrue Date: Mon Sep 11 16:30:56 2006 New Revision: 257 Modified: trunk/docs/manual/event-functions.texinfo trunk/src/uitoolkit/graphics/graphics-context.lisp trunk/src/uitoolkit/system/system-utils.lisp trunk/src/uitoolkit/widgets/window.lisp Log: account for menu wrapping in window compute-outer-size Modified: trunk/docs/manual/event-functions.texinfo ============================================================================== --- trunk/docs/manual/event-functions.texinfo (original) +++ trunk/docs/manual/event-functions.texinfo Mon Sep 11 16:30:56 2006 @@ -239,10 +239,10 @@ @event-dispatcher-arg @item widget The @ref{widget} whose contents need to be repainted. -@item gc +@item graphics-context A @ref{graphics-context} initialized for use during this paint event and which will be @ref{dispose}d after this method returns. -@item rect +@item rectangle The specific @ref{rectangle} within @var{widget} needing to be repainted. @end table @end deffn Modified: trunk/src/uitoolkit/graphics/graphics-context.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-context.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-context.lisp Mon Sep 11 16:30:56 2006 @@ -175,8 +175,8 @@ (setf gfs::tablength tab-width) (setf gfs::leftmargin 0) (setf gfs::rightmargin 0) - (gfs::with-rect - (gfs::draw-text-ex hdc str -1 gfs::rect-ptr (logior dt-flags gfs::+dt-calcrect+) dt-ptr) + (gfs::with-rect (rect-ptr) + (gfs::draw-text-ex hdc str -1 rect-ptr (logior dt-flags gfs::+dt-calcrect+) dt-ptr) (setf (gfs:size-width sz) (- gfs::right gfs::left)) (setf (gfs:size-height sz) (- gfs::bottom gfs::top)))))) (when (or (zerop len) (zerop (gfs:size-height sz))) @@ -292,7 +292,7 @@ (let ((hdc (gfs:handle self)) (pnt (gfs:location rect)) (size (gfs:size rect))) - (gfs::with-rect + (gfs::with-rect (rect-ptr) (setf gfs::top (gfs:point-y pnt) gfs::left (gfs:point-x pnt) gfs::bottom (+ (gfs:point-y pnt) (gfs:size-height size)) @@ -441,19 +441,19 @@ (setf gfs::tablength tb-width) (setf gfs::leftmargin 0) (setf gfs::rightmargin 0) - (gfs::with-rect + (gfs::with-rect (rect-ptr) (setf gfs::left (gfs:point-x pnt)) (setf gfs::top (gfs:point-y pnt)) (gfs::draw-text-ex (gfs:handle self) text -1 - gfs::rect-ptr + rect-ptr (logior gfs::+dt-calcrect+ (logand flags (lognot gfs::+dt-vcenter+))) dt-ptr) (gfs::draw-text-ex (gfs:handle self) text (length text) - gfs::rect-ptr + rect-ptr flags dt-ptr) (gfs::set-bk-mode (gfs:handle self) old-bk-mode)))))) Modified: trunk/src/uitoolkit/system/system-utils.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-utils.lisp (original) +++ trunk/src/uitoolkit/system/system-utils.lisp Mon Sep 11 16:30:56 2006 @@ -132,11 +132,11 @@ ;;; convenience macros ;;; -(defmacro with-rect (&body body) - `(cffi:with-foreign-object (rect-ptr 'gfs::rect) +(defmacro with-rect ((rect-var) &body body) + `(cffi:with-foreign-object (,rect-var 'gfs::rect) (cffi:with-foreign-slots ((gfs::left gfs::right gfs::top gfs::bottom) - rect-ptr gfs::rect) - (zero-mem rect-ptr gfs::rect) + ,rect-var gfs::rect) + (zero-mem ,rect-var gfs::rect) ,@body))) (defmacro with-hfont-selected ((hdc hfont) &body body) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Mon Sep 11 16:30:56 2006 @@ -153,18 +153,29 @@ color)) (defmethod compute-outer-size ((self window) desired-client-size) - (let ((hwnd (gfs:handle self)) - (new-size (gfs:make-size))) - (gfs::with-rect + (let* ((hwnd (gfs:handle self)) + (has-menu (not (cffi:null-pointer-p (gfs::get-menu hwnd)))) + (new-size (gfs:make-size))) + (gfs::with-rect (rect-ptr) (setf gfs::right (gfs:size-width desired-client-size) gfs::bottom (gfs:size-height desired-client-size)) - (if (zerop (gfs::adjust-window-rect gfs::rect-ptr + (if (zerop (gfs::adjust-window-rect rect-ptr (get-native-style self) - (if (cffi:null-pointer-p (gfs::get-menu hwnd)) 0 1) + (if has-menu 1 0) (get-native-exstyle self))) (error 'gfs:win32-error :detail "adjust-window-rect failed")) (setf (gfs:size-width new-size) (- gfs::right gfs::left) - (gfs:size-height new-size) (- gfs::bottom gfs::top))) + (gfs:size-height new-size) (- gfs::bottom gfs::top)) + ;; check how much wrapping occurs if there is a menu and we + ;; size a window to the above-computed width and infinite + ;; height + (when has-menu + (setf gfs::bottom #x7FFFFFFF) ; ensures we handle all possible menu wrap + (gfs::send-message hwnd gfs::+wm-nccalcsize+ 0 (cffi:pointer-address rect-ptr)) + ;; gfs::top is now the bottom-most position of the top part of the window's + ;; non-client area, which is the area that the wrapped menu occupies and for + ;; which compensation is needed. + (incf (gfs:size-height new-size) gfs::top))) new-size)) (defmethod gfs:dispose ((self window))

1 0

[graphic-forms-cvs] r256 - trunk
by junrue＠common-lisp.net 11 Sep '06

11 Sep '06

Author: junrue Date: Mon Sep 11 00:41:24 2006 New Revision: 256 Modified: trunk/NEWS.txt trunk/README.txt Log: doc updates Modified: trunk/NEWS.txt ============================================================================== --- trunk/NEWS.txt (original) +++ trunk/NEWS.txt Mon Sep 11 00:41:24 2006 @@ -1,8 +1,28 @@ +. Initial list box control functionality is now available: + + * three selection modes (none / multiple / extend) + + * list item data comprised by arbitrary application-defined data + + * application defined sorting predicates + + * querying and programmatic control of item selection states + + * customizability of vertical scrollbar mode and keyboard input + + Additional list box control features will be provided in a future release. + +. Did some housecleaning of the item-manager protocol and heavily refactored + the implementation of item-manager base functionality. + . Implemented GFW:ENABLE-REDRAW to enable applications to temporarily disable (and later re-enable) drawing of widget content. +. Fixed a silly bug in GFW:CHECKED-P (and GFW:SELECTED-P) for checkbox and + radio button -style buttons. + ============================================================================== Release 0.5.0 of Graphic-Forms, a Common Lisp library for Windows GUI Modified: trunk/README.txt ============================================================================== --- trunk/README.txt (original) +++ trunk/README.txt Mon Sep 11 00:41:24 2006 @@ -1,5 +1,5 @@ -Graphic-Forms README for version 0.6.0 (22 August 2006) +Graphic-Forms README for version 0.6.0 (xx xxxxxxx 2006) Copyright (c) 2006, Jack D. Unrue Graphic-Forms is a user interface library implemented in Common Lisp focusing @@ -73,11 +73,15 @@ compute height from that. The gfg:text-extent function does return the correct width. +5. If a Graphic-Forms application is launched from within SLIME on a + single-threaded Common Lisp implementation, further SLIME commands + will be 'pipelined' until the Graphic-Forms main message loop exits. + How To Configure and Build -------------------------- -NOTE: in a future release, this project will be packaged for delivery +NOTE: in a future release, this library will be packaged for delivery via asdf-install. 1. [OPTIONAL] Install ImageMagick 6.2.6.5-Q16 (note in particular that it @@ -169,10 +173,12 @@ (gft:event-tester) - (gft:image-tester) + (gft:image-tester) ; if ImageMagick loaded, shows PNG and GIF images (gft:layout-tester) + (gft:widget-tester) + (gft:windlg) ;;

1 0

[graphic-forms-cvs] r255 - in trunk/src: tests/uitoolkit uitoolkit/widgets
by junrue＠common-lisp.net 10 Sep '06

10 Sep '06

Author: junrue Date: Sun Sep 10 18:59:22 2006 New Revision: 255 Modified: trunk/src/tests/uitoolkit/widget-tester.lisp trunk/src/uitoolkit/widgets/list-item.lisp Log: implemented select and selected-p for list-item Modified: trunk/src/tests/uitoolkit/widget-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/widget-tester.lisp (original) +++ trunk/src/tests/uitoolkit/widget-tester.lisp Sun Sep 10 18:59:22 2006 @@ -85,7 +85,9 @@ (defun select-lb-content (lb state) (let ((count (gfw:item-count lb)) (func (if state #'gfw::lb-select-item #'gfw::lb-deselect-item))) - (loop for index in '(0 2 4) + (if (> count 0) + (gfw:select (first (gfw:items-of lb)) state)) + (loop for index in '(2 4) when (>= count (1+ index)) do (funcall func lb index)))) #| Modified: trunk/src/uitoolkit/widgets/list-item.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/list-item.lisp (original) +++ trunk/src/uitoolkit/widgets/list-item.lisp Sun Sep 10 18:59:22 2006 @@ -77,6 +77,16 @@ (gfs::send-message hwnd gfs::+lb-deletestring+ (item-index owner self) 0))))) (call-next-method)) +(defmethod select ((self list-item) flag) + (let ((owner (owner self))) + (if flag + (lb-select-item owner (item-index owner self)) + (lb-deselect-item owner (item-index owner self))))) + +(defmethod selected-p ((self list-item)) + (let ((owner (owner self))) + (> (gfs::send-message (gfs:handle self) gfs::+lb-getsel+ (item-index owner self) 0) 0))) + (defmethod text ((self list-item)) (let ((hwnd (gfs:handle self))) (if (or (null hwnd) (cffi:null-pointer-p hwnd))

1 0

[graphic-forms-cvs] r254 - in trunk: docs/manual src src/tests/uitoolkit src/uitoolkit/system src/uitoolkit/widgets
by junrue＠common-lisp.net 10 Sep '06

10 Sep '06

Author: junrue Date: Sun Sep 10 17:31:01 2006 New Revision: 254 Modified: trunk/docs/manual/widget-functions.texinfo trunk/src/packages.lisp trunk/src/tests/uitoolkit/widget-tester.lisp trunk/src/uitoolkit/system/user32.lisp trunk/src/uitoolkit/widgets/button.lisp trunk/src/uitoolkit/widgets/item-manager.lisp trunk/src/uitoolkit/widgets/list-box.lisp trunk/src/uitoolkit/widgets/list-item.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp trunk/src/uitoolkit/widgets/widget.lisp Log: fixed a bug in checked-p for buttons; implemented low-level select and deselect functions for list-box; enhanced test-native-style to support more than one bit to test Modified: trunk/docs/manual/widget-functions.texinfo ============================================================================== --- trunk/docs/manual/widget-functions.texinfo (original) +++ trunk/docs/manual/widget-functions.texinfo Sun Sep 10 17:31:01 2006 @@ -16,22 +16,35 @@ @anchor{append-item} @deffn GenericFunction append-item self thing dispatcher &optional disabled checked => @ref{item} -Adds a new item representing @var{thing} to @var{self}, where the -class of @var{self} must derive from @ref{item-manager}. The -newly-created item is returned. The @var{dispatcher} parameter must -be an instance of @ref{event-dispatcher} or a subclass thereof. The -optional @var{checked} and @var{disabled} arguments can be used to set -the item's initial state. +Adds a new item representing @var{thing} to @var{self}, where @var{thing} +can be any @sc{object}. The newly-created item is returned. +The @var{dispatcher} parameter must be one of the following: +@itemize @bullet +@item An instance of @ref{event-dispatcher} or a subclass thereof. +@item A function whose argument list matches the event method +identified by the @var{callback-event-name} slot in @var{self}'s +class. + +See also @ref{items-of}. +@end itemize + +The optional @var{checked} and @var{disabled} arguments will each be +interpreted as @sc{generalized boolean} values in order to set the +item's initial state. Note, however, that not all @ref{item-manager} +subclasses support enabled or checked states for individual items. @end deffn @deffn GenericFunction append-separator self => @ref{item} -Adds a separator item to @var{self}, and returns the newly-created item. +Adds a separator to @var{self}, and returns a newly-created item to +wrap the separator. A separator is a thin etched divider that serves +to visually separate groups of items and has no other behavior. @end deffn -@deffn GenericFunction append-submenu self text submenu dispatcher &optional disabled checked => @ref{item} +@deffn GenericFunction append-submenu self text submenu dispatcher &optional disabled checked => @ref{menu-item} Adds @var{submenu} anchored to @var{self} and returns the corresponding -@ref{menu-item}. The optional @var{checked} and @var{disabled} arguments can -be used to set the menu item's initial state. +menu-item. The optional @var{checked} and @var{disabled} arguments +will each be interpreted as @sc{generalized boolean} values +in order to set the menu item's initial state. @end deffn @anchor{auto-hscroll-p} @@ -139,6 +152,16 @@ presses @sc{enter}. @end deffn +@anchor{data-of} +@deffn Accessor data-of self +(setf (@strong{data-of} @var{self}) @var{object})@* + +Returns application-specific data associated with @var{self}. + +The corresponding @sc{set} function associates new data with +@var{self}. +@end deffn + @deffn GenericFunction delete-all self Removes all content from @var{self}. @end deffn @@ -259,8 +282,33 @@ an image or an icon-bundle. @end deffn +@anchor{item-count} +@deffn GenericFunction item-count self => integer +Returns the number of instances of @ref{item} subclasses contained within +@var{self}. +@end deffn + +@anchor{item-index} @deffn GenericFunction item-index self item -Return the zero-based index of the location of the other object in this object. +Return the zero-based index of the location of @var{item} within @var{self}. +@end deffn + +@anchor{items-of} +@deffn GenericFunction items-of self +(setf (@strong{items-of} @var{self}) @var{items})@* + +Returns a fresh @sc{list} of @ref{item} subclasses appropriate for +@var{self}'s type. + +The corresponding @sc{setf} function accepts a list whose contents +are any combination of: +@itemize @bullet +@item Instances of @ref{item} subclasses appropriate for @var{self}. +@item Instances of any @sc{object} type; these will be wrapped by item +objects, to be accessible later via the @ref{data-of} method. +@end itemize +Existing items contained by @var{self} are replaced, and then the +native control is refreshed. See also @ref{append-item}. @end deffn @anchor{layout} @@ -284,7 +332,10 @@ Calls @var{func}, which is a function of two arguments, for each child of @var{self} and places @var{func}'s return value in @var{result-list}. @var{func}'s two arguments are @var{self} and -the current child. +the current child. Note that @code{mapchildren} accesses @var{self}'s +@emph{actual} children as determined by the underlying window's +data structures, regardless of any @ref{layout-manager} assigned +to @var{self}. @end deffn @anchor{maximum-size} @@ -464,16 +515,18 @@ @deffn GenericFunction selected-items self => list (setf (@strong{selected-items} @var{self}) @var{list}) -Returns a @sc{list} containing subclasses of @ref{item} appropriate -for @var{self} that correspond to selections made by the user, or -@sc{nil} if there are no selections. This function is defined only -for @ref{widget}s whose notion of @emph{selection} is a set of -item objects. - -The @sc{setf} function takes a @var{list} of item subclasses -appropriate for @var{self} which identify the items in -@var{self} that should be selected. Passing @sc{nil} will unselect all -items, which is equivalent to calling @ref{select-all} with @sc{nil}. +Returns a fresh @sc{list} containing subclasses of @ref{item} +appropriate for @var{self} that correspond to selections made by the +user, or @sc{nil} if there are no selections. This function is defined +only for @ref{widget}s whose notion of @emph{selection} is a set of +instances of @ref{item} subclasses. + +The @sc{setf} function takes a @sc{list} of instances of item +subclasses appropriate for @var{self} which identify the items in +@var{self} that should be selected.@footnote{In this respect, +@ref{selected-items} is not symmetric with @ref{items-of}.} Passing +@sc{nil} will unselect all items, which is equivalent to calling +@ref{select-all} with @sc{nil}. @end deffn @anchor{selected-p} Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Sun Sep 10 17:31:01 2006 @@ -436,6 +436,7 @@ #:initial-delay-of #:horizontal-scrollbar #:image + #:item-count #:item-height #:item-id #:item-index Modified: trunk/src/tests/uitoolkit/widget-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/widget-tester.lisp (original) +++ trunk/src/tests/uitoolkit/widget-tester.lisp Sun Sep 10 17:31:01 2006 @@ -65,10 +65,12 @@ (gfg:foreground-color gc) color)) (gfg:draw-filled-rectangle gc (gfs:make-rectangle :size (gfw:client-size window)))) -(defun manage-lb-button-states (lb move-btn all-btn none-btn) +(defun manage-lb-button-states (lb move-btn selected-btn all-btn none-btn) (let ((sel-count (gfw:selected-count lb)) - (item-count (length (gfw:items-of lb)))) + (item-count (gfw:item-count lb))) (gfw:enable move-btn (> sel-count 0)) + (if selected-btn + (gfw:check selected-btn (> sel-count 0))) (if all-btn (gfw:enable all-btn (and (> item-count 0) (< sel-count item-count)))) (if none-btn @@ -80,39 +82,64 @@ (if sel-items (setf (gfw:items-of dest-lb) (append sel-items (gfw:items-of dest-lb)))))) +(defun select-lb-content (lb state) + (let ((count (gfw:item-count lb)) + (func (if state #'gfw::lb-select-item #'gfw::lb-deselect-item))) + (loop for index in '(0 2 4) + when (>= count (1+ index)) + do (funcall func lb index)))) +#| + (let ((items (gfw:items-of lb))) + (setf (gfw:selected-items lb) (subseq items 0 (min 4 (length items)))))) +|# + (defun populate-list-box-test-panel () (setf (gfw:text *widget-tester-win*) "Widget Tester (List Boxes)") (let* ((panel-disp (make-instance 'widget-tester-panel-events)) - (lb1 nil) - (lb2 nil) - (btn-left nil) - (btn-right nil) - (btn-all nil) - (btn-none nil) - (lb1-callback (lambda (disp lb) - (declare (ignore disp)) - (manage-lb-button-states lb btn-right btn-all btn-none))) - (lb2-callback (lambda (disp lb) - (declare (ignore disp)) - (manage-lb-button-states lb btn-left nil nil))) - (btn-left-callback (lambda (disp btn) - (declare (ignore disp btn)) - (move-lb-content lb2 lb1) - (manage-lb-button-states lb1 btn-right btn-all btn-none) - (manage-lb-button-states lb2 btn-left nil nil))) - (btn-right-callback (lambda (disp btn) - (declare (ignore disp btn)) - (move-lb-content lb1 lb2) - (manage-lb-button-states lb1 btn-right btn-all btn-none) - (manage-lb-button-states lb2 btn-left nil nil))) - (btn-all-callback (lambda (disp btn) - (declare (ignore disp btn)) - (gfw:select-all lb1 t) - (manage-lb-button-states lb1 btn-right btn-all btn-none))) - (btn-none-callback (lambda (disp btn) - (declare (ignore disp btn)) - (gfw:select-all lb1 nil) - (manage-lb-button-states lb1 btn-right btn-all btn-none))) + (latch nil) + (lb1 nil) + (lb2 nil) + (btn-left nil) + (btn-right nil) + (btn-all nil) + (btn-none nil) + (btn-select nil) + (lb1-callback (lambda (disp lb) + (declare (ignore disp)) + (manage-lb-button-states lb btn-right (if latch nil btn-select) btn-all btn-none))) + (lb2-callback (lambda (disp lb) + (declare (ignore disp)) + (manage-lb-button-states lb btn-left nil nil nil))) + (btn-left-callback (lambda (disp btn) + (declare (ignore disp btn)) + (move-lb-content lb2 lb1) + (manage-lb-button-states lb1 btn-right btn-select btn-all btn-none) + (manage-lb-button-states lb2 btn-left nil nil nil))) + (btn-right-callback (lambda (disp btn) + (declare (ignore disp btn)) + (move-lb-content lb1 lb2) + (manage-lb-button-states lb1 btn-right btn-select btn-all btn-none) + (manage-lb-button-states lb2 btn-left nil nil nil))) + (btn-all-callback (lambda (disp btn) + (declare (ignore disp btn)) + (gfw:select-all lb1 t) + (manage-lb-button-states lb1 btn-right btn-select btn-all btn-none))) + (btn-none-callback (lambda (disp btn) + (declare (ignore disp btn)) + (gfw:select-all lb1 nil) + (manage-lb-button-states lb1 btn-right btn-select btn-all btn-none))) + (btn-reset-callback (lambda (disp btn) + (declare (ignore disp btn)) + (gfw:delete-all lb2) + (setf (gfw:items-of lb1) *list-box-test-data*) + (manage-lb-button-states lb1 btn-right btn-select btn-all btn-none) + (manage-lb-button-states lb2 btn-left nil nil nil))) + (btn-select-callback (lambda (disp btn) + (declare (ignore disp)) + (setf latch t) + (select-lb-content lb1 (gfw:selected-p btn)) + (manage-lb-button-states lb1 btn-right nil btn-all btn-none) + (setf latch nil))) (outer-panel (make-instance 'gfw:panel :dispatcher panel-disp :parent *widget-tester-win* @@ -135,21 +162,28 @@ :items (subseq *list-box-test-data* 4))) (gfw:pack lb1-panel) - (setf btn-right (make-instance 'gfw:button :parent btn-panel - :text " ==> " - :callback btn-right-callback)) + (setf btn-right (make-instance 'gfw:button :parent btn-panel + :text " ==> " + :callback btn-right-callback)) (gfw:enable btn-right nil) - (setf btn-left (make-instance 'gfw:button :parent btn-panel - :text " <== " - :callback btn-left-callback)) + (setf btn-left (make-instance 'gfw:button :parent btn-panel + :text " <== " + :callback btn-left-callback)) (gfw:enable btn-left nil) - (setf btn-all (make-instance 'gfw:button :parent btn-panel - :text "Select All" - :callback btn-all-callback)) - (setf btn-none (make-instance 'gfw:button :parent btn-panel - :text "Select None" - :callback btn-none-callback)) + (setf btn-all (make-instance 'gfw:button :parent btn-panel + :text "Select All" + :callback btn-all-callback)) + (setf btn-none (make-instance 'gfw:button :parent btn-panel + :text "Select None" + :callback btn-none-callback)) (gfw:enable btn-none nil) + (make-instance 'gfw:button :parent btn-panel + :text "Reset" + :callback btn-reset-callback) + (setf btn-select (make-instance 'gfw:button :parent btn-panel + :text "Select 0,2,4" + :style '(:check-box) + :callback btn-select-callback)) (gfw:pack btn-panel) (make-instance 'gfw:label :text "Extended Select:" :parent lb2-panel) @@ -160,12 +194,17 @@ (gfw:pack lb2-panel) (gfw:pack outer-panel) + ;; FIXME: need to think of a more elegant solution for the following + ;; use-case where we want synchronize the sizes of two or more + ;; layout children + ;; (let ((size (gfw:size lb1))) (setf (gfw:maximum-size lb1) size (gfw:minimum-size lb1) size (gfw:maximum-size lb2) size (gfw:minimum-size lb2) size)) (setf (gfw:items-of lb1) *list-box-test-data*) + (manage-lb-button-states lb1 btn-right btn-select btn-all btn-none) (gfw:delete-all lb2) outer-panel)) Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Sun Sep 10 17:31:01 2006 @@ -729,3 +729,9 @@ ("UpdateWindow" update-window) BOOL (hwnd HANDLE)) + +(defcfun + ("ValidateRect" validate-rect) + BOOL + (hwnd HANDLE) + (rct LPTR)) Modified: trunk/src/uitoolkit/widgets/button.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/button.lisp (original) +++ trunk/src/uitoolkit/widgets/button.lisp Sun Sep 10 17:31:01 2006 @@ -46,10 +46,7 @@ (defmethod checked-p ((self button)) (let ((bits (gfs::send-message (gfs:handle self) gfs::+bm-getcheck+ 0 0))) - (case bits - (gfs::+bst-checked+ t) - (gfs::+bst-unchecked+ nil) - (otherwise nil)))) + (= (logand bits gfs::+bst-checked+) gfs::+bst-checked+))) (defmethod compute-style-flags ((self button) &rest extra-data) (declare (ignore extra-data)) Modified: trunk/src/uitoolkit/widgets/item-manager.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/item-manager.lisp (original) +++ trunk/src/uitoolkit/widgets/item-manager.lisp Sun Sep 10 17:31:01 2006 @@ -124,6 +124,13 @@ (dotimes (i (length items)) (delete-tc-item tc (elt items i))))) +(defmethod item-count :before ((self item-manager)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + +(defmethod item-count ((self item-manager)) + (length (slot-value self 'items))) + (defmethod item-index :before ((self item-manager) (it item)) (declare (ignore it)) (if (gfs:disposed-p self) Modified: trunk/src/uitoolkit/widgets/list-box.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/list-box.lisp (original) +++ trunk/src/uitoolkit/widgets/list-box.lisp Sun Sep 10 17:31:01 2006 @@ -56,6 +56,11 @@ (logand orig-flags (lognot (logior gfs::+lbs-nosel+ gfs::+lbs-extendedsel+ gfs::+lbs-multiplesel+)))) +(defun lb-is-single-select (lb) + (not (test-native-style lb (logior gfs::+lbs-extendedsel+ + gfs::+lbs-multiplesel+ + gfs::+lbs-nosel+)))) + (defun lb-width (hwnd) (let ((width (gfs::send-message hwnd gfs::+lb-gethorizontalextent+ 0 0))) (if (< width 0) @@ -76,6 +81,90 @@ (setf (slot-value victim 'gfs:handle) nil) (gfs:dispose victim))))) +;;; This function is based on the package private select( int, boolean ) +;;; method from SWT 3.2 located in List.java starting on line 998, without +;;; the additional scrolling logic. +;;; +(defun lb-select-item (lb index) + (let ((hwnd (gfs:handle lb))) + + ;; sanity-check the index + ;; + (if (or (< index 0) (>= index (gfs::send-message hwnd gfs::+lb-getcount+ 0 0))) + (return-from lb-select-item nil)) + + ;; save the index of the top-most item + ;; + (let ((top-index (gfs::send-message hwnd gfs::+lb-gettopindex+ 0 0))) + (cffi:with-foreign-object (top-item-rect-ptr 'gfs::rect) + (cffi:with-foreign-object (sel-item-rect-ptr 'gfs::rect) + + ;; get the rectangle for the top-most item which we + ;; will repaint at the end + ;; + (gfs::send-message hwnd gfs::+lb-getitemrect+ + top-index (cffi:pointer-address top-item-rect-ptr)) + (let ((redraw-needed (zerop (gfs::is-window-visible hwnd))) + (has-sel-item nil)) + + ;; if the list box is visible, disable repainting + ;; + (if redraw-needed + (enable-redraw lb nil)) + (unwind-protect + (progn + (if (lb-is-single-select lb) + + ;; single-select list boxes must be configured differently + ;; from multi-select + ;; + (let ((old-index (gfs::send-message hwnd gfs::+lb-getcursel+ 0 0))) + (setf has-sel-item (/= old-index -1)) + + ;; get the rectangle for the old selected item + ;; + (if has-sel-item + (gfs::send-message hwnd gfs::+lb-getitemrect+ + old-index (cffi:pointer-address sel-item-rect-ptr))) + + ;; set the new selection + ;; + (gfs::send-message hwnd gfs::+lb-setcursel+ index 0)) + + ;; configure new selection for multi-select list boxes + ;; + (let ((focus-index (gfs::send-message hwnd gfs::+lb-getcaretindex+ 0 0))) + + ;; set the new selection + ;; + (gfs::send-message hwnd gfs::+lb-setsel+ 1 index) + + ;; if there was an item with focus, restore it + ;; + (if (/= focus-index -1) + (gfs::send-message hwnd gfs::+lb-setcaretindex+ focus-index 0))))) + + ;; restore the original top-index, then update the + ;; list box and the top item and the selection item + ;; + (gfs::send-message hwnd gfs::+lb-settopindex+ top-index 0) + (when redraw-needed + (enable-redraw lb t) + (gfs::validate-rect hwnd (cffi:null-pointer)) + (gfs::invalidate-rect hwnd top-item-rect-ptr 1) + (if has-sel-item + (gfs::invalidate-rect hwnd sel-item-rect-ptr 1)))))))))) + +(defun lb-deselect-item (lb index) + (let ((hwnd (gfs:handle lb))) + (if (or (< index 0) (>= index (gfs::send-message hwnd gfs::+lb-getcount+ 0 0))) + (return-from lb-deselect-item nil)) + (if (lb-is-single-select lb) + (let ((curr-index (gfs::send-message hwnd gfs::+lb-getcursel+ 0 0))) + (if (= curr-index index) + (gfs::send-message hwnd gfs::+lb-setcursel+ -1 0))) + (gfs::send-message hwnd gfs::+lb-setsel+ 0 index)))) + ;;; ;;; methods ;;; @@ -202,8 +291,7 @@ size)) (defmethod select-all ((self list-box) flag) - (when (or (test-native-style self gfs::+lbs-extendedsel+) - (test-native-style self gfs::+lbs-multiplesel+)) + (when (test-native-style self (logior gfs::+lbs-extendedsel+ gfs::+lbs-multiplesel+)) (gfs::send-message (gfs:handle self) gfs::+lb-setsel+ (if flag 1 0) #xFFFFFFFF))) (defmethod selected-count ((self list-box)) @@ -216,8 +304,7 @@ (defmethod selected-items ((self list-box)) (let ((hwnd (gfs:handle self)) (items (slot-value self 'items))) - (if (and (not (test-native-style self gfs::+lbs-extendedsel+)) - (not (test-native-style self gfs::+lbs-multiplesel+))) + (if (lb-is-single-select self) (let ((index (gfs::send-message hwnd gfs::+lb-getcursel+ 0 0))) (if (and (>= index 0) (< index (length items))) (list (elt items index)) Modified: trunk/src/uitoolkit/widgets/list-item.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/list-item.lisp (original) +++ trunk/src/uitoolkit/widgets/list-item.lisp Sun Sep 10 17:31:01 2006 @@ -51,6 +51,12 @@ (error 'gfs:win32-error :detail "LB_GETITEMHEIGHT failed")) height)) +(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)) + (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))) @@ -59,12 +65,6 @@ (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 ;;; @@ -76,3 +76,9 @@ (if (and owner (cffi:pointer-eq hwnd (gfs:handle owner))) (gfs::send-message hwnd gfs::+lb-deletestring+ (item-index owner self) 0))))) (call-next-method)) + +(defmethod text ((self list-item)) + (let ((hwnd (gfs:handle self))) + (if (or (null hwnd) (cffi:null-pointer-p hwnd)) + "" + (lb-item-text hwnd (item-index (get-widget (thread-context) hwnd) self))))) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Sun Sep 10 17:31:01 2006 @@ -39,6 +39,8 @@ (defclass event-dispatcher () () (:documentation "Instances of this class receive events on behalf of user interface objects.")) +(defvar *default-dispatcher* (make-instance 'event-dispatcher)) + (defclass layout-managed () ((layout-p :reader layout-p @@ -68,7 +70,7 @@ ((dispatcher :accessor dispatcher :initarg :dispatcher - :initform (make-instance 'event-dispatcher)) + :initform *default-dispatcher*) (callback-event-name :accessor callback-event-name-of :initform nil Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Sun Sep 10 17:31:01 2006 @@ -207,6 +207,9 @@ (defgeneric (setf image) (image self) (:documentation "Sets self's image object.")) +(defgeneric item-count (self) + (:documentation "Returns the number of items contained within self.")) + (defgeneric item-height (self) (:documentation "Return the height of the area if one of the object's items were displayed.")) Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Sun Sep 10 17:31:01 2006 @@ -141,7 +141,7 @@ (defun show-common-dialog (dlg dlg-func) (let* ((struct-ptr (gfs:handle dlg)) (retval (funcall dlg-func struct-ptr))) - (if (and (zerop retval) (not (zerop (gfs::comm-dlg-extended-error)))) + (if (and (zerop retval) (/= (gfs::comm-dlg-extended-error) 0)) (error 'gfs:comdlg-error :detail (format nil "~a failed" (symbol-name dlg-func)))) retval)) @@ -286,7 +286,7 @@ (gfs::get-window-long (gfs:handle widget) gfs::+gwl-exstyle+)) (defun test-native-style (widget bits) - (= (logand (gfs::get-window-long (gfs:handle widget) gfs::+gwl-style+) bits) bits)) + (/= (logand (gfs::get-window-long (gfs:handle widget) gfs::+gwl-style+) bits) 0)) (defun test-native-exstyle (widget bits) - (= (logand (gfs::get-window-long (gfs:handle widget) gfs::+gwl-exstyle+) bits) bits)) + (/= (logand (gfs::get-window-long (gfs:handle widget) gfs::+gwl-exstyle+) bits) 0)) Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Sun Sep 10 17:31:01 2006 @@ -207,7 +207,7 @@ (redraw self))) (defmethod enabled-p ((self widget)) - (not (zerop (gfs::is-window-enabled (gfs:handle self))))) + (/= (gfs::is-window-enabled (gfs:handle self)) 0)) (defmethod image :before ((self widget)) (if (gfs:disposed-p self) @@ -435,4 +435,4 @@ (error 'gfs:disposed-error))) (defmethod visible-p ((self widget)) - (not (zerop (gfs::is-window-visible (gfs:handle self))))) + (/= (gfs::is-window-visible (gfs:handle self)) 0))

1 0

[graphic-forms-cvs] r253 - in trunk/src: tests/uitoolkit uitoolkit/widgets
by junrue＠common-lisp.net 09 Sep '06

09 Sep '06

Author: junrue Date: Sat Sep 9 00:39:19 2006 New Revision: 253 Modified: trunk/src/tests/uitoolkit/widget-tester.lisp trunk/src/uitoolkit/widgets/item-manager.lisp trunk/src/uitoolkit/widgets/list-box.lisp Log: implemented select-all for list-box Modified: trunk/src/tests/uitoolkit/widget-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/widget-tester.lisp (original) +++ trunk/src/tests/uitoolkit/widget-tester.lisp Sat Sep 9 00:39:19 2006 @@ -66,13 +66,13 @@ (gfg:draw-filled-rectangle gc (gfs:make-rectangle :size (gfw:client-size window)))) (defun manage-lb-button-states (lb move-btn all-btn none-btn) - (let ((count (gfw:selected-count lb)) - (items (gfw:items-of lb))) - (gfw:enable move-btn (> count 0)) + (let ((sel-count (gfw:selected-count lb)) + (item-count (length (gfw:items-of lb)))) + (gfw:enable move-btn (> sel-count 0)) (if all-btn - (gfw:enable all-btn (< count (length items)))) + (gfw:enable all-btn (and (> item-count 0) (< sel-count item-count)))) (if none-btn - (gfw:enable none-btn (> count 0))))) + (gfw:enable none-btn (> sel-count 0))))) (defun move-lb-content (orig-lb dest-lb) (let ((sel-items (gfw:selected-items orig-lb))) @@ -99,16 +99,20 @@ (declare (ignore disp btn)) (move-lb-content lb2 lb1) (manage-lb-button-states lb1 btn-right btn-all btn-none) - (manage-lb-button-states lb2 btn-left btn-all btn-none))) + (manage-lb-button-states lb2 btn-left nil nil))) (btn-right-callback (lambda (disp btn) (declare (ignore disp btn)) (move-lb-content lb1 lb2) (manage-lb-button-states lb1 btn-right btn-all btn-none) - (manage-lb-button-states lb2 btn-left btn-all btn-none))) + (manage-lb-button-states lb2 btn-left nil nil))) (btn-all-callback (lambda (disp btn) - (declare (ignore disp btn)))) + (declare (ignore disp btn)) + (gfw:select-all lb1 t) + (manage-lb-button-states lb1 btn-right btn-all btn-none))) (btn-none-callback (lambda (disp btn) - (declare (ignore disp btn)))) + (declare (ignore disp btn)) + (gfw:select-all lb1 nil) + (manage-lb-button-states lb1 btn-right btn-all btn-none))) (outer-panel (make-instance 'gfw:panel :dispatcher panel-disp :parent *widget-tester-win* Modified: trunk/src/uitoolkit/widgets/item-manager.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/item-manager.lisp (original) +++ trunk/src/uitoolkit/widgets/item-manager.lisp Sat Sep 9 00:39:19 2006 @@ -102,6 +102,8 @@ (error 'gfs:disposed-error))) (defmethod delete-item ((self item-manager) index) + (if (or (< index 0) (>= index (length (slot-value self 'items)))) + (error 'gfs:toolkit-error :detail "invalid item index")) (multiple-value-bind (new-items victim) (gfs::remove-element (slot-value self 'items) index #'make-items-array) (setf (slot-value self 'items) new-items) @@ -116,10 +118,6 @@ (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod delete-span ((self item-manager) (sp gfs:span)) - (dotimes (i (1+ (- (gfs:span-end sp) (gfs:span-start sp)))) - (delete-item self (gfs:span-start sp)))) - (defmethod gfs:dispose ((self item-manager)) (let ((items (slot-value self 'items)) (tc (thread-context))) Modified: trunk/src/uitoolkit/widgets/list-box.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/list-box.lisp (original) +++ trunk/src/uitoolkit/widgets/list-box.lisp Sat Sep 9 00:39:19 2006 @@ -123,6 +123,13 @@ do (gfs:dispose item)) (enable-redraw self t))) +(defmethod delete-span ((self list-box) (span gfs:span)) + (enable-redraw self nil) + (unwind-protect + (dotimes (i (1+ (- (gfs:span-end span) (gfs:span-start span)))) + (delete-item self (gfs:span-start span))) + (enable-redraw self t))) + (defmethod initialize-instance :after ((self list-box) &key estimated-count items parent &allow-other-keys) (initialize-comctl-classes gfs::+icc-standard-classes+) (multiple-value-bind (std-style ex-style) @@ -194,6 +201,11 @@ (incf (gfs:size-width size) (vertical-scrollbar-width))) size)) +(defmethod select-all ((self list-box) flag) + (when (or (test-native-style self gfs::+lbs-extendedsel+) + (test-native-style self gfs::+lbs-multiplesel+)) + (gfs::send-message (gfs:handle self) gfs::+lb-setsel+ (if flag 1 0) #xFFFFFFFF))) + (defmethod selected-count ((self list-box)) (let ((hwnd (gfs:handle self))) (if (test-native-style self gfs::+lbs-nosel+)

1 0

[graphic-forms-cvs] r252 - in trunk: docs/manual src/tests/uitoolkit src/uitoolkit/system src/uitoolkit/widgets
by junrue＠common-lisp.net 09 Sep '06

09 Sep '06

Author: junrue Date: Fri Sep 8 23:02:05 2006 New Revision: 252 Modified: trunk/docs/manual/widget-functions.texinfo trunk/src/tests/uitoolkit/item-manager-unit-tests.lisp trunk/src/tests/uitoolkit/misc-unit-tests.lisp trunk/src/tests/uitoolkit/widget-tester.lisp trunk/src/uitoolkit/system/system-utils.lisp trunk/src/uitoolkit/widgets/item-manager.lisp trunk/src/uitoolkit/widgets/list-box.lisp trunk/src/uitoolkit/widgets/list-item.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp trunk/src/uitoolkit/widgets/widget.lisp Log: rewrote item dispose / manager delete-item, implemented item-index to replace index-of accessor, added unit-tests Modified: trunk/docs/manual/widget-functions.texinfo ============================================================================== --- trunk/docs/manual/widget-functions.texinfo (original) +++ trunk/docs/manual/widget-functions.texinfo Fri Sep 8 23:02:05 2006 @@ -147,11 +147,6 @@ Removes the @ref{item} at the zero-based @var{index}. @end deffn -@deffn GenericFunction delete-item-span self @ref{span} -Removes the items from @var{self} whose zero-based indices lie within -the specified @var{span}. -@end deffn - @deffn GenericFunction delete-selection self Removes the subset of items from @var{self} that are in the @samp{selected} state. For a @ref{control} with a text field @@ -159,6 +154,11 @@ selected text. @end deffn +@deffn GenericFunction delete-span self @ref{span} +Removes the content from @var{self} whose zero-based indices lie within +the specified @var{span}. +@end deffn + @deffn GenericFunction display-to-object self pnt Return a point that is the result of transforming the specified point from display-relative coordinates to this object's coordinate system. Modified: trunk/src/tests/uitoolkit/item-manager-unit-tests.lisp ============================================================================== --- trunk/src/tests/uitoolkit/item-manager-unit-tests.lisp (original) +++ trunk/src/tests/uitoolkit/item-manager-unit-tests.lisp Fri Sep 8 23:02:05 2006 @@ -69,6 +69,14 @@ :handle *test-hwnd*))))) (validate-item-array values (gfw::copy-item-sequence *test-hwnd* tmp 'mock-item) *test-hwnd*)))) +(define-test item-manager-positions-test + (let* ((values '(a b c)) + (mgr (make-instance 'mock-item-manager :items values)) + (items (slot-value mgr 'gfw::items))) + (assert-equal 0 (gfw:item-index mgr (elt items 0))) + (assert-equal 1 (gfw:item-index mgr (elt items 1))) + (assert-equal 2 (gfw:item-index mgr (elt items 2))))) + (define-test item-manager-modifications-test (let ((values1 '(a b c)) (values2 '(1 2 3)) @@ -113,7 +121,7 @@ (validate-item 1 (first tmp) nil nil) (assert-equal 3 (length (gfw:items-of mgr2))) (loop for actual in (gfw:items-of mgr2) - for expected in (subseq (append values2 '(4)) 1 4) + for expected in (mapcar (lambda (x) (1+ x)) (subseq values2 0 3)) do (validate-item expected actual nil *test-hwnd*))) ;; delete last item from mgr3 (using dispose) @@ -129,6 +137,6 @@ (assert-equal 3 (length (gfw:items-of mgr1))) (loop for actual in (gfw:items-of mgr1) for expected in (subseq (append values2 '(4)) 1 4) - do (validate-item expected actual nil *test-hwnd*))) + do (validate-item expected actual nil *default-hwnd*))) (gfw::delete-widget (gfw::thread-context) *default-hwnd*))))) Modified: trunk/src/tests/uitoolkit/misc-unit-tests.lisp ============================================================================== --- trunk/src/tests/uitoolkit/misc-unit-tests.lisp (original) +++ trunk/src/tests/uitoolkit/misc-unit-tests.lisp Fri Sep 8 23:02:05 2006 @@ -102,3 +102,88 @@ (assert-equal 3 (length result1)) (assert-equal 3 (length result2)) (validate-array-elements result1 result2)))) + +(define-test remove-element-list-test + (let ((orig '(a b c)) + (remainder nil)) + (multiple-value-bind (tmp victim) (gfs::remove-element orig 1 nil) + (setf remainder tmp) + (assert-equal 2 (length tmp)) + (assert-eql 'a (first tmp)) + (assert-eql 'c (second tmp)) + (assert-eql 'b victim)) + (multiple-value-bind (tmp victim) (gfs::remove-element remainder 1 nil) + (setf remainder tmp) + (assert-equal 1 (length tmp)) + (assert-eql 'a (first tmp)) + (assert-eql 'c victim)) + (multiple-value-bind (tmp victim) (gfs::remove-element remainder 0 nil) + (assert-false tmp) + (assert-eql 'a victim)))) + +(define-test remove-elements-list-test + (let ((orig '(a b c d e f)) + (remainder nil)) + (multiple-value-bind (tmp victims) + (gfs::remove-elements orig (gfs:make-span :start 2 :end 4) nil) + (setf remainder tmp) + (assert-equal 3 (length victims)) + (assert-eql 'c (first victims)) + (assert-eql 'd (second victims)) + (assert-eql 'e (third victims)) + (assert-equal 3 (length tmp)) + (assert-eql 'a (first tmp)) + (assert-eql 'b (second tmp)) + (assert-eql 'f (third tmp))) + (multiple-value-bind (tmp victims) + (gfs::remove-elements remainder (gfs:make-span :start 0 :end 1) nil) + (setf remainder tmp) + (assert-equal 2 (length victims)) + (assert-eql 'a (first victims)) + (assert-eql 'b (second victims)) + (assert-equal 1 (length tmp)) + (assert-eql 'f (first tmp))) + (multiple-value-bind (tmp victims) + (gfs::remove-elements remainder (gfs:make-span :start 0 :end 0) nil) + (assert-false tmp) + (assert-equal 1 (length victims)) + (assert-eql 'f (first victims))))) + +(define-test remove-element-non-adjustable-array-test + (let ((orig (make-array 3 :initial-contents '(a b c))) + (tmp nil)) + (setf tmp (gfs::remove-element orig 1 (lambda () (make-array 2)))) + (assert-false (array-has-fill-pointer-p tmp)) + (assert-false (adjustable-array-p tmp)) + (assert-equal 2 (length tmp)) + (assert-eql 'a (elt tmp 0)) + (assert-eql 'c (elt tmp 1)) + (setf tmp (gfs::remove-element tmp 1 (lambda () (make-array 1)))) + (assert-equal 1 (length tmp)) + (assert-eql 'a (elt tmp 0)) + (assert-false (gfs::remove-element tmp 0 (lambda () (make-array 0)))))) + +(defun reaam-test-make-array () + (make-array 10 :fill-pointer 0 :adjustable t)) + +(define-test remove-elements-adjustable-array-test + (let ((orig (reaam-test-make-array)) + (tmp nil)) + (loop for item in '(a b c d e f) do (vector-push-extend item orig)) + (setf tmp (gfs::remove-elements orig + (gfs:make-span :start 2 :end 4) + #'reaam-test-make-array)) + (assert-true (array-has-fill-pointer-p tmp)) + (assert-true (adjustable-array-p tmp)) + (assert-equal 3 (length tmp)) + (assert-eql 'a (elt tmp 0)) + (assert-eql 'b (elt tmp 1)) + (assert-eql 'f (elt tmp 2)) + (setf tmp (gfs::remove-elements tmp + (gfs:make-span :start 0 :end 1) + #'reaam-test-make-array)) + (assert-equal 1 (length tmp)) + (assert-eql 'f (elt tmp 0)) + (assert-false (gfs::remove-elements tmp + (gfs:make-span :start 0 :end 0) + #'reaam-test-make-array)))) Modified: trunk/src/tests/uitoolkit/widget-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/widget-tester.lisp (original) +++ trunk/src/tests/uitoolkit/widget-tester.lisp Fri Sep 8 23:02:05 2006 @@ -76,6 +76,7 @@ (defun move-lb-content (orig-lb dest-lb) (let ((sel-items (gfw:selected-items orig-lb))) + (gfw:delete-selection orig-lb) (if sel-items (setf (gfw:items-of dest-lb) (append sel-items (gfw:items-of dest-lb)))))) Modified: trunk/src/uitoolkit/system/system-utils.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-utils.lisp (original) +++ trunk/src/uitoolkit/system/system-utils.lisp Fri Sep 8 23:02:05 2006 @@ -65,15 +65,51 @@ (dotimes (i (length tmp)) (setf (elt result i) (second (elt tmp i)))))) result)) -(defun pick-elements (lisp-seq indices &optional count) +(defun pick-elements (sequence indices &optional count) (let ((picks nil)) (if (cffi:pointerp indices) (dotimes (i count) - (push (elt lisp-seq (mem-aref indices :unsigned-int i)) picks)) + (push (elt sequence (mem-aref indices :unsigned-int i)) picks)) (dotimes (i (length indices)) - (push (elt lisp-seq (elt indices i)) picks))) + (push (elt sequence (elt indices i)) picks))) (reverse picks))) +(defun add-element (element sequence index) + (cond + ((listp sequence) + (push element sequence)) + ((adjustable-array-p sequence) + (vector-push-extend element sequence)) + (t + (setf (elt sequence index) element))) + sequence) + +(defun remove-element (sequence index creator) + (let ((result nil) + (victim nil)) + (dotimes (i (length sequence)) + (if (= i index) + (setf victim (elt sequence i)) + (setf result (add-element (elt sequence i) + (or result (if creator (funcall creator) nil)) + (if victim (1- i) i))))) + (if (listp result) + (values (reverse result) victim) + (values result victim)))) + +(defun remove-elements (sequence span creator) + (let ((result nil) + (victims nil)) + (dotimes (i (length sequence)) + (if (and (>= i (gfs:span-start span)) (<= i (gfs:span-end span))) + (push (elt sequence i) victims) + (setf result (add-element (elt sequence i) + (or result (if creator (funcall creator) nil)) + (- i (length victims)))))) + (if (listp result) + (values (reverse result) (reverse victims)) + (values result (reverse victims))))) + (defun flatten (tree) (if (cl:atom tree) (list tree) Modified: trunk/src/uitoolkit/widgets/item-manager.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/item-manager.lisp (original) +++ trunk/src/uitoolkit/widgets/item-manager.lisp Fri Sep 8 23:02:05 2006 @@ -61,7 +61,9 @@ (dotimes (i (length new-items)) (let ((item (elt new-items i))) (if (typep item item-class) - (vector-push-extend item replacements) + (progn + (setf (slot-value item 'gfs:handle) handle) + (vector-push-extend item replacements)) (let ((tmp (make-instance item-class :handle handle :data item))) (put-item tc tmp) (vector-push-extend tmp replacements))))) @@ -69,7 +71,9 @@ ((listp new-items) (loop for item in new-items do (if (typep item item-class) - (vector-push-extend item replacements) + (progn + (setf (slot-value item 'gfs:handle) handle) + (vector-push-extend item replacements)) (let ((tmp (make-instance item-class :handle handle :data item))) (put-item tc tmp) (vector-push-extend tmp replacements)))) @@ -98,17 +102,21 @@ (error 'gfs:disposed-error))) (defmethod delete-item ((self item-manager) index) - (let* ((items (slot-value self 'items)) - (it (elt items index))) - (setf (slot-value self 'items) (remove it items :test #'items-equal)) - (gfs:dispose it))) + (multiple-value-bind (new-items victim) + (gfs::remove-element (slot-value self 'items) index #'make-items-array) + (setf (slot-value self 'items) new-items) + (gfs:dispose victim))) -(defmethod delete-item-span :before ((self item-manager) (sp gfs:span)) +(defmethod delete-selection :before ((self item-manager)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + +(defmethod delete-span :before ((self item-manager) (sp gfs:span)) (declare (ignore sp)) (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod delete-item-span ((self item-manager) (sp gfs:span)) +(defmethod delete-span ((self item-manager) (sp gfs:span)) (dotimes (i (1+ (- (gfs:span-end sp) (gfs:span-start sp)))) (delete-item self (gfs:span-start sp)))) @@ -127,7 +135,7 @@ (let ((pos (position it (slot-value self 'items) :test #'items-equal))) (if (null pos) (return-from item-index 0)) - 0)) + pos)) (defmethod items-of ((self item-manager)) (coerce (slot-value self 'items) 'list)) 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 8 23:02:05 2006 @@ -116,6 +116,13 @@ (lb-delete-all self) (setf (slot-value self 'items) (make-items-array))) +(defmethod delete-selection ((self list-box)) + (enable-redraw self nil) + (unwind-protect + (loop for item in (selected-items self) + do (gfs:dispose item)) + (enable-redraw self t))) + (defmethod initialize-instance :after ((self list-box) &key estimated-count items parent &allow-other-keys) (initialize-comctl-classes gfs::+icc-standard-classes+) (multiple-value-bind (std-style ex-style) @@ -214,6 +221,8 @@ (defmethod update-from-items ((self list-box)) (let ((sort-func (sort-predicate-of self)) (hwnd (gfs:handle self))) + (unless (zerop (lb-item-count hwnd)) + (error 'gfs:toolkit-error :detail "list-box has existing content")) (when sort-func (setf (slot-value self 'items) (gfs::indexed-sort (slot-value self 'items) sort-func #'data-of))) (enable-redraw self nil) @@ -222,6 +231,5 @@ (dotimes (index (length items)) (let* ((item (elt items index)) (text (call-text-provider self (data-of item)))) - (setf (index-of item) index) (lb-insert-item hwnd #xFFFFFFFF text (cffi:null-pointer))))) (enable-redraw self t)))) 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 8 23:02:05 2006 @@ -70,17 +70,9 @@ ;;; (defmethod gfs:dispose ((self list-item)) - (let ((index (index-of self)) - (howner (gfs:handle self))) - (if howner - (gfs::send-message howner gfs::+lb-deletestring+ index 0)) - (setf (index-of self) 0)) + (let ((hwnd (gfs:handle self))) + (unless (or (null hwnd) (cffi:null-pointer-p hwnd)) + (let ((owner (get-widget (thread-context) hwnd))) + (if (and owner (cffi:pointer-eq hwnd (gfs:handle owner))) + (gfs::send-message hwnd gfs::+lb-deletestring+ (item-index owner self) 0))))) (call-next-method)) - -(defmethod print-object ((self list-item) stream) - (print-unreadable-object (self stream :type t) - (format stream "id: ~d " (item-id self)) - (format stream "index: ~d " (index-of self)) - (format stream "data: ~a " (data-of self)) - (format stream "handle: ~x " (gfs:handle self)) - (format stream "dispatcher: ~a" (dispatcher self)))) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Fri Sep 8 23:02:05 2006 @@ -90,10 +90,7 @@ :allocation :class)) ; shadowing same slot from event-source (:documentation "The item class is the base class for all non-windowed user interface objects.")) -(defclass list-item (item) - ((index - :accessor index-of - :initform 0)) +(defclass list-item (item) () (:documentation "A subclass of item representing an element of a list-box.")) (defclass menu-item (item) () Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Fri Sep 8 23:02:05 2006 @@ -135,12 +135,12 @@ (defgeneric delete-item (self index) (:documentation "Removes the item at the zero-based index from the object.")) -(defgeneric delete-item-span (self span) - (:documentation "Removes the sequence of items represented by the specified span object.")) - (defgeneric delete-selection (self) (:documentation "Removes items from self that are in the selected state.")) +(defgeneric delete-span (self span) + (:documentation "Removes the sequence of items represented by the specified span object.")) + (defgeneric disabled-image (self) (:documentation "Returns the image used to render this item with a disabled look.")) @@ -213,6 +213,12 @@ (defgeneric item-index (self item) (:documentation "Return the zero-based index of the location of the other object in this object.")) +(defgeneric items-of (self) + (:documentation "Returns a list of item subclasses representing the content of self.")) + +(defgeneric (setf items-of) (items self) + (:documentation "Accepts a list of application data (or list subclasses) to set the content of self.")) + (defgeneric layout (self) (:documentation "Set the size and location of this object's children.")) Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Fri Sep 8 23:02:05 2006 @@ -165,20 +165,11 @@ (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod delete-item :before ((self widget) index) - (declare (ignore index)) - (if (gfs:disposed-p self) - (error 'gfs:disposed-error))) - -(defmethod delete-item-span :before ((self widget) span) +(defmethod delete-span :before ((self widget) span) (declare (ignore span)) (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod delete-selection :before ((self widget)) - (if (gfs:disposed-p self) - (error 'gfs:disposed-error))) - (defmethod gfs:dispose ((self widget)) (unless (null (dispatcher self)) (event-dispose (dispatcher self) self))

1 0

[graphic-forms-cvs] r251 - in trunk: . docs/manual src src/tests/uitoolkit src/uitoolkit/widgets
by junrue＠common-lisp.net 08 Sep '06

08 Sep '06

Author: junrue Date: Fri Sep 8 11:32:27 2006 New Revision: 251 Added: trunk/src/tests/uitoolkit/item-manager-unit-tests.lisp Modified: trunk/docs/manual/reference.texinfo trunk/docs/manual/widget-functions.texinfo trunk/src/packages.lisp trunk/src/tests/uitoolkit/layout-unit-tests.lisp trunk/src/tests/uitoolkit/mock-objects.lisp trunk/src/uitoolkit/widgets/item-manager.lisp trunk/src/uitoolkit/widgets/item.lisp trunk/src/uitoolkit/widgets/list-box.lisp trunk/src/uitoolkit/widgets/list-item.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp trunk/tests.lisp Log: added unit-tests for item-manager, fixed more bugs Modified: trunk/docs/manual/reference.texinfo ============================================================================== --- trunk/docs/manual/reference.texinfo (original) +++ trunk/docs/manual/reference.texinfo Fri Sep 8 11:32:27 2006 @@ -70,7 +70,7 @@ @end macro @macro apps-shouldnt-call-function -This function should typically not be called from application code. +This function is not intended to be called from application code. @end macro @macro event-dispatcher-arg Modified: trunk/docs/manual/widget-functions.texinfo ============================================================================== --- trunk/docs/manual/widget-functions.texinfo (original) +++ trunk/docs/manual/widget-functions.texinfo Fri Sep 8 11:32:27 2006 @@ -36,13 +36,13 @@ @anchor{auto-hscroll-p} @deffn GenericFunction auto-hscroll-p self => boolean -Returns T if @code{self} is configured for automatic horizontal scrolling; +Returns T if @var{self} is configured for automatic horizontal scrolling; @sc{nil} otherwise. See @ref{auto-vscroll-p} and @ref{enable-auto-scrolling}. @end deffn @anchor{auto-vscroll-p} @deffn GenericFunction auto-vscroll-p self => boolean -Returns T if @code{self} is configured for automatic vertical scrolling; +Returns T if @var{self} is configured for automatic vertical scrolling; @sc{nil} otherwise. See @ref{auto-hscroll-p} and @ref{enable-auto-scrolling}. @end deffn @@ -56,9 +56,9 @@ @anchor{capture-mouse} @defun capture-mouse self -Enables the @ref{window} identified by @code{self} to receive mouse +Enables the @ref{window} identified by @var{self} to receive mouse input events even when the mouse pointer is outside of the bounds -of @code{self}. Only one window at a time can capture the mouse. This +of @var{self}. Only one window at a time can capture the mouse. This function is primarily intended for use with a window in the foreground; background windows may still capture the mouse, but only mouse move events will be received and those only when the mouse hotspot is within @@ -67,15 +67,15 @@ @anchor{center-on-owner} @deffn GenericFunction center-on-owner self -Position @code{self} such that it is centrally located relative to its -@ref{owner}, based on @code{self}'s current outermost size. +Position @var{self} such that it is centrally located relative to its +@ref{owner}, based on @var{self}'s current outermost size. See also @ref{center-on-parent}. @end deffn @anchor{center-on-parent} @deffn GenericFunction center-on-parent self -Position @code{self} such that it is centrally located relative to its -@ref{parent}, based on @code{self}'s current outermost size. +Position @var{self} such that it is centrally located relative to its +@ref{parent}, based on @var{self}'s current outermost size. See also @ref{center-on-owner}. @end deffn @@ -93,7 +93,7 @@ @end deffn @deffn GenericFunction compute-style-flags self &rest extra-data -Convert a list of keyword symbols in the object's @code{style} slot to +Convert a list of keyword symbols in the object's @var{style} slot to a values pair of native bitmasks; the first conveys normal/standard flags, whereas the second any extended flags that the system supports. @end deffn @@ -106,8 +106,8 @@ @anchor{copy-text} @deffn GenericFunction copy-text self This function is a shortcut for a common clipboard transfer operation, -namely the transfer of text from @code{self} to the system clipboard. -The existing content of @code{self} remains in place. Some @ref{control}s +namely the transfer of text from @var{self} to the system clipboard. +The existing content of @var{self} remains in place. Some @ref{control}s like the @ref{edit} control have built-in clipboard functionality, and in such cases, the implementation of this function delegates directly. See @ref{cut-text}, @ref{paste-text}, and @ref{text-for-pasting-p}.@*@* @@ -118,8 +118,8 @@ @anchor{cut-text} @deffn GenericFunction cut-text self This function is a shortcut for a common clipboard transfer operation, -namely the transfer of text from @code{self} to the system clipboard -and removal of content from @code{self}. Some @ref{control}s like the +namely the transfer of text from @var{self} to the system clipboard +and removal of content from @var{self}. Some @ref{control}s like the @ref{edit} control have built-in clipboard functionality, and in such cases, the implementation of this function delegates directly. For other @ref{widget}s, this operation is a wrapper around a copy/delete @@ -135,12 +135,12 @@ Returns the default @ref{widget} set for a @ref{dialog}, or @sc{nil} if none has been set. If @sc{nil} is passed to the corresponding @sc{setf} function, then no default widget is set. The default widget -is the one that is selected when @code{self} is active and the user +is the one that is selected when @var{self} is active and the user presses @sc{enter}. @end deffn @deffn GenericFunction delete-all self -Removes all content from @code{self}. +Removes all content from @var{self}. @end deffn @deffn GenericFunction delete-item self index @@ -204,7 +204,7 @@ Specifying T for @var{horizontal} (@var{vertical}) reveals a scrollbar to attached to the right-hand (bottom) of @var{self}. Specifying @sc{nil} hides the scrollbar. These flags do -not affect scrolling behavior in @code{self} -- they only control +not affect scrolling behavior in @var{self} -- they only control scrollbar visibility. See @ref{horizontal-scrollbar-p} and @ref{vertical-scrollbar-p}. @end deffn @@ -224,7 +224,7 @@ @end defun @deffn GenericFunction focus-p self -Returns @sc{t} if @code{self} currently has keyboard focus; @sc{nil} +Returns @sc{t} if @var{self} currently has keyboard focus; @sc{nil} otherwise. @end deffn @@ -233,7 +233,7 @@ Interrogates the data structure associated with an instance of @ref{font-dialog} to obtain the @ref{font} and @ref{color} corresponding to selections made by the user, and returns -them via @sc{values}. The @code{gc} parameter should be the same +them via @sc{values}. The @var{gc} parameter should be the same @ref{graphics-context} object with which the dialog was created. If the user cancelled the dialog, the font value will be @sc{nil}. Also, the color value will be @sc{nil} if the dialog was created with @@ -242,12 +242,12 @@ @end defun @deffn GenericFunction give-focus self -Places keyboard focus on @code{self}. +Places keyboard focus on @var{self}. @end deffn @anchor{horizontal-scrollbar-p} @deffn GenericFunction horizontal-scrollbar-p self => boolean -Returns T if @code{self} has been configured to display a horizontal +Returns T if @var{self} has been configured to display a horizontal scrollbar; @sc{nil} otherwise. @xref{enable-scrollbars}. @end deffn @@ -270,7 +270,7 @@ @anchor{line-count} @deffn GenericFunction line-count self => integer -Returns the total number of lines (e.g., of text) contained by @code{self}. +Returns the total number of lines (e.g., of text) contained by @var{self}. @end deffn @deffn GenericFunction location self => @ref{point} @@ -281,9 +281,9 @@ @end deffn @deffn GenericFunction mapchildren self func => result-list -Calls @code{func}, which is a function of two arguments, for each -child of @code{self} and places @code{func}'s return value in -@code{result-list}. @code{func}'s two arguments are @code{self} and +Calls @var{func}, which is a function of two arguments, for each +child of @var{self} and places @var{func}'s return value in +@var{result-list}. @var{func}'s two arguments are @var{self} and the current child. @end deffn @@ -343,8 +343,8 @@ @anchor{owner} @deffn GenericFunction owner self -Returns the @code{owner} of @code{self}, which may be different from -@code{self}'s @ref{parent} because the window ownership hierarchy +Returns the @var{owner} of @var{self}, which may be different from +@var{self}'s @ref{parent} because the window ownership hierarchy includes the relationships between physically separate @ref{top-level}s and dialogs. And it is possible for a window to be unowned but still have a @ref{parent}. Consequently, calling @@ -370,7 +370,7 @@ @anchor{parent} @deffn GenericFunction parent self => @ref{window} -Returns the @code{parent} of @code{self}. In the case of @ref{panel}s +Returns the @code{parent} of @var{self}. In the case of @ref{panel}s and @ref{control}s, this will be the ancestor dialog, @ref{panel}, or @ref{top-level} window. In the case of a dialog or @ref{top-level}, then a @ref{root-window} is returned. In the case of a @code{submenu}, @@ -391,8 +391,8 @@ @anchor{paste-text} @deffn GenericFunction paste-text self This function is a shortcut for a common clipboard transfer operation, -namely the transfer of text from the system clipboard to @code{self}. -Depending on the current selection within @code{self}, the text either +namely the transfer of text from the system clipboard to @var{self}. +Depending on the current selection within @var{self}, the text either gets inserted or existing content is replaced. Some @ref{control}s like the @ref{edit} control have built-in clipboard functionality, and in such cases, the implementation of this function delegates directly. See @@ -403,12 +403,12 @@ @anchor{preferred-size} @deffn GenericFunction preferred-size self width-hint height-hint -Implement this function to return @code{self}'s preferred @ref{size}; -that is, the dimensions that @code{self} computes as being the best +Implement this function to return @var{self}'s preferred @ref{size}; +that is, the dimensions that @var{self} computes as being the best fit for itself and/or its children. If one or both of -@code{width-hint} and @code{height-hint} are positive, then each such +@var{width-hint} and @var{height-hint} are positive, then each such parameter is used as a constraint on the @ref{size} calculation -- if -for example @code{width-hint} is some positive value, then @code{self} +for example @var{width-hint} is some positive value, then @var{self} must determine how tall it would be given that width. @end deffn @@ -418,7 +418,7 @@ @end defun @deffn GenericFunction redo-available-p self => boolean -Returns T if @code{self} has @sc{redo} capability and has an +Returns T if @var{self} has @sc{redo} capability and has an operation that can be redone; @sc{nil} otherwise. @end deffn @@ -436,11 +436,11 @@ @deffn GenericFunction resizable-p self => boolean (setf (@strong{resizable-p} @var{self}) @var{boolean})@* -Returns T if @code{self} can be resized by the user; @sc{nil} +Returns T if @var{self} can be resized by the user; @sc{nil} otherwise. The corresponding @sc{setf} function is implemented for the @ref{top-level} class (but only has meaning when the @code{:frame} or @code{:workspace} styles are set), allowing the application to -modify the resizability of @code{self}, whereupon the frame +modify the resizability of @var{self}, whereupon the frame decorations are modified appropriately. @end deffn @@ -514,14 +514,14 @@ @deffn GenericFunction text self => string (setf (@strong{text} @var{self}) @var{string})@* -For a @ref{window} or @ref{dialog}, this function returns @code{self}'s +For a @ref{window} or @ref{dialog}, this function returns @var{self}'s titlebar text (which may be blank). For other @ref{widget}s that have a text component, this function returns that text component. For anything else, this function returns @sc{nil}. @end deffn @deffn GenericFunction text-baseline self => integer -Returns the y coordinate value (relative to the top of @code{self}'s +Returns the y coordinate value (relative to the top of @var{self}'s bounding box) that correlates to the baseline of the text of the @ref{control}, if any. For controls in which a text baseline is not meaningful, such as a @ref{label} with an @ref{image}, this function @@ -544,7 +544,7 @@ @anchor{text-modified-p} @deffn GenericFunction text-modified-p self => boolean (setf (@strong{text-modified-p} @var{self}) @var{boolean})@*@* -Returns T if the text component of @code{self} has been modified by +Returns T if the text component of @var{self} has been modified by the user; @sc{nil} otherwise. The corresponding @sc{setf} function updates the dirty state flag. This function is not implemented for all widgets, since in some cases there are multiple text components and in @@ -553,7 +553,7 @@ @anchor{undo-available-p} @deffn GenericFunction undo-available-p self => boolean -Returns T if @code{self} has @sc{undo} capability and has an +Returns T if @var{self} has @sc{undo} capability and has an operation that can be undone; @sc{nil} otherwise. @end deffn @@ -584,7 +584,7 @@ @anchor{vertical-scrollbar-p} @deffn GenericFunction vertical-scrollbar-p self => boolean -Returns T if @code{self} has been configured to display a vertical +Returns T if @var{self} has been configured to display a vertical scrollbar; @sc{nil} otherwise. @xref{enable-scrollbars}. @end deffn @@ -595,7 +595,7 @@ @html @deffn GenericFunction window->display self Return the @ref{display} object representing the monitor that is nearest -to @code{self}. The @ref{rectangle} bounding @code{self} is not required +to @var{self}. The @ref{rectangle} bounding @var{self} is not required to intersect the returned @ref{display}. @end deffn @end html Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Fri Sep 8 11:32:27 2006 @@ -368,6 +368,7 @@ #:cut-text #:current-font #:cursor + #:data-of #:default-message-filter #:default-widget #:defmenu Added: trunk/src/tests/uitoolkit/item-manager-unit-tests.lisp ============================================================================== --- (empty file) +++ trunk/src/tests/uitoolkit/item-manager-unit-tests.lisp Fri Sep 8 11:32:27 2006 @@ -0,0 +1,134 @@ +;;;; +;;;; item-manager-unit-tests.lisp +;;;; +;;;; Copyright (C) 2006, Jack D. Unrue +;;;; All rights reserved. +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; +;;;; 3. Neither the names of the authors nor the names of its contributors +;;;; may be used to endorse or promote products derived from this software +;;;; without specific prior written permission. +;;;; +;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY +;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS- +;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY +;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;;;; + +(in-package :graphic-forms.uitoolkit.tests) + +(defvar *test-hwnd* (cffi:make-pointer 1)) + +(defun validate-item (expected actual &optional expected-id (expected-hwnd *default-hwnd*)) + (assert-true (typep actual 'mock-item)) + (if expected-id + (assert-equal expected-id (gfw:item-id actual)) + (assert-false (zerop (gfw::item-id actual)))) + (if expected-hwnd + (assert-equality #'cffi:pointer-eq expected-hwnd (gfs:handle actual)) + (assert-equality #'eql expected-hwnd (gfs:handle actual))) + (assert-equality #'equal expected (gfw:data-of actual))) + +(defun validate-item-array (expected array &optional (expected-hwnd *default-hwnd*)) + (assert-true (vectorp array)) + (assert-true (array-has-fill-pointer-p array)) + (assert-true (adjustable-array-p array)) + (assert-equal (length expected) (length array)) + (dotimes (i (length array)) + (validate-item (elt expected i) (elt array i) nil expected-hwnd))) + +(define-test copy-item-sequence-test + (let ((values '(a b c))) + (validate-item-array values (gfw::copy-item-sequence *test-hwnd* values 'mock-item) *test-hwnd*) + (let ((tmp (loop for datum in values + collect (make-instance 'mock-item :data datum + :handle *test-hwnd*)))) + (validate-item-array values (gfw::copy-item-sequence *test-hwnd* tmp 'mock-item) *test-hwnd*)) + (let ((tmp (make-array 3 :initial-contents (loop for datum in values + collect datum)))) + (validate-item-array values (gfw::copy-item-sequence *test-hwnd* tmp 'mock-item) *test-hwnd*)) + (let ((tmp (make-array 3 :initial-contents (loop for datum in values + collect (make-instance 'mock-item + :data datum + :handle *test-hwnd*))))) + (validate-item-array values (gfw::copy-item-sequence *test-hwnd* tmp 'mock-item) *test-hwnd*)))) + +(define-test item-manager-modifications-test + (let ((values1 '(a b c)) + (values2 '(1 2 3)) + (disp (make-instance 'gfw:event-dispatcher))) + (let ((mgr1 (make-instance 'mock-item-manager :items values1)) + (mgr2 (make-instance 'mock-item-manager :items values2 :handle *test-hwnd*)) + (mgr3 (make-instance 'mock-item-manager))) + + (gfw::put-widget (gfw::thread-context) mgr3) + (unwind-protect + (progn + + ;; sanity check initial states + ;; + (validate-item-array values1 (slot-value mgr1 'gfw::items)) + (validate-item-array values2 (slot-value mgr2 'gfw::items) *test-hwnd*) + (assert-true (zerop (length (slot-value mgr3 'gfw::items)))) + + ;; append a new item to each and sanity check again + ;; + (gfw:append-item mgr1 'd disp) + (validate-item-array (append values1 '(d)) (slot-value mgr1 'gfw::items)) + (gfw:append-item mgr2 4 disp) + (validate-item-array (append values2 '(4)) (slot-value mgr2 'gfw::items) *test-hwnd*) + (gfw:append-item mgr3 t disp) + (validate-item-array (list t) (slot-value mgr3 'gfw::items)) + + ;; delete all from mgr1 + ;; + (let ((tmp (gfw:items-of mgr1))) + (assert-equal 4 (length tmp)) + (gfw:delete-all mgr1) + (assert-true (zerop (length (gfw:items-of mgr1)))) + (loop for actual in tmp + for expected in (append values1 '(d)) + do (validate-item expected actual nil nil))) + + ;; delete an item from mgr2 (using delete-item) + ;; + (let ((tmp (gfw:items-of mgr2))) + (gfw:delete-item mgr2 0) + (validate-item 1 (first tmp) nil nil) + (assert-equal 3 (length (gfw:items-of mgr2))) + (loop for actual in (gfw:items-of mgr2) + for expected in (subseq (append values2 '(4)) 1 4) + do (validate-item expected actual nil *test-hwnd*))) + + ;; delete last item from mgr3 (using dispose) + ;; + (let ((tmp (gfw:items-of mgr3))) + (gfs:dispose (first tmp)) + (assert-true (zerop (length (gfw:items-of mgr3)))) + (validate-item t (first tmp) nil nil)) + + ;; copy items from mgr2 to mgr1 + ;; + (setf (gfw:items-of mgr1) (gfw:items-of mgr2)) + (assert-equal 3 (length (gfw:items-of mgr1))) + (loop for actual in (gfw:items-of mgr1) + for expected in (subseq (append values2 '(4)) 1 4) + do (validate-item expected actual nil *test-hwnd*))) + + (gfw::delete-widget (gfw::thread-context) *default-hwnd*))))) Modified: trunk/src/tests/uitoolkit/layout-unit-tests.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-unit-tests.lisp (original) +++ trunk/src/tests/uitoolkit/layout-unit-tests.lisp Fri Sep 8 11:32:27 2006 @@ -34,8 +34,8 @@ (in-package :graphic-forms.uitoolkit.tests) (define-test layout-attributes-test - (let ((widget1 (make-instance 'mock-widget :handle 1234)) - (widget2 (make-instance 'mock-widget :handle 5678))) + (let ((widget1 (make-instance 'mock-widget :handle (cffi:make-pointer 1234))) + (widget2 (make-instance 'mock-widget :handle (cffi:make-pointer 5678)))) (let ((data1 `(,widget1 (a 1 b 2))) (data2 `(,widget2 (a 10 c 30))) (layout (make-instance 'gfw:layout-manager))) Modified: trunk/src/tests/uitoolkit/mock-objects.lisp ============================================================================== --- trunk/src/tests/uitoolkit/mock-objects.lisp (original) +++ trunk/src/tests/uitoolkit/mock-objects.lisp Fri Sep 8 11:32:27 2006 @@ -37,6 +37,8 @@ (defconstant +default-container-width+ 300) (defconstant +default-container-height+ 200) +(defvar *default-hwnd* (cffi:make-pointer #xFFFFFFFF)) + ;;; ;;; stand-in for a window, used as parent of mock-widget ;;; @@ -80,19 +82,19 @@ :initarg :min-size :initform (gfs:make-size)))) -(defmethod initialize-instance :after ((widget mock-widget) &key handle &allow-other-keys) - (setf (slot-value widget 'gfs:handle) (cffi:make-pointer (or handle #xFFFFFFFF)))) +(defmethod initialize-instance :after ((self mock-widget) &key handle &allow-other-keys) + (setf (slot-value self 'gfs:handle) (or handle *default-hwnd*))) -(defmethod gfw:location ((widget mock-widget)) +(defmethod gfw:location ((self mock-widget)) (gfs:make-point)) -(defmethod gfw:minimum-size ((widget mock-widget)) - (gfs:make-size :width (gfs:size-width (min-size-of widget)) - :height (gfs:size-height (min-size-of widget)))) +(defmethod gfw:minimum-size ((self mock-widget)) + (gfs:make-size :width (gfs:size-width (min-size-of self)) + :height (gfs:size-height (min-size-of self)))) -(defmethod gfw:preferred-size ((widget mock-widget) width-hint height-hint) +(defmethod gfw:preferred-size ((self mock-widget) width-hint height-hint) (let ((size (gfs:make-size)) - (min-size (min-size-of widget))) + (min-size (min-size-of self))) (if (< width-hint 0) (setf (gfs:size-width size) (gfs:size-width min-size)) (setf (gfs:size-width size) width-hint)) @@ -101,8 +103,30 @@ (setf (gfs:size-height size) height-hint)) size)) -(defmethod gfw:text-baseline ((widget mock-widget)) - (floor (* (gfs:size-height (min-size-of widget)) 3) 4)) +(defmethod gfw:text-baseline ((self mock-widget)) + (floor (* (gfs:size-height (min-size-of self)) 3) 4)) + +(defmethod gfw:visible-p ((self mock-widget)) + (visibility-of self)) + +;;; +;;; infrastructure for item-manager unit tests +;;; + +(defclass mock-item (gfw:item) ()) + +(defclass mock-item-manager (gfw:widget gfw:item-manager) ()) + +(defmethod initialize-instance :after ((self mock-item-manager) &key handle items &allow-other-keys) + (setf (slot-value self 'gfs:handle) (or handle *default-hwnd*)) + (if items + (setf (slot-value self 'gfw::items) (gfw::copy-item-sequence (gfs:handle self) items 'mock-item)))) + +(defmethod gfw:append-item ((self mock-item-manager) thing (disp gfw:event-dispatcher) &optional checked disabled) + (declare (ignore disabled checked)) + (let ((item (gfw::create-item-with-callback (gfs:handle self) 'mock-item thing disp))) + (vector-push-extend item (slot-value self 'gfw::items)) + item)) -(defmethod gfw:visible-p ((widget mock-widget)) - (visibility-of widget)) +(defmethod (setf gfw:items-of) (new-items (self mock-item-manager)) + (setf (slot-value self 'gfw::items) (gfw::copy-item-sequence (gfs:handle self) new-items 'mock-item))) Modified: trunk/src/uitoolkit/widgets/item-manager.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/item-manager.lisp (original) +++ trunk/src/uitoolkit/widgets/item-manager.lisp Fri Sep 8 11:32:27 2006 @@ -51,9 +51,8 @@ (t (funcall func thing))))) -(defun copy-item-sequence (parent new-items item-class) - (let ((hwnd (gfs:handle parent)) - (tc (thread-context)) +(defun copy-item-sequence (handle new-items item-class) + (let ((tc (thread-context)) (replacements (make-items-array))) (cond ((null new-items) @@ -63,7 +62,7 @@ (let ((item (elt new-items i))) (if (typep item item-class) (vector-push-extend item replacements) - (let ((tmp (make-instance item-class :handle hwnd :data item))) + (let ((tmp (make-instance item-class :handle handle :data item))) (put-item tc tmp) (vector-push-extend tmp replacements))))) replacements) @@ -71,7 +70,7 @@ (loop for item in new-items do (if (typep item item-class) (vector-push-extend item replacements) - (let ((tmp (make-instance item-class :handle hwnd :data item))) + (let ((tmp (make-instance item-class :handle handle :data item))) (put-item tc tmp) (vector-push-extend tmp replacements)))) replacements) @@ -101,9 +100,7 @@ (defmethod delete-item ((self item-manager) index) (let* ((items (slot-value self 'items)) (it (elt items index))) - (setf (slot-value self 'items) (remove it items :test #'items-equal-p)) - (if (gfs:disposed-p it) - (error 'gfs:disposed-error)) + (setf (slot-value self 'items) (remove it items :test #'items-equal)) (gfs:dispose it))) (defmethod delete-item-span :before ((self item-manager) (sp gfs:span)) @@ -127,7 +124,7 @@ (error 'gfs:disposed-error))) (defmethod item-index ((self item-manager) (it item)) - (let ((pos (position it (slot-value self 'items) :test #'items-equal-p))) + (let ((pos (position it (slot-value self 'items) :test #'items-equal))) (if (null pos) (return-from item-index 0)) 0)) Modified: trunk/src/uitoolkit/widgets/item.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/item.lisp (original) +++ trunk/src/uitoolkit/widgets/item.lisp Fri Sep 8 11:32:27 2006 @@ -51,7 +51,7 @@ :detail "callback must be a function, instance of gfw:event-dispatcher, or null"))) item)) -(defun items-equal-p (item1 item2) +(defun items-equal (item1 item2) (= (item-id item1) (item-id item2))) ;;; @@ -68,16 +68,13 @@ (error 'gfs:toolkit-error :detail "null owner handle"))) (defmethod gfs:dispose ((self item)) - (setf (dispatcher self) nil) (let ((hwnd (gfs:handle self))) (unless (or (null hwnd) (cffi:null-pointer-p hwnd)) (let ((owner (get-widget (thread-context) hwnd))) (if owner (setf (slot-value owner 'items) - (remove self (slot-value owner 'items) :test #'items-equal-p)))))) + (remove self (slot-value owner 'items) :test #'items-equal)))))) (delete-tc-item (thread-context) self) - (setf (data-of self) nil) - (setf (item-id self) 0) (setf (slot-value self 'gfs:handle) nil)) (defmethod initialize-instance :after ((self item) &key callback &allow-other-keys) 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 8 11:32:27 2006 @@ -134,12 +134,12 @@ estimated-count (* estimated-count +estimated-text-size+))))) (if items - (setf (slot-value self 'items) (copy-item-sequence self items 'list-item))) + (setf (slot-value self 'items) (copy-item-sequence (gfs:handle self) items 'list-item))) (update-from-items self)) (defmethod (setf items-of) (new-items (self list-box)) (lb-delete-all self) - (setf (slot-value self 'items) (copy-item-sequence self new-items 'list-item)) + (setf (slot-value self 'items) (copy-item-sequence (gfs:handle self) new-items 'list-item)) (update-from-items self)) (defmethod preferred-size ((self list-box) width-hint height-hint) 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 8 11:32:27 2006 @@ -70,7 +70,6 @@ ;;; (defmethod gfs:dispose ((self list-item)) -(print self) (let ((index (index-of self)) (howner (gfs:handle self))) (if howner 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 8 11:32:27 2006 @@ -55,6 +55,10 @@ (gfs:dispose ,gc))))) (defmacro with-drawing-disabled ((widget) &body body) + ;; FIXME: should this macro use enable-redraw instead? + ;; One immediate problem is that only one window can be + ;; locked at a time by LockWindowUpdate. + ;; (let ((tmp-widget (gensym))) `(let ((,tmp-widget ,widget)) (unwind-protect Modified: trunk/tests.lisp ============================================================================== --- trunk/tests.lisp (original) +++ trunk/tests.lisp Fri Sep 8 11:32:27 2006 @@ -45,4 +45,5 @@ (load (concatenate 'string *gf-tests-dir* "layout-unit-tests")) (load (concatenate 'string *gf-tests-dir* "flow-layout-unit-tests")) (load (concatenate 'string *gf-tests-dir* "widget-unit-tests")) + (load (concatenate 'string *gf-tests-dir* "item-manager-unit-tests")) (load (concatenate 'string *gf-tests-dir* "misc-unit-tests")))

1 0

[graphic-forms-cvs] r250 - in trunk: docs/manual src src/tests/uitoolkit src/uitoolkit/system src/uitoolkit/widgets
by junrue＠common-lisp.net 07 Sep '06

07 Sep '06

Author: junrue Date: Thu Sep 7 01:46:41 2006 New Revision: 250 Modified: trunk/docs/manual/reference.texinfo trunk/docs/manual/widget-functions.texinfo trunk/docs/manual/widget-types.texinfo trunk/src/packages.lisp trunk/src/tests/uitoolkit/widget-tester.lisp trunk/src/uitoolkit/system/system-utils.lisp trunk/src/uitoolkit/widgets/item-manager.lisp trunk/src/uitoolkit/widgets/item.lisp trunk/src/uitoolkit/widgets/list-box.lisp trunk/src/uitoolkit/widgets/list-item.lisp trunk/src/uitoolkit/widgets/menu.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/widget.lisp Log: revised item-manager protocol so that now we have selected-items and selected-span, implemented selected-items for list-box and fixed up menu implementation, more debugging/bugfixing via widget-tester Modified: trunk/docs/manual/reference.texinfo ============================================================================== --- trunk/docs/manual/reference.texinfo (original) +++ trunk/docs/manual/reference.texinfo Thu Sep 7 01:46:41 2006 @@ -69,6 +69,10 @@ @acronym{GFW} @end macro +@macro apps-shouldnt-call-function +This function should typically not be called from application code. +@end macro + @macro event-dispatcher-arg @item event-dispatcher The @ref{event-dispatcher} to process this event. Modified: trunk/docs/manual/widget-functions.texinfo ============================================================================== --- trunk/docs/manual/widget-functions.texinfo (original) +++ trunk/docs/manual/widget-functions.texinfo Thu Sep 7 01:46:41 2006 @@ -568,6 +568,8 @@ data structures) with data derived from the @var{items} slot. If @var{self} has been assigned a sorting predicate, the array of items will be sorted prior to the internal model update. + +@apps-shouldnt-call-function @end deffn @anchor{update-native-style} @@ -576,6 +578,8 @@ @var{integer} and calls any additional API needed to ensure that @var{self}'s visual representation is refreshed. The supplied @var{integer} is returned. + +@apps-shouldnt-call-function @end deffn @anchor{vertical-scrollbar-p} Modified: trunk/docs/manual/widget-types.texinfo ============================================================================== --- trunk/docs/manual/widget-types.texinfo (original) +++ trunk/docs/manual/widget-types.texinfo Thu Sep 7 01:46:41 2006 @@ -375,7 +375,8 @@ @begin-control-subclass{list-box, This @ref{control} subclass represents a list of selectable items; it also inherits @ref{item-manager}. The list is always visible\, unlike -a combo-box., +a combo-box. Each of the @code{-select} style keywords mentioned below +are exclusive., event-select} @control-callback-initarg{list-box,event-select} @deffn Initarg :estimated-count @@ -400,11 +401,13 @@ keys. @item :multiple-select This style keyword enables individual toggling of multiple item -selections within the list-box. Without this style, the list-box will -only allow a single selection. +selections within the list-box. @item :no-select This style keyword means that the list-box will display items but not allow any selections. +@item :single-select +This style keyword means that the list-box only allows one item at a +time to be selected. This is the default selection style. @item :tab-stops This style keyword configures the list-box to to expand tab characters when rendering item strings. Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Thu Sep 7 01:46:41 2006 @@ -520,7 +520,6 @@ #:trim-sizes #:undo-available-p #:update - #:update-from-items #:vertical-scrollbar #:visible-item-count #:visible-p Modified: trunk/src/tests/uitoolkit/widget-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/widget-tester.lisp (original) +++ trunk/src/tests/uitoolkit/widget-tester.lisp Thu Sep 7 01:46:41 2006 @@ -65,15 +65,50 @@ (gfg:foreground-color gc) color)) (gfg:draw-filled-rectangle gc (gfs:make-rectangle :size (gfw:client-size window)))) -(defun lb-select (disp lb) - (declare (ignore disp)) - (print lb)) +(defun manage-lb-button-states (lb move-btn all-btn none-btn) + (let ((count (gfw:selected-count lb)) + (items (gfw:items-of lb))) + (gfw:enable move-btn (> count 0)) + (if all-btn + (gfw:enable all-btn (< count (length items)))) + (if none-btn + (gfw:enable none-btn (> count 0))))) + +(defun move-lb-content (orig-lb dest-lb) + (let ((sel-items (gfw:selected-items orig-lb))) + (if sel-items + (setf (gfw:items-of dest-lb) (append sel-items (gfw:items-of dest-lb)))))) (defun populate-list-box-test-panel () (setf (gfw:text *widget-tester-win*) "Widget Tester (List Boxes)") (let* ((panel-disp (make-instance 'widget-tester-panel-events)) - (lb1 nil) - (lb2 nil) + (lb1 nil) + (lb2 nil) + (btn-left nil) + (btn-right nil) + (btn-all nil) + (btn-none nil) + (lb1-callback (lambda (disp lb) + (declare (ignore disp)) + (manage-lb-button-states lb btn-right btn-all btn-none))) + (lb2-callback (lambda (disp lb) + (declare (ignore disp)) + (manage-lb-button-states lb btn-left nil nil))) + (btn-left-callback (lambda (disp btn) + (declare (ignore disp btn)) + (move-lb-content lb2 lb1) + (manage-lb-button-states lb1 btn-right btn-all btn-none) + (manage-lb-button-states lb2 btn-left btn-all btn-none))) + (btn-right-callback (lambda (disp btn) + (declare (ignore disp btn)) + (move-lb-content lb1 lb2) + (manage-lb-button-states lb1 btn-right btn-all btn-none) + (manage-lb-button-states lb2 btn-left btn-all btn-none))) + (btn-all-callback (lambda (disp btn) + (declare (ignore disp btn)))) + (btn-none-callback (lambda (disp btn) + (declare (ignore disp btn)))) + (outer-panel (make-instance 'gfw:panel :dispatcher panel-disp :parent *widget-tester-win* :layout (make-instance 'gfw:flow-layout :spacing 4 :margins 4))) @@ -82,26 +117,43 @@ :layout (make-instance 'gfw:flow-layout :style '(:vertical) :spacing 4 :margins 4))) (btn-panel (make-instance 'gfw:panel :dispatcher panel-disp :parent outer-panel - :layout (make-instance 'gfw:flow-layout :style '(:vertical) :spacing 4 :margins 4))) + :layout (make-instance 'gfw:flow-layout :style '(:vertical :normalize) :spacing 4 :margins 4))) (lb2-panel (make-instance 'gfw:panel :dispatcher panel-disp :parent outer-panel :layout (make-instance 'gfw:flow-layout :style '(:vertical) :spacing 4 :margins 4)))) + (make-instance 'gfw:label :text "Multiple Select:" :parent lb1-panel) (setf lb1 (make-instance 'gfw:list-box :parent lb1-panel - :callback #'lb-select + :callback lb1-callback :sort-predicate #'string< :style '(:multiple-select) :items (subseq *list-box-test-data* 4))) (gfw:pack lb1-panel) - (gfw:enable (make-instance 'gfw:button :parent btn-panel :text " ==> ") nil) - (gfw:enable (make-instance 'gfw:button :parent btn-panel :text " <== ") nil) + + (setf btn-right (make-instance 'gfw:button :parent btn-panel + :text " ==> " + :callback btn-right-callback)) + (gfw:enable btn-right nil) + (setf btn-left (make-instance 'gfw:button :parent btn-panel + :text " <== " + :callback btn-left-callback)) + (gfw:enable btn-left nil) + (setf btn-all (make-instance 'gfw:button :parent btn-panel + :text "Select All" + :callback btn-all-callback)) + (setf btn-none (make-instance 'gfw:button :parent btn-panel + :text "Select None" + :callback btn-none-callback)) + (gfw:enable btn-none nil) (gfw:pack btn-panel) + (make-instance 'gfw:label :text "Extended Select:" :parent lb2-panel) (setf lb2 (make-instance 'gfw:list-box :parent lb2-panel - :callback #'lb-select + :callback lb2-callback :style '(:extend-select :want-scrollbar) :items (subseq *list-box-test-data* 4))) (gfw:pack lb2-panel) + (gfw:pack outer-panel) (let ((size (gfw:size lb1))) (setf (gfw:maximum-size lb1) size @@ -109,7 +161,6 @@ (gfw:maximum-size lb2) size (gfw:minimum-size lb2) size)) (setf (gfw:items-of lb1) *list-box-test-data*) - (gfw:update-from-items lb1) (gfw:delete-all lb2) outer-panel)) Modified: trunk/src/uitoolkit/system/system-utils.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-utils.lisp (original) +++ trunk/src/uitoolkit/system/system-utils.lisp Thu Sep 7 01:46:41 2006 @@ -39,6 +39,7 @@ (defun recreate-array (array) (make-array (array-dimensions array) + :element-type (array-element-type array) :adjustable (adjustable-array-p array) :fill-pointer (if (array-has-fill-pointer-p array) 0 nil))) @@ -64,6 +65,15 @@ (dotimes (i (length tmp)) (setf (elt result i) (second (elt tmp i)))))) result)) +(defun pick-elements (lisp-seq indices &optional count) + (let ((picks nil)) + (if (cffi:pointerp indices) + (dotimes (i count) + (push (elt lisp-seq (mem-aref indices :unsigned-int i)) picks)) + (dotimes (i (length indices)) + (push (elt lisp-seq (elt indices i)) picks))) + (reverse picks))) + (defun flatten (tree) (if (cl:atom tree) (list tree) Modified: trunk/src/uitoolkit/widgets/item-manager.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/item-manager.lisp (original) +++ trunk/src/uitoolkit/widgets/item-manager.lisp Thu Sep 7 01:46:41 2006 @@ -37,6 +37,9 @@ ;;; helper functions ;;; +(defun make-items-array (&optional (count 7)) + (make-array count :fill-pointer 0 :adjustable t)) + (defun call-text-provider (manager thing) (let ((func (text-provider-of manager)) (*print-readably* nil)) @@ -51,7 +54,7 @@ (defun copy-item-sequence (parent new-items item-class) (let ((hwnd (gfs:handle parent)) (tc (thread-context)) - (replacements (make-array 7 :fill-pointer 0 :adjustable t))) + (replacements (make-items-array))) (cond ((null new-items) replacements) @@ -85,10 +88,10 @@ (error 'gfs:disposed-error))) (defmethod delete-all ((self item-manager)) - (let ((items (items-of self))) + (let ((items (slot-value self 'items))) (dotimes (i (length items)) (gfs:dispose (aref items i)))) - (setf (items-of self) (make-array 7 :fill-pointer 0 :adjustable t))) + (setf (slot-value self 'items) (make-items-array))) (defmethod delete-item :before ((self item-manager) index) (declare (ignore index)) @@ -96,9 +99,9 @@ (error 'gfs:disposed-error))) (defmethod delete-item ((self item-manager) index) - (let* ((items (items-of self)) + (let* ((items (slot-value self 'items)) (it (elt items index))) - (setf (items-of self) (remove it items :test #'items-equal-p)) + (setf (slot-value self 'items) (remove it items :test #'items-equal-p)) (if (gfs:disposed-p it) (error 'gfs:disposed-error)) (gfs:dispose it))) @@ -113,7 +116,7 @@ (delete-item self (gfs:span-start sp)))) (defmethod gfs:dispose ((self item-manager)) - (let ((items (items-of self)) + (let ((items (slot-value self 'items)) (tc (thread-context))) (dotimes (i (length items)) (delete-tc-item tc (elt items i))))) @@ -124,11 +127,23 @@ (error 'gfs:disposed-error))) (defmethod item-index ((self item-manager) (it item)) - (let ((pos (position it (items-of self) :test #'items-equal-p))) + (let ((pos (position it (slot-value self 'items) :test #'items-equal-p))) (if (null pos) (return-from item-index 0)) 0)) +(defmethod items-of ((self item-manager)) + (coerce (slot-value self 'items) 'list)) + +(defmethod selected-items :before ((self item-manager)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + +(defmethod (setf selected-items) :before (items (self item-manager)) + (declare (ignore items)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + (defmethod update-from-items :before ((self item-manager)) (if (gfs:disposed-p self) (error 'gfs:disposed-error))) Modified: trunk/src/uitoolkit/widgets/item.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/item.lisp (original) +++ trunk/src/uitoolkit/widgets/item.lisp Thu Sep 7 01:46:41 2006 @@ -38,15 +38,14 @@ ;;; (defun create-item-with-callback (howner class-symbol thing disp) - (let ((item nil) - (id (increment-item-id (thread-context)))) + (let ((item nil)) (cond ((null disp) - (setf item (make-instance class-symbol :item-id id :data thing :handle howner))) + (setf item (make-instance class-symbol :data thing :handle howner))) ((functionp disp) - (setf item (make-instance class-symbol :item-id id :data thing :handle howner :callback disp))) + (setf item (make-instance class-symbol :data thing :handle howner :callback disp))) ((typep disp 'gfw:event-dispatcher) - (setf item (make-instance class-symbol :item-id id :data thing :handle howner :dispatcher disp))) + (setf item (make-instance class-symbol :data thing :handle howner :dispatcher disp))) (t (error 'gfs:toolkit-error :detail "callback must be a function, instance of gfw:event-dispatcher, or null"))) @@ -70,12 +69,19 @@ (defmethod gfs:dispose ((self item)) (setf (dispatcher self) nil) + (let ((hwnd (gfs:handle self))) + (unless (or (null hwnd) (cffi:null-pointer-p hwnd)) + (let ((owner (get-widget (thread-context) hwnd))) + (if owner + (setf (slot-value owner 'items) + (remove self (slot-value owner 'items) :test #'items-equal-p)))))) (delete-tc-item (thread-context) self) (setf (data-of self) nil) (setf (item-id self) 0) (setf (slot-value self 'gfs:handle) nil)) (defmethod initialize-instance :after ((self item) &key callback &allow-other-keys) + (setf (item-id self) (increment-item-id (thread-context))) (when callback (unless (typep callback 'function) (error 'gfs:toolkit-error :detail ":callback value must be a function")) Modified: trunk/src/uitoolkit/widgets/list-box.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/list-box.lisp (original) +++ trunk/src/uitoolkit/widgets/list-box.lisp Thu Sep 7 01:46:41 2006 @@ -52,11 +52,9 @@ (lognot (logior gfs::+lbs-multiplesel+ gfs::+lbs-extendedsel+)))) (logior orig-flags gfs::+lbs-nosel+)) -(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-single-select-flags (orig-flags) + (logand orig-flags + (lognot (logior gfs::+lbs-nosel+ gfs::+lbs-extendedsel+ gfs::+lbs-multiplesel+)))) (defun lb-width (hwnd) (let ((width (gfs::send-message hwnd gfs::+lb-gethorizontalextent+ 0 0))) @@ -70,6 +68,14 @@ (error 'gfs:win32-error :detail "LB_GETCOUNT failed")) count)) +(defun lb-delete-all (lb) + (let ((old-items (slot-value lb 'items))) + (gfs::send-message (gfs:handle lb) gfs::+lb-resetcontent+ 0 0) + (dotimes (i (length old-items)) + (let ((victim (elt old-items i))) + (setf (slot-value victim 'gfs:handle) nil) + (gfs:dispose victim))))) + ;;; ;;; methods ;;; @@ -82,7 +88,7 @@ (item (create-item-with-callback hcontrol 'list-item thing disp))) (lb-insert-item hcontrol #xFFFFFFFF text (cffi:null-pointer)) (put-item tc item) - (vector-push-extend item (items-of self)) + (vector-push-extend item (slot-value self 'items)) item)) (defmethod compute-style-flags ((self list-box) &rest extra-data) @@ -97,6 +103,7 @@ (:extend-select (setf std-flags (lb-extend-select-flags std-flags))) (:multiple-select (setf std-flags (lb-multi-select-flags std-flags))) (:no-select (setf std-flags (lb-no-select-flags std-flags))) + (:single-select (setf std-flags (lb-single-select-flags std-flags))) ;; styles that can be combined ;; @@ -105,6 +112,10 @@ (:want-scrollbar (setf std-flags (logior std-flags gfs::+lbs-disablenoscroll+))))) (values std-flags 0))) +(defmethod delete-all ((self list-box)) + (lb-delete-all self) + (setf (slot-value self 'items) (make-items-array))) + (defmethod initialize-instance :after ((self list-box) &key estimated-count items parent &allow-other-keys) (initialize-comctl-classes gfs::+icc-standard-classes+) (multiple-value-bind (std-style ex-style) @@ -115,23 +126,19 @@ std-style ex-style (increment-widget-id (thread-context))))) - (setf (slot-value self 'gfs:handle) hwnd))) - (init-control self) - (if (and estimated-count (> estimated-count 0)) - (lb-init-storage (gfs:handle self) estimated-count (* estimated-count +estimated-text-size+))) + (setf (slot-value self 'gfs:handle) hwnd) + (init-control self) + (if (and estimated-count (> estimated-count 0)) + (gfs::send-message hwnd + gfs::+lb-initstorage+ + estimated-count + (* estimated-count +estimated-text-size+))))) (if items (setf (slot-value self 'items) (copy-item-sequence self items 'list-item))) (update-from-items self)) -(defmethod (setf items-of) :before (new-items (self list-box)) - (declare (ignore new-items)) - (let ((old-items (items-of self))) - (dotimes (i (length old-items)) - (let ((victim (elt old-items i))) - (setf (slot-value victim 'gfs:handle) nil) - (gfs:dispose victim))))) - -(defmethod (setf items-of) :after (new-items (self list-box)) +(defmethod (setf items-of) (new-items (self list-box)) + (lb-delete-all self) (setf (slot-value self 'items) (copy-item-sequence self new-items 'list-item)) (update-from-items self)) @@ -180,15 +187,38 @@ (incf (gfs:size-width size) (vertical-scrollbar-width))) size)) +(defmethod selected-count ((self list-box)) + (let ((hwnd (gfs:handle self))) + (if (test-native-style self gfs::+lbs-nosel+) + (if (>= (gfs::send-message hwnd gfs::+lb-getcursel+ 0 0) 0) 1 0) + (let ((count (gfs::send-message hwnd gfs::+lb-getselcount+ 0 0))) + (if (< count 0) 0 count))))) + +(defmethod selected-items ((self list-box)) + (let ((hwnd (gfs:handle self)) + (items (slot-value self 'items))) + (if (and (not (test-native-style self gfs::+lbs-extendedsel+)) + (not (test-native-style self gfs::+lbs-multiplesel+))) + (let ((index (gfs::send-message hwnd gfs::+lb-getcursel+ 0 0))) + (if (and (>= index 0) (< index (length items))) + (list (elt items index)) + nil)) + (let ((count (gfs::send-message hwnd gfs::+lb-getselcount+ 0 0))) + (if (<= count 0) + nil + (cffi:with-foreign-object (indices :unsigned-int count) + (if (/= (gfs::send-message hwnd gfs::+lb-getselitems+ count (cffi:pointer-address indices)) count) + nil + (gfs::pick-elements items indices count)))))))) + (defmethod update-from-items ((self list-box)) (let ((sort-func (sort-predicate-of self)) (hwnd (gfs:handle self))) (when sort-func - (setf (slot-value self 'items) (gfs::indexed-sort (items-of self) sort-func #'data-of))) + (setf (slot-value self 'items) (gfs::indexed-sort (slot-value self 'items) sort-func #'data-of))) (enable-redraw self nil) (unwind-protect - (let ((items (items-of self))) - (lb-clear-content hwnd) + (let ((items (slot-value self 'items))) (dotimes (index (length items)) (let* ((item (elt items index)) (text (call-text-provider self (data-of item)))) Modified: trunk/src/uitoolkit/widgets/list-item.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/list-item.lisp (original) +++ trunk/src/uitoolkit/widgets/list-item.lisp Thu Sep 7 01:46:41 2006 @@ -70,6 +70,7 @@ ;;; (defmethod gfs:dispose ((self list-item)) +(print self) (let ((index (index-of self)) (howner (gfs:handle self))) (if howner Modified: trunk/src/uitoolkit/widgets/menu.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu.lisp (original) +++ trunk/src/uitoolkit/widgets/menu.lisp Thu Sep 7 01:46:41 2006 @@ -79,8 +79,8 @@ nil))) (defun visit-menu-tree (menu fn) - (dotimes (index (length (items-of menu))) - (let ((it (elt (items-of menu) index)) + (dotimes (index (length (slot-value menu 'items))) + (let ((it (elt (slot-value menu 'items) index)) (child (sub-menu menu index))) (unless (null child) (visit-menu-tree child fn)) @@ -97,32 +97,30 @@ (text (call-text-provider self thing))) (append-menuitem hmenu (item-id item) text (cffi:null-pointer) (cffi:null-pointer) disabled checked) (put-item tc item) - (vector-push-extend item (items-of self)) + (vector-push-extend item (slot-value self 'items)) item)) (defmethod append-separator ((self menu)) (if (gfs:disposed-p self) (error 'gfs:disposed-error)) (let* ((tc (thread-context)) - (id (increment-item-id tc)) (hmenu (gfs:handle self)) - (item (make-instance 'menu-item :handle hmenu :item-id id))) - (append-menuitem hmenu id nil (cffi:null-pointer) (cffi:null-pointer) nil nil) + (item (make-instance 'menu-item :handle hmenu))) + (append-menuitem hmenu (item-id item) nil (cffi:null-pointer) (cffi:null-pointer) nil nil) (put-item tc item) - (vector-push-extend item (items-of self)) + (vector-push-extend item (slot-value self 'items)) item)) (defmethod append-submenu ((self menu) text (submenu menu) disp &optional disabled checked) (if (or (gfs:disposed-p self) (gfs:disposed-p submenu)) (error 'gfs:disposed-error)) (let* ((tc (thread-context)) - (id (increment-item-id tc)) (hparent (gfs:handle self)) (hmenu (gfs:handle submenu)) - (item (make-instance 'menu-item :handle hparent :item-id id))) - (append-menuitem hparent id text (cffi:null-pointer) hmenu disabled checked) + (item (make-instance 'menu-item :handle hparent))) + (append-menuitem hparent (item-id item) text (cffi:null-pointer) hmenu disabled checked) (put-item tc item) - (vector-push-extend item (items-of self)) + (vector-push-extend item (slot-value self 'items)) (put-widget tc submenu) (cond ((null disp)) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Thu Sep 7 01:46:41 2006 @@ -170,7 +170,6 @@ :initarg :sort-predicate :initform nil) (items - :accessor items-of ;; FIXME: allow subclasses to set initial size? :initform (make-array 7 :fill-pointer 0 :adjustable t)) (text-provider Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Thu Sep 7 01:46:41 2006 @@ -347,15 +347,6 @@ (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod selected-items :before ((self widget)) - (if (gfs:disposed-p self) - (error 'gfs:disposed-error))) - -(defmethod (setf selected-items) :before (items (self widget)) - (declare (ignore items)) - (if (gfs:disposed-p self) - (error 'gfs:disposed-error))) - (defmethod selected-p :before ((self widget)) (if (gfs:disposed-p self) (error 'gfs:disposed-error)))

1 0

[graphic-forms-cvs] r249 - in trunk: docs/manual src src/demos/textedit src/uitoolkit/widgets
by junrue＠common-lisp.net 06 Sep '06

06 Sep '06

Author: junrue Date: Wed Sep 6 01:08:05 2006 New Revision: 249 Modified: trunk/docs/manual/widget-functions.texinfo trunk/src/demos/textedit/textedit-window.lisp trunk/src/packages.lisp trunk/src/uitoolkit/widgets/edit.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp trunk/src/uitoolkit/widgets/widget.lisp Log: API cleanup: collapsed selection-span and select-span into selected-span and associated setf function Modified: trunk/docs/manual/widget-functions.texinfo ============================================================================== --- trunk/docs/manual/widget-functions.texinfo (original) +++ trunk/docs/manual/widget-functions.texinfo Wed Sep 6 01:08:05 2006 @@ -449,37 +449,56 @@ or to the unselected state if @sc{nil}. @end deffn +@anchor{select-all} @deffn GenericFunction select-all self flag -Sets the entire content of @code{self} to the selected state if +Sets the entire content of @var{self} to the selected state if @var{flag} is not @sc{nil} or to the unselected state if @sc{nil}. @end deffn -@anchor{select-items} -@deffn GenericFunction select-items self indices flag -Sets the @ref{item}s of @var{self}, each identified by a zero-based -index from the @var{indices} @sc{list}, to the selected state if -@var{flag} is not @sc{nil} or to the unselected state if @sc{nil}. -This is the function to use when not all of the items in question -are contiguous. +@anchor{selected-count} +@deffn GenericFunction selected-count self => integer +Returns the number of @ref{item}s selected in @var{self}. @end deffn -@anchor{select-span} -@deffn GenericFunction select-span self span -Sets the @ref{item}s of @var{self} that lie within @var{span} to -the selected state. An existing selection's extent is modified -to match the new @var{span}. -@end deffn +@anchor{selected-items} +@deffn GenericFunction selected-items self => list +(setf (@strong{selected-items} @var{self}) @var{list}) + +Returns a @sc{list} containing subclasses of @ref{item} appropriate +for @var{self} that correspond to selections made by the user, or +@sc{nil} if there are no selections. This function is defined only +for @ref{widget}s whose notion of @emph{selection} is a set of +item objects. -@deffn GenericFunction selection-span self => @ref{span} -Returns a span object describing the @var{start} and @var{end} of the -selection within @var{self}. If there is no selection, this function -returns @sc{nil}. +The @sc{setf} function takes a @var{list} of item subclasses +appropriate for @var{self} which identify the items in +@var{self} that should be selected. Passing @sc{nil} will unselect all +items, which is equivalent to calling @ref{select-all} with @sc{nil}. @end deffn +@anchor{selected-p} @deffn GenericFunction selected-p self => boolean Returns T if @var{self} is in the selected state; @sc{nil} otherwise. @end deffn +@anchor{selected-span} +@deffn GenericFunction selected-span self => @var{object}, @var{span} +(setf (@strong{selected-span} @var{self}) @var{span}) + +Returns a @ref{span} describing a range of data within @var{self} +that is in the selected state, as well as an @var{object} comprising +the selected data. If there is no selection, this +function returns @sc{nil} for both values. This function is defined +only for @ref{widget}s whose notion of @emph{selection} is a +contiguous range of simple data (e.g., characters in a string). + +The corresponding @sc{setf} function sets the content of +@var{self} whose indices lie within @var{span} to the selected +state. An existing selection's extent is modified to match the +new @var{span}. Passing @sc{nil} for @var{span} will unselect +all content. +@end deffn + @anchor{show} @deffn GenericFunction show self flag Causes the object to be visible or hidden on the screen, but not Modified: trunk/src/demos/textedit/textedit-window.lisp ============================================================================== --- trunk/src/demos/textedit/textedit-window.lisp (original) +++ trunk/src/demos/textedit/textedit-window.lisp Wed Sep 6 01:08:05 2006 @@ -98,17 +98,19 @@ (unless *textedit-control* (return-from manage-textedit-edit-menu nil)) (let ((items (gfw:items-of menu)) - (text (gfw:text *textedit-control*)) - (text-sel (gfw:selection-span *textedit-control*))) - (gfw:enable (elt items 0) (gfw:undo-available-p *textedit-control*)) - (gfw:enable (elt items 2) text-sel) - (gfw:enable (elt items 3) text-sel) - (gfw:enable (elt items 4) (gfw:text-for-pasting-p *textedit-control*)) - (gfw:enable (elt items 5) text-sel) - (gfw:enable (elt items 12) (and (> (length text) 0) - (or (null text-sel) - (> (gfs:span-start text-sel) 0) - (< (gfs:span-end text-sel) (length text))))))) + (text (gfw:text *textedit-control*))) + (multiple-value-bind (sub-text text-sel) + (gfw:selected-span *textedit-control*) + (declare (ignore sub-text)) + (gfw:enable (elt items 0) (gfw:undo-available-p *textedit-control*)) + (gfw:enable (elt items 2) text-sel) + (gfw:enable (elt items 3) text-sel) + (gfw:enable (elt items 4) (gfw:text-for-pasting-p *textedit-control*)) + (gfw:enable (elt items 5) text-sel) + (gfw:enable (elt items 12) (and (> (length text) 0) + (or (null text-sel) + (> (gfs:span-start text-sel) 0) + (< (gfs:span-end text-sel) (length text)))))))) (defun textedit-edit-copy (disp item) (declare (ignore disp item)) Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Wed Sep 6 01:08:05 2006 @@ -487,12 +487,10 @@ #:scroll #:select #:select-all - #:select-items + #:selected-count + #:selected-items #:selected-p - #:selection-count - #:selection-index - #:selection-indices - #:selection-span + #:selected-span #:show #:show-column #:show-header Modified: trunk/src/uitoolkit/widgets/edit.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/edit.lisp (original) +++ trunk/src/uitoolkit/widgets/edit.lisp Wed Sep 6 01:08:05 2006 @@ -133,13 +133,7 @@ (gfs::send-message (gfs:handle self) gfs::+em-setsel+ 0 (length (text self))) (gfs::send-message (gfs:handle self) gfs::+em-setsel+ 0 0))) -(defmethod select-span ((self edit) (span gfs:span)) - (with-drawing-disabled (self) - (let ((hwnd (gfs:handle self))) - (gfs::send-message hwnd gfs::+em-setsel+ 1 1) - (gfs::send-message hwnd gfs::+em-setsel+ (gfs:span-start span) (gfs:span-end span))))) - -(defmethod selection-span ((self edit)) +(defmethod selected-span ((self edit)) (cffi:with-foreign-object (start-ptr :unsigned-long) (cffi:with-foreign-object (end-ptr :unsigned-long) (gfs::send-message (gfs:handle self) @@ -147,8 +141,17 @@ (cffi:pointer-address start-ptr) (cffi:pointer-address end-ptr)) (let ((start (cffi:mem-ref start-ptr :unsigned-long)) - (end (cffi:mem-ref end-ptr :unsigned-long))) - (if (= start end) nil (gfs:make-span :start start :end end)))))) + (end (cffi:mem-ref end-ptr :unsigned-long)) + (str (text self))) + (if (= start end) + (values nil nil) + (values (subseq str start end) (gfs:make-span :start start :end end))))))) + +(defmethod (setf selected-span) ((span gfs:span) (self edit)) + (with-drawing-disabled (self) + (let ((hwnd (gfs:handle self))) + (gfs::send-message hwnd gfs::+em-setsel+ 1 1) + (gfs::send-message hwnd gfs::+em-setsel+ (gfs:span-start span) (gfs:span-end span))))) (defmethod text ((self edit)) (get-widget-text self)) Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Wed Sep 6 01:08:05 2006 @@ -327,26 +327,23 @@ (defgeneric select-all (self flag) (:documentation "Set all items of this object into (or out of) the selected state.")) -(defgeneric select-items (self indices flag) - (:documentation "Set items of self, each identified by a zero-based index, into (or out of) the selected state.")) +(defgeneric selected-count (self) + (:documentation "Returns the number of this object's items that are selected.")) + +(defgeneric selected-items (self) + (:documentation "Returns a list of item subclasses representing selected items in self, or nil if no items are selected.")) -(defgeneric select-span (self span) - (:documentation "Set items of self that lie within span into the selected state.")) +(defgeneric (setf selected-items) (items self) + (:documentation "Updates self's visual display such that the specified items are selected.")) (defgeneric selected-p (self) (:documentation "Returns T if the object is in the selected state; nil otherwise.")) -(defgeneric selection-count (self) - (:documentation "Returns the number of this object's items that are selected.")) - -(defgeneric selection-index (self) - (:documentation "Returns the zero-based index of the currently-selected item, or nil if no item is selected.")) - -(defgeneric selection-indices (self) - (:documentation "Returns a list of zero-based indices identifying the selected items within this object.")) +(defgeneric selected-span (self) + (:documentation "Returns a span describing the range of data selected in self, and the selected data.")) -(defgeneric selection-span (self) - (:documentation "Returns a span object describing the start and end indices of the selection within self.")) +(defgeneric (setf selected-span) (span self) + (:documentation "Updates self's visual display such that the data within span is selected.")) (defgeneric show (self flag) (:documentation "Causes the object to be visible or hidden on the screen, but not necessarily top-most in the display z-order.")) Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Wed Sep 6 01:08:05 2006 @@ -343,13 +343,16 @@ (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod select-items :before ((self widget) items flag) - (declare (ignore items flag)) +(defmethod selected-count :before ((self widget)) (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod select-span :before ((self widget) span) - (declare (ignore span)) +(defmethod selected-items :before ((self widget)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + +(defmethod (setf selected-items) :before (items (self widget)) + (declare (ignore items)) (if (gfs:disposed-p self) (error 'gfs:disposed-error))) @@ -360,7 +363,15 @@ (defmethod selected-p ((self widget)) nil) -(defmethod selection-span :before ((self widget)) +(defmethod selected-span :before ((self widget)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + +(defmethod selected-span ((self widget)) + nil) + +(defmethod (setf selected-span) :before (span (self widget)) + (declare (ignore span)) (if (gfs:disposed-p self) (error 'gfs:disposed-error)))

1 0

← Newer
1
...
19
20
21
22
23
24
25
...
47
Older →

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

graphic-forms-cvs