August 2006 - graphic-forms-cvs@common-lisp.net

[graphic-forms-cvs] r223 - in trunk: . docs/manual src/uitoolkit/system src/uitoolkit/widgets
by junrue＠common-lisp.net 20 Aug '06

20 Aug '06

Author: junrue Date: Sat Aug 19 20:37:13 2006 New Revision: 223 Modified: trunk/NEWS.txt trunk/docs/manual/widgets-api.texinfo trunk/src/uitoolkit/system/user32.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/thread-context.lisp Log: changed obtain-event-time to call native GetMessageTime, and removed obsolete slot from thread-context Modified: trunk/NEWS.txt ============================================================================== --- trunk/NEWS.txt (original) +++ trunk/NEWS.txt Sat Aug 19 20:37:13 2006 @@ -4,6 +4,8 @@ to enable the stdcall calling convention for alien callbacks, located in src/external-libraries/sbcl-callback-patch +. Implemented the standard color chooser dialog. + ============================================================================== Modified: trunk/docs/manual/widgets-api.texinfo ============================================================================== --- trunk/docs/manual/widgets-api.texinfo (original) +++ trunk/docs/manual/widgets-api.texinfo Sat Aug 19 20:37:13 2006 @@ -1162,8 +1162,7 @@ @anchor{obtain-event-time} @defun obtain-event-time => milliseconds -Returns the timestamp for the event currently being processed, or -zero if called prior to delivery of any events. +Returns the timestamp for the event currently being processed. @end defun Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Sat Aug 19 20:37:13 2006 @@ -414,6 +414,10 @@ (filter-max UINT)) (defcfun + ("GetMessageTime" get-message-time) + LONG) + +(defcfun ("GetMonitorInfoA" get-monitor-info) BOOL (hmonitor HANDLE) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Sat Aug 19 20:37:13 2006 @@ -78,7 +78,6 @@ gfs::time gfs::pnt) msg-ptr gfs::msg) - (setf (event-time (thread-context)) gfs::time) (when (funcall msg-filter gm msg-ptr) (return-from message-loop gfs::wparam))))))) @@ -140,10 +139,8 @@ (setf ret-val (cffi:pointer-address (brush-handle-of widget)))) ret-val)) -;;; FIXME: replace event-time slot with call to GetMessageTime -;;; (defun obtain-event-time () - (event-time (thread-context))) + (gfs::get-message-time)) (defun option->reason (lparam) ;; MSDN says the value is a bitmask, so must be tested bit-wise. Modified: trunk/src/uitoolkit/widgets/thread-context.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/thread-context.lisp (original) +++ trunk/src/uitoolkit/widgets/thread-context.lisp Sat Aug 19 20:37:13 2006 @@ -40,7 +40,6 @@ (display-visitor-results :initform nil :accessor display-visitor-results) (job-table :initform (make-hash-table :test #'equal)) (job-table-lock :initform nil) - (event-time :initform 0 :accessor event-time) ; FIXME: GetMessageTime (virtual-key :initform 0 :accessor virtual-key) (menuitems-by-id :initform (make-hash-table :test #'equal)) (mouse-event-pnt :initform (gfs:make-point) :accessor mouse-event-pnt)

1 0

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

19 Aug '06

Author: junrue Date: Sat Aug 19 18:56:20 2006 New Revision: 222 Added: trunk/src/uitoolkit/widgets/color-dialog.lisp Modified: trunk/NEWS.txt trunk/docs/manual/widgets-api.texinfo trunk/graphic-forms-uitoolkit.asd trunk/src/packages.lisp trunk/src/tests/uitoolkit/windlg.lisp trunk/src/uitoolkit/system/comdlg32.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/system/system-types.lisp trunk/src/uitoolkit/widgets/file-dialog.lisp trunk/src/uitoolkit/widgets/font-dialog.lisp trunk/src/uitoolkit/widgets/layout.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp Log: implemented and documented system color dialog Modified: trunk/NEWS.txt ============================================================================== --- trunk/NEWS.txt (original) +++ trunk/NEWS.txt Sat Aug 19 18:56:20 2006 @@ -1,8 +1,8 @@ -. SBCL 0.9.15 is now a supported Common Lisp implementation. Graphic-Forms - includes a small patch to enable the stdcall calling convention for alien - callbacks, located in src/external-libraries/sbcl-callback-patch +. SBCL 0.9.15 is now supported. Graphic-Forms includes a small patch +to enable the stdcall calling convention for alien callbacks, located +in src/external-libraries/sbcl-callback-patch ============================================================================== Modified: trunk/docs/manual/widgets-api.texinfo ============================================================================== --- trunk/docs/manual/widgets-api.texinfo (original) +++ trunk/docs/manual/widgets-api.texinfo Sat Aug 19 18:56:20 2006 @@ -28,7 +28,7 @@ @node widget types @subsection widget types -@strong{NOTE:} A future release will provide additional widget +@strong{Note:} A future release will provide additional widget classes. @anchor{button} @@ -90,6 +90,46 @@ @end deffn @end deftp +@anchor{color-dialog} +@deftp Class color-dialog +This class provides a standard dialog for choosing (or defining new) +@ref{color}s. The @ref{with-color-dialog} macro wraps the creation of +this dialog type and subsequent retrieval of the user's color choice. +However, applications may choose to implement these steps manually, in +which case the @ref{obtain-chosen-color} function can be used.@*@* +Like other system dialogs in Graphic-Forms, @code{color-dialog} is +derived from @ref{widget} rather than @ref{dialog} since the majority +of its functionality is implemented by the system. @strong{Note:} A +future release will provide a customization mechanism. +@deffn Initarg :initial-color +This initarg causes the dialog to show the specified color as +initially selected. +@end deffn +@deffn Initarg :initial-custom-colors +This initarg accepts a list of color objects which are used to +populate the custom color editing portion of the dialog. A +maximum of 16 colors are used, with any extras supplied in the +list being ignored. Fewer than 16 may be supplied, in which case +black is displayed as a default color for the remaining entries. +@end deffn +@deffn Initarg :owner +A value is required for this initarg, and it may be either a +@ref{window} or a dialog. +@end deffn +@deffn Initarg :style +This initarg accepts a list of keyword symbols: +@table @code +@item :allow-custom-colors +This configures the dialog to enable the Define Custom Color +button, which when clicked reveals additional controls for +creating custom colors. +@item :display-solid-only +This configures the dialog to only display solid colors in the +set of basic colors. +@end table +@end deffn +@end deftp + @anchor{control} @deftp Class control brush-color brush-handle font pixel-point maximum-size minimum-size text-color The base class for widgets having pre-defined native behavior. It derives from @@ -314,7 +354,7 @@ must be followed by an explicit call to @ref{dispose}.@*@* Like other system dialogs in Graphic-Forms, @code{file-dialog} is derived from @ref{widget} rather than @ref{dialog} since the majority -of its functionality is implemented by the system. @strong{NOTE:} A +of its functionality is implemented by the system. @strong{Note:} A future release will provide a customization mechanism.@*@* @deffn Initarg :default-extension Specifies a default extension to be appended to a file name if @@ -354,7 +394,7 @@ @ref{window} or a @ref{dialog}. @end deffn @deffn Initarg :style -This initarg accepts a list of keyword symbols, as follows: +This initarg accepts a list of keyword symbols: @table @code @item :add-to-recent This enables the system to add a link to the selected file @@ -374,7 +414,7 @@ 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 +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. @@ -402,7 +442,7 @@ by an explicit call to @ref{dispose}.@*@* Like other system dialogs in Graphic-Forms, @code{font-dialog} is derived from @ref{widget} rather than @ref{dialog} since the majority of its -functionality is implemented by the system. @strong{NOTE:} A future release +functionality is implemented by the system. @strong{Note:} A future release will provide a customization mechanism.@* @deffn Initarg :gc This required initarg accepts a @ref{graphics-context} object providing @@ -424,7 +464,7 @@ @ref{window} or a @ref{dialog}. @end deffn @deffn Initarg :style -This initarg accepts a list of keyword symbols, as follows: +This initarg accepts a list of keyword symbols: @table @code @item :all-fonts This is a convenience style, used by default if no other font @@ -453,7 +493,7 @@ @anchor{group} @deftp Class group children location size style -@strong{NOTE:} this class is not yet fully implemented +@strong{Note:} this class is not yet fully implemented and does not yet participate in the layout protocol.@*@* A @code{group} represents a logical rectangular aggregation of @ref{window} children which has the following properties @@ -748,7 +788,7 @@ This slot holds a margin value in pixels for the bottom side of the container. @item data -This slot holds a @sc{alist} of pairs, each one associating a +This slot holds an @sc{alist} of pairs, each one associating a @sc{plist} of layout-specific attributes with an item from a container. @item left-margin @@ -1171,7 +1211,7 @@ @end deffn @anchor{capture-mouse} -@deffn Function capture-mouse self +@defun capture-mouse self Enables the @ref{window} identified by @code{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 @@ -1179,7 +1219,7 @@ background windows may still capture the mouse, but only mouse move events will be received and those only when the mouse hotspot is within the visible portions of such a window. @xref{release-mouse}. -@end deffn +@end defun @anchor{center-on-owner} @deffn GenericFunction center-on-owner self @@ -1319,13 +1359,13 @@ @end deffn @anchor{file-dialog-paths} -@deffn Function file-dialog-paths dlg => @sc{list} +@defun file-dialog-paths dlg => @sc{list} Interrogates the data structure associated with an instance of @ref{file-dialog} to obtain the paths for selected files. This return value is either @sc{nil} if the user cancelled the dialog, or a list of file @sc{namestring}s. Use this function when manually constructing a file dialog. @xref{with-file-dialog}. -@end deffn +@end defun @deffn GenericFunction focus-p self Returns @sc{t} if @code{self} currently has keyboard focus; @sc{nil} @@ -1333,7 +1373,7 @@ @end deffn @anchor{font-dialog-results} -@deffn Function font-dialog-results dlg gc => @ref{font}, @ref{color} +@defun font-dialog-results dlg gc => @ref{font}, @ref{color} 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 @@ -1343,7 +1383,7 @@ Also, the color value will be @sc{nil} if the dialog was created with the @code{:no-effects} style keyword. Use this function when manually constructing a font dialog. @xref{with-font-dialog}. -@end deffn +@end defun @deffn GenericFunction give-focus self Places keyboard focus on @code{self}. @@ -1420,23 +1460,28 @@ the new minimum. @xref{maximum-size}. @end deffn -@deffn GenericFunction object-to-display self pnt -Return a point that is the result of transforming the specified point -from this object's coordinate system to display-relative coordinates. -@end deffn +@anchor{obtain-chosen-color} +@defun obtain-chosen-color @ref{color-dialog} => @ref{color}, list +Interrogates the data structure associated with @var{color-dialog} +to retrieve @var{color}. The secondary value is a list of color +objects corresponding to custom colors displayed by the dialog. +If the user cancelled the dialog, @sc{nil} is returned for both +values. Use this function when manually constructing a color dialog. +@xref{with-color-dialog}. +@end defun @anchor{obtain-displays} -@deffn Function obtain-displays +@defun obtain-displays => list Returns a list of @ref{display} objects, each of which describes a monitor attached to the system. The system specifies that one of these is the primary @ref{display}. -@end deffn +@end defun @anchor{obtain-primary-display} -@deffn Function obtain-primary-display -Return a @ref{display} object that is regarded by the system as +@defun obtain-primary-display => @ref{display} +Return a display object that is regarded by the system as being the primary. -@end deffn +@end defun @anchor{owner} @deffn GenericFunction owner self @@ -1461,11 +1506,12 @@ @anchor{pack} @deffn GenericFunction pack self -Causes @code{self} to be resized to its preferred @ref{size}. +Causes @var{self} to be resized to the dimensions returned +by @ref{preferred-size}. @end deffn @anchor{parent} -@deffn GenericFunction parent self +@deffn GenericFunction parent self => @ref{window} Returns the @code{parent} of @code{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}, @@ -1508,10 +1554,10 @@ must determine how tall it would be given that width. @end deffn -@deffn Function primary-p display +@defun primary-p display Returns T if the system regards the specified display as the primary display; nil otherwise. -@end deffn +@end defun @deffn GenericFunction redo-available-p self => boolean Returns T if @code{self} has @sc{redo} capability and has an @@ -1523,10 +1569,10 @@ @end deffn @anchor{release-mouse} -@deffn Function release-mouse +@defun release-mouse Clears the mouse capture state to restore normal mouse input processing. @xref{capture-mouse}. -@end deffn +@end defun @anchor{resizable-p} @deffn GenericFunction resizable-p self => boolean @@ -1651,6 +1697,16 @@ @end deffn @end html +@anchor{with-color-dialog} +@defmac with-color-dialog (owner style color custom-colors &key initial-color initial-custom-colors) &body body +This macro wraps the instantiation of a standard color dialog and +the subsequent retrieval of the user's color selection (supplied to @var{body} +via @var{color}). The @var{custom-colors} argument is bound to a list containing +colors that the user has modified in the extended portion of the dialog. +@xref{color-dialog}. +@end defmac + +@anchor{with-drawing-disabled} @defmac with-drawing-disabled (widget) &body body This macro executes @var{body} while updates of @var{widget} are disabled. Drawing operations attempted while @var{body} Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Sat Aug 19 18:56:20 2006 @@ -122,6 +122,9 @@ (:file "timer") (:file "item") (:file "widget") + (:file "color-dialog") + (:file "file-dialog") + (:file "font-dialog") (:file "control") (:file "edit") (:file "label") @@ -136,8 +139,6 @@ (:file "top-level") (:file "panel") (:file "dialog") - (:file "file-dialog") - (:file "font-dialog") (:file "layout") (:file "heap-layout") (:file "flow-layout"))))))))) Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Sat Aug 19 18:56:20 2006 @@ -244,6 +244,7 @@ ;; classes and structs #:button #:caret + #:color-dialog #:control #:dialog #:display @@ -462,7 +463,7 @@ #:move-above #:move-below #:moveable-p - #:object-to-display + #:obtain-chosen-color #:obtain-displays #:obtain-event-time #:obtain-primary-display @@ -523,6 +524,7 @@ #:vertical-scrollbar #:visible-item-count #:visible-p + #:with-color-dialog #:with-drawing-disabled #:with-file-dialog #:with-font-dialog Modified: trunk/src/tests/uitoolkit/windlg.lisp ============================================================================== --- trunk/src/tests/uitoolkit/windlg.lisp (original) +++ trunk/src/tests/uitoolkit/windlg.lisp Sat Aug 19 18:56:20 2006 @@ -117,6 +117,14 @@ :initial-directory #P"c:/") (print paths))) +(defun choose-color-dlg (disp item) + (declare (ignore disp item)) + (gfw:with-color-dialog (*main-win* '(:allow-custom-colors) color custom-colors :initial-custom-colors (list gfg:*color-red* gfg:*color-blue*)) + (if color + (print color)) + (if custom-colors + (print custom-colors)))) + (defun choose-font-dlg (disp item) (declare (ignore disp item)) (gfw:with-graphics-context (gc *main-win*) @@ -235,16 +243,17 @@ (setf menubar (gfw:defmenu ((:item "&File" :submenu ((:item "E&xit" :callback #'windlg-exit-fn))) (:item "&Custom Dialogs" - :submenu ((:item "&Modal" :callback #'open-modal-dlg) - (:item "&Modeless" :callback #'open-modeless-dlg))) + :submenu ((:item "&Modal" :callback #'open-modal-dlg) + (:item "&Modeless" :callback #'open-modeless-dlg))) (:item "&System Dialogs" - :submenu ((:item "&Choose Font" :callback #'choose-font-dlg) - (:item "&Open File" :callback #'open-file-dlg) - (:item "&Save File" :callback #'save-file-dlg))) + :submenu ((:item "Choose &Color" :callback #'choose-color-dlg) + (:item "Choose &Font" :callback #'choose-font-dlg) + (:item "&Open File" :callback #'open-file-dlg) + (:item "&Save File" :callback #'save-file-dlg))) (:item "&Windows" - :submenu ((:item "&Borderless" :callback #'create-borderless-win) - (:item "&Mini Frame" :callback #'create-miniframe-win) - (:item "&Palette" :callback #'create-palette-win)))))) + :submenu ((:item "&Borderless" :callback #'create-borderless-win) + (:item "&Mini Frame" :callback #'create-miniframe-win) + (:item "&Palette" :callback #'create-palette-win)))))) (setf (gfw:menu-bar *main-win*) menubar) (setf (gfw:image *main-win*) (make-instance 'gfg:icon-bundle :file (merge-pathnames "default.ico"))) (gfw:show *main-win* t))) Modified: trunk/src/uitoolkit/system/comdlg32.lisp ============================================================================== --- trunk/src/uitoolkit/system/comdlg32.lisp (original) +++ trunk/src/uitoolkit/system/comdlg32.lisp Sat Aug 19 18:56:20 2006 @@ -39,6 +39,11 @@ (load-foreign-library "comdlg32.dll") (defcfun + ("ChooseColorA" choose-color) + BOOL + (struct LPTR)) ; choosecolor struct + +(defcfun ("ChooseFontA" choose-font) BOOL (struct LPTR)) ; choosefont struct Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Sat Aug 19 18:56:20 2006 @@ -137,10 +137,20 @@ (defconstant +cbm-init+ #x04) -(defconstant +cchdevicename+ 32) +(defconstant +cc-rgbinit+ #x00000001) +(defconstant +cc-fullopen+ #x00000002) +(defconstant +cc-preventfullopen+ #x00000004) +(defconstant +cc-showhelp+ #x00000008) +(defconstant +cc-enablehook+ #x00000010) +(defconstant +cc-enabletemplate+ #x00000020) +(defconstant +cc-enabletemplatehandle+ #x00000040) +(defconstant +cc-solidcolor+ #x00000080) +(defconstant +cc-anycolor+ #x00000100) (defconstant +ccerr-choosecolorcodes+ #x5000) +(defconstant +cchdevicename+ 32) + (defconstant +cderr-dialogfailure+ #xFFFF) (defconstant +cderr-generalcodes+ #x0000) (defconstant +cderr-structsize+ #x0001) Modified: trunk/src/uitoolkit/system/system-types.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-types.lisp (original) +++ trunk/src/uitoolkit/system/system-types.lisp Sat Aug 19 18:56:20 2006 @@ -150,6 +150,17 @@ (biclrused DWORD) (biclrimp DWORD)) +(defcstruct choosecolor + (ccsize DWORD) + (howner HANDLE) + (hinst HANDLE) + (result COLORREF) + (ccolors LPTR) + (flags DWORD) + (cdata LPARAM) + (hookfn LPTR) ; CCHookProc + (templname :string)) + (defcstruct choosefont (structsize DWORD) (howner HANDLE) @@ -159,7 +170,7 @@ (flags DWORD) (color COLORREF) (data LPARAM) - (hookfn LPTR) ; FIXME: not yet used, but eventually should be CFHookProc + (hookfn LPTR) ; CFHookProc (templname :string) (hinstance HANDLE) (style :string) @@ -184,7 +195,7 @@ (whatlen WORD) (withlen WORD) (data LPARAM) - (hookfn LPTR) ; FIXME: not yet used, but eventually should be FRHookProc + (hookfn LPTR) ; FRHookProc (templname :string)) (defcstruct iconinfo Added: trunk/src/uitoolkit/widgets/color-dialog.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/widgets/color-dialog.lisp Sat Aug 19 18:56:20 2006 @@ -0,0 +1,130 @@ +;;;; +;;;; color-dialog.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.widgets) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defconstant +custom-color-array-size+ 16)) + +;;; +;;; helper functions +;;; + +(defun obtain-chosen-color (dlg) + (let ((cc-ptr (gfs:handle dlg))) + (if (cffi:null-pointer-p cc-ptr) + (error 'gfs:disposed-error)) + (cffi:with-foreign-slots ((gfs::result gfs::ccolors) cc-ptr gfs::choosecolor) + (values (gfg:rgb->color gfs::result) + (loop for index to (1- +custom-color-array-size+) + collect (gfg:rgb->color (cffi:mem-aref gfs::ccolors 'gfs::colorref index))))))) + +(defmacro with-color-dialog ((owner style color custom-colors &key initial-color initial-custom-colors) &body body) + (let ((dlg (gensym))) + `(let ((,color nil) + (,custom-colors nil) + (,dlg (make-instance 'color-dialog + :initial-custom-colors ,initial-custom-colors + :initial-color ,initial-color + :owner ,owner + :style ,style))) + (unwind-protect + (unless (zerop (show ,dlg t)) + (multiple-value-bind (tmp-color tmp-custom) + (obtain-chosen-color ,dlg) + (setf ,color tmp-color + ,custom-colors tmp-custom) + ,@body)) + (gfs:dispose ,dlg))))) + +;;; +;;; methods +;;; + +(defmethod compute-style-flags ((self color-dialog) &rest extra-data) + (let ((std-flags (logior gfs::+cc-anycolor+ gfs::+cc-preventfullopen+ (if extra-data gfs::+cc-rgbinit+ 0)))) + (loop for sym in (style-of self) + do (ecase sym + (:allow-custom-colors + (setf std-flags (logand std-flags (lognot gfs::+cc-preventfullopen+)))) + (:display-solid-only) + (setf std-flags (logior std-flags gfs::+cc-solidcolor+)))) + (values std-flags 0))) + +(defmethod gfs:dispose ((self color-dialog)) + (let ((cc-ptr (gfs:handle self))) + (unless (cffi:null-pointer-p cc-ptr) + (cffi:with-foreign-slots ((gfs::ccolors) cc-ptr gfs::choosecolor) + (unless (cffi:null-pointer-p gfs::ccolors) + (cffi:foreign-free gfs::ccolors))) + (cffi:foreign-free cc-ptr) + (setf (slot-value self 'gfs:handle) nil)))) + +(defmethod initialize-instance :after ((self color-dialog) &key initial-color initial-custom-colors owner &allow-other-keys) + (if (null owner) + (error 'gfs:toolkit-error :detail ":owner initarg is required")) + (if (gfs:disposed-p owner) + (error 'gfs:disposed-error)) + (let ((cc-ptr (cffi:foreign-alloc 'gfs::choosecolor)) + (colors-ptr (cffi:foreign-alloc 'gfs::colorref :count +custom-color-array-size+)) + (index 0) + (default-rgb (gfg:color->rgb gfg:*color-black*))) + (loop for color in initial-custom-colors + when (< index +custom-color-array-size+) + do (progn + (setf (cffi:mem-aref colors-ptr 'gfs::colorref index) (gfg:color->rgb color)) + (incf index))) + (loop until (>= index +custom-color-array-size+) + do (progn + (setf (cffi:mem-aref colors-ptr 'gfs::colorref index) default-rgb) + (incf index))) + (multiple-value-bind (std-style ex-style) + (compute-style-flags self initial-color) + (declare (ignore ex-style)) + (cffi:with-foreign-slots ((gfs::ccsize gfs::howner gfs::hinst gfs::result + gfs::ccolors gfs::flags gfs::cdata gfs::hookfn gfs::templname) + cc-ptr gfs::choosecolor) + (setf gfs::ccsize (cffi:foreign-type-size 'gfs::choosecolor) + gfs::howner (gfs:handle owner) + gfs::hinst (cffi:null-pointer) + gfs::result (gfg:color->rgb (or initial-color (gfg:make-color))) + gfs::ccolors colors-ptr + gfs::flags std-style + gfs::cdata 0 + gfs::hookfn (cffi:null-pointer) + gfs::templname (cffi:null-pointer)))) + (setf (slot-value self 'gfs:handle) cc-ptr))) + +(defmethod show ((self color-dialog) flag) + (declare (ignore flag)) + (show-common-dialog self #'gfs::choose-color)) Modified: trunk/src/uitoolkit/widgets/file-dialog.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/file-dialog.lisp (original) +++ trunk/src/uitoolkit/widgets/file-dialog.lisp Sat Aug 19 18:56:20 2006 @@ -38,19 +38,18 @@ ;;; (defun file-dialog-paths (dlg) - (let ((paths nil) - (ofn-ptr (gfs:handle dlg))) + (let ((ofn-ptr (gfs:handle dlg))) (if (cffi:null-pointer-p ofn-ptr) (error 'gfs:disposed-error)) (cffi:with-foreign-slots ((gfs::ofnfile) ofn-ptr gfs::openfilename) - (unless (or (cffi:null-pointer-p gfs::ofnfile) (= (cffi:mem-ref gfs::ofnfile :char) 0)) + (if (or (cffi:null-pointer-p gfs::ofnfile) (= (cffi:mem-ref gfs::ofnfile :char) 0)) + nil (let* ((raw-list (extract-foreign-strings gfs::ofnfile)) (dir-str (first raw-list))) - (if (cdr raw-list) - (setf paths (loop for filename in (cdr raw-list) - collect (parse-namestring (concatenate 'string dir-str "\\" filename)))) - (setf paths (list (parse-namestring dir-str))))))) - paths)) + (if (rest raw-list) + (loop for filename in (rest raw-list) + collect (parse-namestring (concatenate 'string dir-str "\\" filename))) + (list (parse-namestring dir-str)))))))) (defmacro with-file-dialog ((owner style paths &key default-extension filters initial-directory initial-filename text) &body body) (let ((dlg (gensym))) @@ -106,7 +105,7 @@ (unless (cffi:null-pointer-p gfs::ofndefext) (cffi:foreign-free gfs::ofndefext))) (cffi:foreign-free ofn-ptr) - (setf (slot-value self 'gfs:handle) (cffi:null-pointer))))) + (setf (slot-value self 'gfs:handle) nil)))) (defmethod initialize-instance :after ((self file-dialog) &key default-extension filters initial-directory initial-filename owner style text) ;; FIXME: implement an OFNHookProc to process CDN_SELCHANGE Modified: trunk/src/uitoolkit/widgets/font-dialog.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/font-dialog.lisp (original) +++ trunk/src/uitoolkit/widgets/font-dialog.lisp Sat Aug 19 18:56:20 2006 @@ -65,12 +65,11 @@ :owner ,owner :style ,style))) (unwind-protect - (progn - (unless (zerop (show ,dlg t)) - (multiple-value-bind (f c) (font-dialog-results ,dlg ,gc) - (setf ,font f) - (setf ,color c)) - ,@body)) + (unless (zerop (show ,dlg t)) + (multiple-value-bind (f c) (font-dialog-results ,dlg ,gc) + (setf ,font f) + (setf ,color c)) + ,@body) (gfs:dispose ,dlg))))) ;;; Modified: trunk/src/uitoolkit/widgets/layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/layout.lisp (original) +++ trunk/src/uitoolkit/widgets/layout.lisp Sat Aug 19 18:56:20 2006 @@ -116,15 +116,15 @@ (setf (top-margin-of self) vertical-margins (bottom-margin-of self) vertical-margins))) -(defmethod (setf layout-of) :after ((self layout-manager) (container layout-managed)) - (let ((orig-layout (layout-of container))) +(defmethod (setf layout-of) :after ((layout layout-manager) (self layout-managed)) + (let ((orig-layout (layout-of self))) (if orig-layout - (setf (data-of self) (loop for item in (data-of orig-layout) - when (not (gfs:disposed-p (first item))) - collect item) + (setf (data-of layout) (loop for item in (data-of orig-layout) + when (not (gfs:disposed-p (first item))) + collect item) (data-of orig-layout) nil) - (if (typep container 'window) - (setf (data-of self) (mapchildren container (lambda (parent child) + (if (typep self 'window) + (setf (data-of layout) (mapchildren self (lambda (parent child) (declare (ignore parent)) (list child nil)))))))) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Sat Aug 19 18:56:20 2006 @@ -142,6 +142,9 @@ (defclass label (control) () (:documentation "This class represents non-selectable controls that display a string or image.")) +(defclass color-dialog (widget) () + (:documentation "This class represents the standard color chooser dialog.")) + (defclass file-dialog (widget) ((open-mode :reader open-mode Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Sat Aug 19 18:56:20 2006 @@ -249,9 +249,6 @@ (defgeneric moveable-p (self) (:documentation "Returns T if the object is moveable; nil otherwise.")) -(defgeneric object-to-display (self pnt) - (:documentation "Return a point that is the result of transforming the specified point from this object's coordinate system to display-relative coordinates.")) - (defgeneric owner (self) (:documentation "Returns self's owner (which is not necessarily the same as parent)."))

1 0

[graphic-forms-cvs] r221 - in trunk: . src src/tests/uitoolkit src/uitoolkit/widgets
by junrue＠common-lisp.net 18 Aug '06

18 Aug '06

Author: junrue Date: Fri Aug 18 18:30:58 2006 New Revision: 221 Added: trunk/src/tests/uitoolkit/flow-layout-unit-tests.lisp Modified: trunk/src/packages.lisp trunk/src/tests/uitoolkit/layout-unit-tests.lisp trunk/src/tests/uitoolkit/mock-objects.lisp trunk/src/tests/uitoolkit/test-utils.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/flow-layout.lisp trunk/src/uitoolkit/widgets/layout.lisp trunk/tests.lisp Log: refactored flow-layout implementation, updated associated unit-tests Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Fri Aug 18 18:30:58 2006 @@ -255,6 +255,7 @@ #:flow-layout #:heap-layout #:item + #:layout-managed #:layout-manager #:menu #:menu-item Added: trunk/src/tests/uitoolkit/flow-layout-unit-tests.lisp ============================================================================== --- (empty file) +++ trunk/src/tests/uitoolkit/flow-layout-unit-tests.lisp Fri Aug 18 18:30:58 2006 @@ -0,0 +1,266 @@ +;;;; +;;;; flow-layout-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 *large-size* (gfs:make-size :width 25 :height 5)) +(defvar *small-size* (gfs:make-size :width 20 :height 10)) + +(defvar *flow-uniform-kids* (list (make-instance 'mock-widget :min-size *small-size*) + (make-instance 'mock-widget :min-size *small-size*) + (make-instance 'mock-widget :min-size *small-size*))) +(defvar *flow-mixed-kids* (list (make-instance 'mock-widget :min-size *small-size*) + (make-instance 'mock-widget :min-size *large-size*) + (make-instance 'mock-widget :min-size *small-size*))) + +(defvar *flow-container* (make-instance 'mock-container)) + +(define-test flow-layout-test1 + ;; orient: horizontal + ;; normalize: disabled + ;; wrap: disabled + ;; spacing: 0 + ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 + ;; container: unrestricted width and height + ;; kids: uniform + ;; + (let* ((layout (make-flow-layout *flow-uniform-kids* '(:horizontal))) + (size (gfw::compute-size layout *flow-container* -1 -1)) + (data (gfw::compute-layout layout *flow-container* -1 -1)) + (expected-rects '((0 0 20 10) (20 0 20 10) (40 0 20 10)))) + (assert-equal 60 (gfs:size-width size)) + (assert-equal 10 (gfs:size-height size)) + (validate-rects data expected-rects))) + +(define-test flow-layout-test2 + ;; orient: vertical + ;; normalize: disabled + ;; wrap: disabled + ;; spacing: 0 + ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 + ;; container: unrestricted width and height + ;; kids: uniform + ;; + (let* ((layout (make-flow-layout *flow-uniform-kids* '(:vertical))) + (size (gfw::compute-size layout *flow-container* -1 -1)) + (data (gfw::compute-layout layout *flow-container* -1 -1)) + (expected-rects '((0 0 20 10) (0 10 20 10) (0 20 20 10)))) + (assert-equal 20 (gfs:size-width size)) + (assert-equal 30 (gfs:size-height size)) + (validate-rects data expected-rects))) + +(define-test flow-layout-test3 + ;; orient: horizontal + ;; normalize: disabled + ;; wrap: enabled + ;; spacing: 0 + ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 + ;; container: restricted width, unrestricted height + ;; kids: uniform + ;; + (let* ((layout (make-flow-layout *flow-uniform-kids* '(:horizontal :wrap))) + (data (gfw::compute-layout layout *flow-container* 45 -1)) + (expected-rects '((0 0 20 10) (20 0 20 10) (0 10 20 10)))) + (validate-rects data expected-rects))) + +(define-test flow-layout-test4 + ;; orient: vertical + ;; normalize: disabled + ;; wrap: enabled + ;; spacing: 0 + ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 + ;; container: unrestricted width, restricted height + ;; kids: uniform + ;; + (let* ((layout (make-flow-layout *flow-uniform-kids* '(:vertical :wrap))) + (data (gfw::compute-layout layout *flow-container* -1 25)) + (expected-rects '((0 0 20 10) (0 10 20 10) (20 0 20 10)))) + (validate-rects data expected-rects))) + +(define-test flow-layout-test5 + ;; orient: horizontal + ;; normalize: disabled + ;; wrap: enabled + ;; spacing: 0 + ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 + ;; container: restricted width and height + ;; kids: uniform + ;; + (let* ((layout (make-flow-layout *flow-uniform-kids* '(:horizontal :wrap))) + (data (gfw::compute-layout layout *flow-container* 45 18)) + (expected-rects '((0 0 20 10) (20 0 20 10) (0 10 20 10)))) + (validate-rects data expected-rects))) + +(define-test flow-layout-test6 + ;; orient: vertical + ;; normalize: disabled + ;; wrap: enabled + ;; spacing: 0 + ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 + ;; container: restricted width and height + ;; kids: uniform + ;; + (let* ((layout (make-flow-layout *flow-uniform-kids* '(:vertical :wrap))) + (data (gfw::compute-layout layout *flow-container* 30 25)) + (expected-rects '((0 0 20 10) (0 10 20 10) (20 0 20 10)))) + (validate-rects data expected-rects))) + +(define-test flow-layout-test7 + ;; orient: horizontal + ;; normalize: disabled + ;; wrap: disabled + ;; spacing: 4 + ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 + ;; container: unrestricted width and height + ;; kids: uniform + ;; + (let* ((layout (make-flow-layout *flow-uniform-kids* '(:horizontal) 4)) + (size (gfw::compute-size layout *flow-container* -1 -1)) + (data (gfw::compute-layout layout *flow-container* -1 -1)) + (expected-rects '((0 0 20 10) (24 0 20 10) (48 0 20 10)))) + (assert-equal 68 (gfs:size-width size)) + (assert-equal 10 (gfs:size-height size)) + (validate-rects data expected-rects))) + +(define-test flow-layout-test8 + ;; orient: vertical + ;; normalize: disabled + ;; wrap: disabled + ;; spacing: 4 + ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 + ;; container: unrestricted width and height + ;; kids: uniform + ;; + (let* ((layout (make-flow-layout *flow-uniform-kids* '(:vertical) 4)) + (size (gfw::compute-size layout *flow-container* -1 -1)) + (data (gfw::compute-layout layout *flow-container* -1 -1)) + (expected-rects '((0 0 20 10) (0 14 20 10) (0 28 20 10)))) + (assert-equal 20 (gfs:size-width size)) + (assert-equal 38 (gfs:size-height size)) + (validate-rects data expected-rects))) + +(define-test flow-layout-test9 + ;; orient: horizontal + ;; normalize: disabled + ;; wrap: enabled + ;; spacing: 4 + ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 + ;; container: restricted width and height + ;; kids: uniform + ;; + (let* ((layout (make-flow-layout *flow-uniform-kids* '(:horizontal :wrap) 4)) + (data (gfw::compute-layout layout *flow-container* 45 18)) + (expected-rects '((0 0 20 10) (24 0 20 10) (0 14 20 10)))) + (validate-rects data expected-rects))) + +(define-test flow-layout-test10 + ;; orient: vertical + ;; normalize: disabled + ;; wrap: enabled + ;; spacing: 4 + ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 + ;; container: restricted width and height + ;; kids: uniform + ;; + (let* ((layout (make-flow-layout *flow-uniform-kids* '(:vertical :wrap) 4)) + (data (gfw::compute-layout layout *flow-container* 30 25)) + (expected-rects '((0 0 20 10) (0 14 20 10) (24 0 20 10)))) + (validate-rects data expected-rects))) + +(define-test flow-layout-test11 + ;; orient: horizontal + ;; normalize: disabled + ;; wrap: disabled + ;; spacing: 0 + ;; left-margin: 3, top-margin: 3, right-margin: 0, bottom-margin: 0 + ;; container: unrestricted width and height + ;; kids: uniform + ;; + (let* ((layout (make-flow-layout *flow-uniform-kids* '(:horizontal) 0 3 3)) + (size (gfw::compute-size layout *flow-container* -1 -1)) + (data (gfw::compute-layout layout *flow-container* -1 -1)) + (expected-rects '((3 3 20 10) (23 3 20 10) (43 3 20 10)))) + (assert-equal 63 (gfs:size-width size)) + (assert-equal 13 (gfs:size-height size)) + (validate-rects data expected-rects))) + +(define-test flow-layout-test12 + ;; orient: vertical + ;; normalize: disabled + ;; wrap: disabled + ;; spacing: 0 + ;; left-margin: 0, top-margin: 0, right-margin: 3, bottom-margin: 3 + ;; container: unrestricted width and height + ;; kids: uniform + ;; + (let* ((layout (make-flow-layout *flow-uniform-kids* '(:vertical) 0 0 0 3 3)) + (size (gfw::compute-size layout *flow-container* -1 -1)) + (data (gfw::compute-layout layout *flow-container* -1 -1)) + (expected-rects '((0 0 20 10) (0 10 20 10) (0 20 20 10)))) + (assert-equal 23 (gfs:size-width size)) + (assert-equal 33 (gfs:size-height size)) + (validate-rects data expected-rects))) + +(define-test flow-layout-test13 + ;; orient: horizontal + ;; normalize: enabled + ;; wrap: disabled + ;; spacing: 0 + ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 + ;; container: unrestricted width and height + ;; kids: mixed + ;; + (let* ((layout (make-flow-layout *flow-mixed-kids* '(:horizontal :normalize))) + (size (gfw::compute-size layout *flow-container* -1 -1)) + (data (gfw::compute-layout layout *flow-container* -1 -1)) + (expected-rects '((0 0 25 10) (25 0 25 10) (50 0 25 10)))) + (assert-equal 75 (gfs:size-width size)) + (assert-equal 10 (gfs:size-height size)) + (validate-rects data expected-rects))) + +(define-test flow-layout-test14 + ;; orient: vertical + ;; normalize: enabled + ;; wrap: disabled + ;; spacing: 0 + ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 + ;; container: unrestricted width and height + ;; kids: mixed + ;; + (let* ((layout (make-flow-layout *flow-mixed-kids* '(:vertical :normalize))) + (size (gfw::compute-size layout *flow-container* -1 -1)) + (data (gfw::compute-layout layout *flow-container* -1 -1)) + (expected-rects '((0 0 25 10) (0 10 25 10) (0 20 25 10)))) + (assert-equal 25 (gfs:size-width size)) + (assert-equal 30 (gfs:size-height size)) + (validate-rects data expected-rects))) 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 Aug 18 18:30:58 2006 @@ -33,27 +33,6 @@ (in-package :graphic-forms.uitoolkit.tests) -(defvar *large-size* (gfs:make-size :width 25 :height 5)) -(defvar *small-size* (gfs:make-size :width 20 :height 10)) -(defvar *flow-layout-uniform-kids* (list (make-instance 'mock-widget :min-size *small-size*) - (make-instance 'mock-widget :min-size *small-size*) - (make-instance 'mock-widget :min-size *small-size*))) -(defvar *flow-layout-mixed-kids* (list (make-instance 'mock-widget :min-size *small-size*) - (make-instance 'mock-widget :min-size *large-size*) - (make-instance 'mock-widget :min-size *small-size*))) - -(defun validate-layout-rects (entries expected-rects) - (let ((actual-rects (loop for entry in entries collect (cdr entry)))) - (mapc #'(lambda (expected actual) - (let ((pnt-a (gfs:location actual)) - (sz-a (gfs:size actual))) - (assert-equal (first expected) (gfs:point-x pnt-a)) - (assert-equal (second expected) (gfs:point-y pnt-a)) - (assert-equal (third expected) (gfs:size-width sz-a)) - (assert-equal (fourth expected) (gfs:size-height sz-a)))) - expected-rects - actual-rects))) - (define-test layout-attributes-test (let ((widget1 (make-instance 'mock-widget :handle 1234)) (widget2 (make-instance 'mock-widget :handle 5678))) @@ -72,229 +51,3 @@ (assert-equal 10 (gfw:layout-attribute layout widget2 'a)) (assert-equal 30 (gfw:layout-attribute layout widget2 'c)) (assert-equal 100 (gfw:layout-attribute layout widget2 'd))))) - -(define-test flow-layout-test1 - ;; orient: horizontal - ;; normalize: disabled - ;; wrap: disabled - ;; spacing: 0 - ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 - ;; container: unrestricted width and height - ;; kids: uniform - ;; - (let* ((layout (make-instance 'gfw:flow-layout :style '(:horizontal))) - (size (gfw::flow-container-size layout t *flow-layout-uniform-kids* -1 -1)) - (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* -1 -1)) - (expected-rects '((0 0 20 10) (20 0 20 10) (40 0 20 10)))) - (assert-equal 60 (gfs:size-width size)) - (assert-equal 10 (gfs:size-height size)) - (validate-layout-rects data expected-rects))) - -(define-test flow-layout-test2 - ;; orient: vertical - ;; normalize: disabled - ;; wrap: disabled - ;; spacing: 0 - ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 - ;; container: unrestricted width and height - ;; kids: uniform - ;; - (let* ((layout (make-instance 'gfw:flow-layout :style '(:vertical))) - (size (gfw::flow-container-size layout t *flow-layout-uniform-kids* -1 -1)) - (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* -1 -1)) - (expected-rects '((0 0 20 10) (0 10 20 10) (0 20 20 10)))) - (assert-equal 20 (gfs:size-width size)) - (assert-equal 30 (gfs:size-height size)) - (validate-layout-rects data expected-rects))) - -(define-test flow-layout-test3 - ;; orient: horizontal - ;; normalize: disabled - ;; wrap: enabled - ;; spacing: 0 - ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 - ;; container: restricted width, unrestricted height - ;; kids: uniform - ;; - (let* ((layout (make-instance 'gfw:flow-layout :style '(:horizontal :wrap))) - (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* 45 -1)) - (expected-rects '((0 0 20 10) (20 0 20 10) (0 10 20 10)))) - (validate-layout-rects data expected-rects))) - -(define-test flow-layout-test4 - ;; orient: vertical - ;; normalize: disabled - ;; wrap: enabled - ;; spacing: 0 - ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 - ;; container: unrestricted width, restricted height - ;; kids: uniform - ;; - (let* ((layout (make-instance 'gfw:flow-layout :style '(:vertical :wrap))) - (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* -1 25)) - (expected-rects '((0 0 20 10) (0 10 20 10) (20 0 20 10)))) - (validate-layout-rects data expected-rects))) - -(define-test flow-layout-test5 - ;; orient: horizontal - ;; normalize: disabled - ;; wrap: enabled - ;; spacing: 0 - ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 - ;; container: restricted width and height - ;; kids: uniform - ;; - (let* ((layout (make-instance 'gfw:flow-layout :style '(:horizontal :wrap))) - (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* 45 18)) - (expected-rects '((0 0 20 10) (20 0 20 10) (0 10 20 10)))) - (validate-layout-rects data expected-rects))) - -(define-test flow-layout-test6 - ;; orient: vertical - ;; normalize: disabled - ;; wrap: enabled - ;; spacing: 0 - ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 - ;; container: restricted width and height - ;; kids: uniform - ;; - (let* ((layout (make-instance 'gfw:flow-layout :style '(:vertical :wrap))) - (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* 30 25)) - (expected-rects '((0 0 20 10) (0 10 20 10) (20 0 20 10)))) - (validate-layout-rects data expected-rects))) - -(define-test flow-layout-test7 - ;; orient: horizontal - ;; normalize: disabled - ;; wrap: disabled - ;; spacing: 4 - ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 - ;; container: unrestricted width and height - ;; kids: uniform - ;; - (let* ((layout (make-instance 'gfw:flow-layout :spacing 4 :style '(:horizontal))) - (size (gfw::flow-container-size layout t *flow-layout-uniform-kids* -1 -1)) - (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* -1 -1)) - (expected-rects '((0 0 20 10) (24 0 20 10) (48 0 20 10)))) - (assert-equal 68 (gfs:size-width size)) - (assert-equal 10 (gfs:size-height size)) - (validate-layout-rects data expected-rects))) - -(define-test flow-layout-test8 - ;; orient: vertical - ;; normalize: disabled - ;; wrap: disabled - ;; spacing: 4 - ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 - ;; container: unrestricted width and height - ;; kids: uniform - ;; - (let* ((layout (make-instance 'gfw:flow-layout :spacing 4 :style '(:vertical))) - (size (gfw::flow-container-size layout t *flow-layout-uniform-kids* -1 -1)) - (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* -1 -1)) - (expected-rects '((0 0 20 10) (0 14 20 10) (0 28 20 10)))) - (assert-equal 20 (gfs:size-width size)) - (assert-equal 38 (gfs:size-height size)) - (validate-layout-rects data expected-rects))) - -(define-test flow-layout-test9 - ;; orient: horizontal - ;; normalize: disabled - ;; wrap: enabled - ;; spacing: 4 - ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 - ;; container: restricted width and height - ;; kids: uniform - ;; - (let* ((layout (make-instance 'gfw:flow-layout :spacing 4 :style '(:horizontal :wrap))) - (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* 45 18)) - (expected-rects '((0 0 20 10) (24 0 20 10) (0 14 20 10)))) - (validate-layout-rects data expected-rects))) - -(define-test flow-layout-test10 - ;; orient: vertical - ;; normalize: disabled - ;; wrap: enabled - ;; spacing: 4 - ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 - ;; container: restricted width and height - ;; kids: uniform - ;; - (let* ((layout (make-instance 'gfw:flow-layout :spacing 4 :style '(:vertical :wrap))) - (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* 30 25)) - (expected-rects '((0 0 20 10) (0 14 20 10) (24 0 20 10)))) - (validate-layout-rects data expected-rects))) - -(define-test flow-layout-test11 - ;; orient: horizontal - ;; normalize: disabled - ;; wrap: disabled - ;; spacing: 0 - ;; left-margin: 3, top-margin: 3, right-margin: 0, bottom-margin: 0 - ;; container: unrestricted width and height - ;; kids: uniform - ;; - (let* ((layout (make-instance 'gfw:flow-layout - :style '(:horizontal) - :left-margin 3 - :top-margin 3)) - (size (gfw::flow-container-size layout t *flow-layout-uniform-kids* -1 -1)) - (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* -1 -1)) - (expected-rects '((3 3 20 10) (23 3 20 10) (43 3 20 10)))) - (assert-equal 63 (gfs:size-width size)) - (assert-equal 13 (gfs:size-height size)) - (validate-layout-rects data expected-rects))) - -(define-test flow-layout-test12 - ;; orient: vertical - ;; normalize: disabled - ;; wrap: disabled - ;; spacing: 0 - ;; left-margin: 0, top-margin: 0, right-margin: 3, bottom-margin: 3 - ;; container: unrestricted width and height - ;; kids: uniform - ;; - (let* ((layout (make-instance 'gfw:flow-layout - :style '(:vertical) - :right-margin 3 - :bottom-margin 3)) - (size (gfw::flow-container-size layout t *flow-layout-uniform-kids* -1 -1)) - (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* -1 -1)) - (expected-rects '((0 0 20 10) (0 10 20 10) (0 20 20 10)))) - (assert-equal 23 (gfs:size-width size)) - (assert-equal 33 (gfs:size-height size)) - (validate-layout-rects data expected-rects))) - -(define-test flow-layout-test13 - ;; orient: horizontal - ;; normalize: enabled - ;; wrap: disabled - ;; spacing: 0 - ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 - ;; container: unrestricted width and height - ;; kids: mixed - ;; - (let* ((layout (make-instance 'gfw:flow-layout :style '(:horizontal :normalize))) - (size (gfw::flow-container-size layout t *flow-layout-mixed-kids* -1 -1)) - (data (gfw::flow-container-layout layout t *flow-layout-mixed-kids* -1 -1)) - (expected-rects '((0 0 25 10) (25 0 25 10) (50 0 25 10)))) - (assert-equal 75 (gfs:size-width size)) - (assert-equal 10 (gfs:size-height size)) - (validate-layout-rects data expected-rects))) - -(define-test flow-layout-test14 - ;; orient: vertical - ;; normalize: enabled - ;; wrap: disabled - ;; spacing: 0 - ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 - ;; container: unrestricted width and height - ;; kids: mixed - ;; - (let* ((layout (make-instance 'gfw:flow-layout :style '(:vertical :normalize))) - (size (gfw::flow-container-size layout t *flow-layout-mixed-kids* -1 -1)) - (data (gfw::flow-container-layout layout t *flow-layout-mixed-kids* -1 -1)) - (expected-rects '((0 0 25 10) (0 10 25 10) (0 20 25 10)))) - (assert-equal 25 (gfs:size-width size)) - (assert-equal 30 (gfs:size-height size)) - (validate-layout-rects data expected-rects))) Modified: trunk/src/tests/uitoolkit/mock-objects.lisp ============================================================================== --- trunk/src/tests/uitoolkit/mock-objects.lisp (original) +++ trunk/src/tests/uitoolkit/mock-objects.lisp Fri Aug 18 18:30:58 2006 @@ -33,10 +33,33 @@ (in-package :graphic-forms.uitoolkit.tests) -(defconstant +max-widget-size+ 5000) +(defconstant +max-widget-size+ 5000) +(defconstant +default-container-width+ 300) +(defconstant +default-container-height+ 200) ;;; -;;; stand-ins for widgets that would be children of windows, to be organized +;;; stand-in for a window, used as parent of mock-widget +;;; + +(defclass mock-container (gfw:layout-managed) + ((location + :accessor location-of + :initarg :location + :initform (gfs:make-point)) + (size + :accessor size-of + :initarg :size + :initform (gfs:make-size :width +default-container-width+ :height +default-container-height+)) + (visibility + :accessor visibility-of + :initarg :visibility + :initform t))) + +(defmethod gfw:visible-p ((self mock-container)) + (visibility-of self)) + +;;; +;;; stand-in for widgets that would be children of windows, to be organized ;;; via layout managers ;;; Modified: trunk/src/tests/uitoolkit/test-utils.lisp ============================================================================== --- trunk/src/tests/uitoolkit/test-utils.lisp (original) +++ trunk/src/tests/uitoolkit/test-utils.lisp Fri Aug 18 18:30:58 2006 @@ -33,9 +33,32 @@ (in-package :graphic-forms.uitoolkit.tests) +(defun make-flow-layout (kids style &optional spacing left-margin top-margin right-margin bottom-margin) + (let ((layout (make-instance 'gfw:flow-layout + :style style + :spacing (or spacing 0) + :left-margin (or left-margin 0) + :top-margin (or top-margin 0) + :right-margin (or right-margin 0) + :bottom-margin (or bottom-margin 0)))) + (loop for kid in kids do (gfw::append-layout-item layout kid)) + layout)) + (defun validate-image (image expected-size expected-depth) (declare (ignore expected-depth)) (assert-false (null image)) (assert-false (gfs:disposed-p image)) ;; (assert-equal expected-depth (gfg:depth image)) ; FIXME: image->data needed (assert-equality #'gfs:equal-size-p expected-size (gfg:size image))) + +(defun validate-rects (entries expected-rects) + (let ((actual-rects (loop for entry in entries collect (cdr entry)))) + (mapc #'(lambda (expected actual) + (let ((pnt-a (gfs:location actual)) + (sz-a (gfs:size actual))) + (assert-equal (first expected) (gfs:point-x pnt-a)) + (assert-equal (second expected) (gfs:point-y pnt-a)) + (assert-equal (third expected) (gfs:size-width sz-a)) + (assert-equal (fourth expected) (gfs:size-height sz-a)))) + expected-rects + actual-rects))) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Fri Aug 18 18:30:58 2006 @@ -34,7 +34,6 @@ (in-package :graphic-forms.uitoolkit.widgets) (eval-when (:compile-toplevel :load-toplevel :execute) - (defconstant +wm-gf-init-msg+ #xABCD) (defconstant +key-event-peek-flags+ (logior gfs::+pm-noremove+ gfs::+pm-noyield+ gfs::+pm-qs-input+ @@ -222,18 +221,8 @@ (defmethod process-message (hwnd (msg (eql gfs::+wm-create+)) wparam lparam) (let ((widget (get-widget (thread-context) hwnd))) ; has side-effect of setting handle slot (if (typep widget 'dialog) - (let ((tmp (gfs::def-dlg-proc hwnd msg wparam lparam))) - (gfs::post-message hwnd +wm-gf-init-msg+ 0 0) ; 2nd stage init with fully-baked widget - (return-from process-message tmp)) - (gfs::post-message hwnd +wm-gf-init-msg+ 0 0))) ; 2nd stage init with fully-baked widget - 0) - -(defmethod process-message (hwnd (msg (eql +wm-gf-init-msg+)) wparam lparam) - (declare (ignore wparam lparam)) - (let ((widget (get-widget (thread-context) hwnd))) - (unless widget - (return-from process-message 0))) - 0) + (gfs::def-dlg-proc hwnd msg wparam lparam) + 0))) (defmethod process-message (hwnd (msg (eql gfs::+wm-destroy+)) wparam lparam) (declare (ignore wparam lparam)) Modified: trunk/src/uitoolkit/widgets/flow-layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/flow-layout.lisp (original) +++ trunk/src/uitoolkit/widgets/flow-layout.lisp Fri Aug 18 18:30:58 2006 @@ -53,7 +53,7 @@ (start-margin-fn nil) (current nil)) -(defun init-flow-data (layout visible kids width-hint height-hint) +(defun init-flow-data (layout visible items width-hint height-hint) (let ((state (if (find :vertical (style-of layout)) (make-flow-data :hint height-hint :next-coord (top-margin-of layout) @@ -71,7 +71,8 @@ :extent-fn #'gfs:size-height :limit-margin-fn #'right-margin-of :start-margin-fn #'left-margin-of)))) - (loop for kid in kids + (loop for item in items + for kid = (first item) when (or (visible-p kid) (not visible)) do (let* ((size (preferred-size kid -1 -1)) (dist (funcall (flow-data-distance-fn state) size)) @@ -86,37 +87,6 @@ (setf (flow-data-kid-sizes state) (reverse (flow-data-kid-sizes state))) state)) -(defun flow-container-size (layout visible kids width-hint height-hint) - (let ((kid-count (length kids)) - (horz-margin-total (+ (left-margin-of layout) (right-margin-of layout))) - (vert-margin-total (+ (top-margin-of layout) (bottom-margin-of layout))) - (vertical (find :vertical (style-of layout))) - (horizontal (find :horizontal (style-of layout)))) - (let ((spacing-total (* (spacing-of layout) (1- kid-count))) - (state (init-flow-data layout - visible - kids - (if vertical width-hint -1) - (if vertical -1 height-hint)))) - (if (find :normalize (style-of layout)) - (setf (flow-data-distance-total state) (* (flow-data-max-distance state) kid-count))) - (cond - (horizontal - (gfs:make-size :width (+ (flow-data-distance-total state) - horz-margin-total - spacing-total) - :height (+ (flow-data-max-extent state) - vert-margin-total))) - (vertical - (gfs:make-size :width (+ (flow-data-max-extent state) - horz-margin-total) - :height (+ (flow-data-distance-total state) - vert-margin-total - spacing-total))) - (t - (error 'gfs:toolkit-error - :detail (format nil "unrecognized flow layout style: ~a" (style-of layout)))))))) - (defun wrap-needed-p (state layout kid-size) (and (>= (flow-data-hint state) 0) (> (+ (flow-data-next-coord state) @@ -143,12 +113,49 @@ (flow-data-spacing state))) (cons kid (gfs:make-rectangle :size kid-size :location pnt)))) -(defun flow-container-layout (layout visible kids width-hint height-hint) +;;; +;;; methods +;;; + +(defmethod compute-size ((self flow-layout) (container layout-managed) width-hint height-hint) + (cleanup-disposed-items self) + (let ((kid-count (length (data-of self))) + (horz-margin-total (+ (left-margin-of self) (right-margin-of self))) + (vert-margin-total (+ (top-margin-of self) (bottom-margin-of self))) + (vertical (find :vertical (style-of self))) + (horizontal (find :horizontal (style-of self)))) + (let ((spacing-total (* (spacing-of self) (1- kid-count))) + (state (init-flow-data self + (visible-p container) + (data-of self) + (if vertical width-hint -1) + (if vertical -1 height-hint)))) + (if (find :normalize (style-of self)) + (setf (flow-data-distance-total state) (* (flow-data-max-distance state) kid-count))) + (cond + (horizontal + (gfs:make-size :width (+ (flow-data-distance-total state) + horz-margin-total + spacing-total) + :height (+ (flow-data-max-extent state) + vert-margin-total))) + (vertical + (gfs:make-size :width (+ (flow-data-max-extent state) + horz-margin-total) + :height (+ (flow-data-distance-total state) + vert-margin-total + spacing-total))) + (t + (error 'gfs:toolkit-error + :detail (format nil "unrecognized flow layout style: ~a" (style-of self)))))))) + +(defmethod compute-layout ((self flow-layout) (container layout-managed) width-hint height-hint) + (cleanup-disposed-items self) (let ((flows nil) - (normal (find :normalize (style-of layout))) - (vertical (find :vertical (style-of layout))) - (state (init-flow-data layout visible kids width-hint height-hint))) - (loop with wrap = (find :wrap (style-of layout)) + (normal (find :normalize (style-of self))) + (vertical (find :vertical (style-of self))) + (state (init-flow-data self (visible-p container) (data-of self) width-hint height-hint))) + (loop with wrap = (find :wrap (style-of self)) for (kid kid-size) in (flow-data-kid-sizes state) do (cond ((and normal vertical) @@ -159,26 +166,13 @@ (gfs:size-height kid-size) (flow-data-max-extent state)))) (if (and wrap (flow-data-current state) - (wrap-needed-p state layout kid-size)) - (setf flows (append flows (wrap-flow state layout)))) - (push (new-flow-element state layout kid kid-size) (flow-data-current state))) + (wrap-needed-p state self kid-size)) + (setf flows (append flows (wrap-flow state self)))) + (push (new-flow-element state self kid kid-size) (flow-data-current state))) (if (flow-data-current state) - (setf flows (append flows (wrap-flow state layout)))) + (setf flows (append flows (wrap-flow state self)))) flows)) -;;; -;;; methods -;;; - -(defmethod compute-size ((self flow-layout) (container layout-managed) width-hint height-hint) - (cleanup-disposed-items self) - (let ((kids (loop for item in (data-of self) collect (first item)))) - (flow-container-size self (visible-p container) kids width-hint height-hint))) - -(defmethod compute-layout ((self flow-layout) (container layout-managed) width-hint height-hint) - (cleanup-disposed-items self) - (let ((kids (loop for item in (data-of self) collect (first item)))) - (flow-container-layout self (visible-p container) kids width-hint height-hint))) (defmethod initialize-instance :after ((self flow-layout) &key) (unless (intersection (style-of self) '(:horizontal :vertical)) Modified: trunk/src/uitoolkit/widgets/layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/layout.lisp (original) +++ trunk/src/uitoolkit/widgets/layout.lisp Fri Aug 18 18:30:58 2006 @@ -60,7 +60,7 @@ (defsetf layout-attribute set-layout-attribute) (defun append-layout-item (layout thing) - "Adds thing to layout unless it is already registered." + "Adds thing to layout. Duplicate entries are not prevented." (setf (data-of layout) (nconc (data-of layout) (list (list thing nil))))) (defun delete-layout-item (layout thing) Modified: trunk/tests.lisp ============================================================================== --- trunk/tests.lisp (original) +++ trunk/tests.lisp Fri Aug 18 18:30:58 2006 @@ -43,5 +43,6 @@ (load (concatenate 'string *gf-tests-dir* "image-unit-tests")) (load (concatenate 'string *gf-tests-dir* "icon-bundle-unit-tests")) (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* "misc-unit-tests")))

1 0

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

18 Aug '06

Author: junrue Date: Fri Aug 18 13:18:48 2006 New Revision: 220 Modified: trunk/docs/manual/widgets-api.texinfo trunk/src/tests/uitoolkit/layout-unit-tests.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/widgets/control.lisp trunk/src/uitoolkit/widgets/dialog.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/flow-layout.lisp trunk/src/uitoolkit/widgets/heap-layout.lisp trunk/src/uitoolkit/widgets/layout.lisp trunk/src/uitoolkit/widgets/thread-context.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/widget.lisp trunk/src/uitoolkit/widgets/window.lisp Log: implemented layout item registration, no longer directly using mapchildren to layout children Modified: trunk/docs/manual/widgets-api.texinfo ============================================================================== --- trunk/docs/manual/widgets-api.texinfo (original) +++ trunk/docs/manual/widgets-api.texinfo Fri Aug 18 13:18:48 2006 @@ -539,8 +539,10 @@ Instances of this class employ a @ref{layout-manager} to maintain the positions and sizes of their children. @deffn Accessor layout-of -Accepts or returns the @ref{layout-manager} associated with this -container. +Accepts or returns the layout-manager associated with this +container. Note that children currently registered with the previous +layout-manager are copied to the new one, but existing layout +attributes that were set for each child are not copied. @end deffn @deffn Initarg :layout Accepts a @ref{layout-manager} object whose responsibility is to manage @@ -1701,11 +1703,10 @@ @anchor{compute-layout} @deffn GenericFunction compute-layout @ref{layout-manager} container width-hint height-hint -Returns a list of pairs @code{(item rectangle)} describing the +Returns a list of conses @code{(child . rectangle)} describing the new bounds of each child within @var{container}. A layout-manager subclass implements this method based on its particular layout strategy, taking -into account attributes set by the user via @ref{layout-attribute}. Certain -Graphic-Forms functions call this method to accomplish layout within a container. +into account attributes set by the user via @ref{layout-attribute}. @table @var @item layout-manager The layout object dictating how children of @var{container} 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 Aug 18 13:18:48 2006 @@ -57,8 +57,8 @@ (define-test layout-attributes-test (let ((widget1 (make-instance 'mock-widget :handle 1234)) (widget2 (make-instance 'mock-widget :handle 5678))) - (let ((data1 `(,(cffi:make-pointer 1234) (a 1 b 2))) - (data2 `(,(cffi:make-pointer 5678) (a 10 c 30))) + (let ((data1 `(,widget1 (a 1 b 2))) + (data2 `(,widget2 (a 10 c 30))) (layout (make-instance 'gfw:layout-manager))) (setf (slot-value layout 'gfw::data) (list data1 data2)) (assert-equal 1 (gfw:layout-attribute layout widget1 'a)) Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Fri Aug 18 13:18:48 2006 @@ -1014,6 +1014,14 @@ (defconstant +wm-displaychange+ #x007E) (defconstant +wm-geticon+ #x007F) (defconstant +wm-seticon+ #x0080) +(defconstant +wm-nccreate+ #x0081) +(defconstant +wm-ncdestroy+ #x0082) +(defconstant +wm-nccalcsize+ #x0083) +(defconstant +wm-nchittest+ #x0084) +(defconstant +wm-ncpaint+ #x0085) +(defconstant +wm-ncactivate+ #x0086) +(defconstant +wm-getdlgcode+ #x0087) +(defconstant +wm-syncpaint+ #x0088) (defconstant +wm-ncmousemove+ #x00A0) (defconstant +wm-nclbuttondown+ #x00A1) (defconstant +wm-nclbuttonup+ #x00A2) Modified: trunk/src/uitoolkit/widgets/control.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/control.lisp (original) +++ trunk/src/uitoolkit/widgets/control.lisp Fri Aug 18 13:18:48 2006 @@ -43,7 +43,13 @@ (put-widget (thread-context) ctrl) (let ((hfont (gfs::get-stock-object gfs::+default-gui-font+))) (unless (gfs:null-handle-p hfont) - (gfs::send-message hwnd gfs::+wm-setfont+ (cffi:pointer-address hfont) 0))))) + (gfs::send-message hwnd gfs::+wm-setfont+ (cffi:pointer-address hfont) 0))) + ;; FIXME: this is a temporary hack to allow layout management testing; + ;; it breaks in the presence of virtual containers like group + ;; + (let ((parent (parent ctrl))) + (when (and parent (layout-of parent)) + (append-layout-item (layout-of parent) ctrl))))) ;;; ;;; methods Modified: trunk/src/uitoolkit/widgets/dialog.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/dialog.lisp (original) +++ trunk/src/uitoolkit/widgets/dialog.lisp Fri Aug 18 13:18:48 2006 @@ -169,7 +169,7 @@ (error 'gfs:disposed-error))) (if (null text) (setf text *default-dialog-title*)) - ;; NOTE: do not allow apps to specify the desktop window as the + ;; Don't allow apps to specify the desktop window as the ;; owner of the dialog; it would cause the desktop to become ;; disabled. ;; Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Fri Aug 18 13:18:48 2006 @@ -33,10 +33,12 @@ (in-package :graphic-forms.uitoolkit.widgets) -(defconstant +key-event-peek-flags+ (logior gfs::+pm-noremove+ - gfs::+pm-noyield+ - gfs::+pm-qs-input+ - gfs::+pm-qs-postmessage+)) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defconstant +wm-gf-init-msg+ #xABCD) + (defconstant +key-event-peek-flags+ (logior gfs::+pm-noremove+ + gfs::+pm-noyield+ + gfs::+pm-qs-input+ + gfs::+pm-qs-postmessage+))) ;;; ;;; window procedures @@ -139,6 +141,8 @@ (setf ret-val (cffi:pointer-address (brush-handle-of widget)))) ret-val)) +;;; FIXME: replace event-time slot with call to GetMessageTime +;;; (defun obtain-event-time () (event-time (thread-context))) @@ -216,13 +220,30 @@ 0) (defmethod process-message (hwnd (msg (eql gfs::+wm-create+)) wparam lparam) - (let ((w (get-widget (thread-context) hwnd))) ; has side-effect of setting handle slot - (if (typep w 'dialog) - (return-from process-message (gfs::def-dlg-proc hwnd msg wparam lparam)))) + (let ((widget (get-widget (thread-context) hwnd))) ; has side-effect of setting handle slot + (if (typep widget 'dialog) + (let ((tmp (gfs::def-dlg-proc hwnd msg wparam lparam))) + (gfs::post-message hwnd +wm-gf-init-msg+ 0 0) ; 2nd stage init with fully-baked widget + (return-from process-message tmp)) + (gfs::post-message hwnd +wm-gf-init-msg+ 0 0))) ; 2nd stage init with fully-baked widget + 0) + +(defmethod process-message (hwnd (msg (eql +wm-gf-init-msg+)) wparam lparam) + (declare (ignore wparam lparam)) + (let ((widget (get-widget (thread-context) hwnd))) + (unless widget + (return-from process-message 0))) 0) (defmethod process-message (hwnd (msg (eql gfs::+wm-destroy+)) wparam lparam) (declare (ignore wparam lparam)) + (let ((widget (get-widget (thread-context) hwnd))) + (if widget + (event-dispose (dispatcher widget) widget))) + ;; If widget is registered with a layout manager, that reference + ;; is not cleared until the next time the layout manager is invoked. + ;; This alleviates the need for slow messy code here. + ;; (delete-widget (thread-context) hwnd) 0) @@ -242,10 +263,10 @@ (defmethod process-message (hwnd (msg (eql gfs::+wm-char+)) wparam lparam) (declare (ignore lparam)) (let* ((tc (thread-context)) - (w (get-widget tc hwnd)) + (widget (get-widget tc hwnd)) (ch (code-char (lo-word wparam)))) - (when w - (event-key-down (dispatcher w) w (virtual-key tc) ch))) + (when widget + (event-key-down (dispatcher widget) widget (virtual-key tc) ch))) 0) (defmethod process-message (hwnd (msg (eql gfs::+wm-keydown+)) wparam lparam) Modified: trunk/src/uitoolkit/widgets/flow-layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/flow-layout.lisp (original) +++ trunk/src/uitoolkit/widgets/flow-layout.lisp Fri Aug 18 13:18:48 2006 @@ -170,18 +170,16 @@ ;;; methods ;;; -(defmethod compute-size ((layout flow-layout) (win window) width-hint height-hint) - (let ((kids (mapchildren win (lambda (parent child) - (declare (ignore parent)) - child)))) - (flow-container-size layout (visible-p win) kids width-hint height-hint))) +(defmethod compute-size ((self flow-layout) (container layout-managed) width-hint height-hint) + (cleanup-disposed-items self) + (let ((kids (loop for item in (data-of self) collect (first item)))) + (flow-container-size self (visible-p container) kids width-hint height-hint))) -(defmethod compute-layout ((layout flow-layout) (win window) width-hint height-hint) - (let ((kids (mapchildren win (lambda (parent child) - (declare (ignore parent)) - child)))) - (flow-container-layout layout (visible-p win) kids width-hint height-hint))) +(defmethod compute-layout ((self flow-layout) (container layout-managed) width-hint height-hint) + (cleanup-disposed-items self) + (let ((kids (loop for item in (data-of self) collect (first item)))) + (flow-container-layout self (visible-p container) kids width-hint height-hint))) -(defmethod initialize-instance :after ((layout flow-layout) &key) - (unless (intersection (style-of layout) '(:horizontal :vertical)) - (setf (style-of layout) (list :horizontal)))) +(defmethod initialize-instance :after ((self flow-layout) &key) + (unless (intersection (style-of self) '(:horizontal :vertical)) + (setf (style-of self) (list :horizontal)))) Modified: trunk/src/uitoolkit/widgets/heap-layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/heap-layout.lisp (original) +++ trunk/src/uitoolkit/widgets/heap-layout.lisp Fri Aug 18 13:18:48 2006 @@ -37,21 +37,23 @@ ;;; methods ;;; -(defmethod compute-size ((self heap-layout) win width-hint height-hint) +(defmethod compute-size ((self heap-layout) (container layout-managed) width-hint height-hint) + (cleanup-disposed-items self) (let ((size (gfs:make-size))) - (mapchildren win (lambda (parent kid) - (declare (ignore parent)) - (let ((kid-size (preferred-size kid width-hint height-hint))) - (setf (gfs:size-width size) (max (gfs:size-width size) - (gfs:size-width kid-size)) - (gfs:size-height size) (max (gfs:size-height size) - (gfs:size-height kid-size)))))) + (mapc (lambda (item) + (let ((kid-size (preferred-size (first item) width-hint height-hint))) + (setf (gfs:size-width size) (max (gfs:size-width size) + (gfs:size-width kid-size)) + (gfs:size-height size) (max (gfs:size-height size) + (gfs:size-height kid-size))))) + (data-of self)) (incf (gfs:size-width size) (+ (left-margin-of self) (right-margin-of self))) (incf (gfs:size-height size) (+ (top-margin-of self) (bottom-margin-of self))) size)) -(defmethod compute-layout ((self heap-layout) win width-hint height-hint) - (let* ((size (client-size win)) +(defmethod compute-layout ((self heap-layout) (container layout-managed) width-hint height-hint) + (cleanup-disposed-items self) + (let* ((size (client-size container)) (horz-margin (+ (left-margin-of self) (right-margin-of self))) (vert-margin (+ (top-margin-of self) (bottom-margin-of self))) (new-size (gfs:make-size :width (- (if (> width-hint horz-margin) @@ -64,16 +66,19 @@ vert-margin))) (new-pnt (gfs:make-point :x (left-margin-of self) :y (top-margin-of self))) (bounds (gfs:make-rectangle :size new-size :location new-pnt))) - (mapchildren win (lambda (parent kid) - (declare (ignore parent)) - (cons kid bounds))))) + (mapcar (lambda (item) (cons (first item) bounds)) (data-of self)))) (defmethod perform ((self heap-layout) (container layout-managed) width-hint height-hint) - (let ((top (top-child-of self)) - (kid-specs (compute-layout self container width-hint height-hint))) - (unless top - (setf top (car (first kid-specs)))) - (arrange-children kid-specs (lambda (item) - (if (cffi:pointer-eq (gfs:handle top) (gfs:handle item)) - (logior +window-pos-flags+ gfs::+swp-showwindow+) - (logior +window-pos-flags+ gfs::+swp-hidewindow+)))))) + (if (layout-p container) + (let ((top (top-child-of self)) + (kid-specs (compute-layout self container width-hint height-hint))) + (unless top + (setf top (car (first kid-specs)))) + (arrange-hwnds kid-specs (lambda (item) + (if (eql top item) + (logior +window-pos-flags+ gfs::+swp-showwindow+) + (logior +window-pos-flags+ gfs::+swp-hidewindow+))))))) + +(defmethod (setf top-child-of) :after (child (self heap-layout)) + (unless (typep child 'widget) + (error 'gfs:toolkit-error :detail "top child must be an instance of a widget subclass"))) Modified: trunk/src/uitoolkit/widgets/layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/layout.lisp (original) +++ trunk/src/uitoolkit/widgets/layout.lisp Fri Aug 18 13:18:48 2006 @@ -43,27 +43,34 @@ ;;; helper functions ;;; -(defun layout-attribute (layout widget name) - "Return the value associated with name for widget; or NIL if no value is set." - (if (gfs:disposed-p widget) - (error 'gfs:disposed-error)) - (let ((attrs (assoc (gfs:handle widget) (data-of layout) :test #'cffi:pointer-eq))) - (unless attrs - (error 'gfs:toolkit-error :detail (format nil "~a is not managed ~a" widget layout))) - (getf (first (rest attrs)) name))) - -(defun set-layout-attribute (layout widget name value) - "Sets a value associated with name for widget in the specified layout." - (if (gfs:disposed-p widget) - (error 'gfs:disposed-error)) - (let ((attrs (assoc (gfs:handle widget) (data-of layout) :test #'cffi:pointer-eq))) - (unless attrs - (error 'gfs:toolkit-error :detail (format nil "~a is not managed ~a" widget layout))) - (setf (getf (first (rest attrs)) name) value))) +(defun layout-attribute (layout thing name) + "Return the value associated with name for thing; or NIL if no value is set." + (let ((items (assoc thing (data-of layout)))) + (unless items + (error 'gfs:toolkit-error :detail (format nil "~a is not managed by ~a" thing layout))) + (getf (first (rest items)) name))) + +(defun set-layout-attribute (layout thing name value) + "Sets a value associated with name for thing in the specified layout." + (let ((items (assoc thing (data-of layout)))) + (unless items + (error 'gfs:toolkit-error :detail (format nil "~a is not managed by ~a" thing layout))) + (setf (getf (first (rest items)) name) value))) (defsetf layout-attribute set-layout-attribute) -(defun arrange-children (kid-specs flags-func) +(defun append-layout-item (layout thing) + "Adds thing to layout unless it is already registered." + (setf (data-of layout) (nconc (data-of layout) (list (list thing nil))))) + +(defun delete-layout-item (layout thing) + "Removes thing from layout." + (delete thing (data-of layout) :key #'first)) + +(defun cleanup-disposed-items (layout) + (delete-if #'gfs:disposed-p (data-of layout) :key #'first)) + +(defun arrange-hwnds (kid-specs flags-func) (let ((hdwp (gfs::begin-defer-window-pos (length kid-specs)))) (loop for k in kid-specs for rect = (cdr k) @@ -93,25 +100,37 @@ ;;; methods ;;; -(defmethod initialize-instance :after ((layout layout-manager) +(defmethod initialize-instance :after ((self layout-manager) &key style margins horizontal-margins vertical-margins &allow-other-keys) - (setf (style-of layout) (if (listp style) style (list style))) + (setf (style-of self) (if (listp style) style (list style))) (unless (null margins) - (setf (left-margin-of layout) margins - (right-margin-of layout) margins - (top-margin-of layout) margins - (bottom-margin-of layout) margins)) + (setf (left-margin-of self) margins + (right-margin-of self) margins + (top-margin-of self) margins + (bottom-margin-of self) margins)) (unless (null horizontal-margins) - (setf (left-margin-of layout) horizontal-margins - (right-margin-of layout) horizontal-margins)) + (setf (left-margin-of self) horizontal-margins + (right-margin-of self) horizontal-margins)) (unless (null vertical-margins) - (setf (top-margin-of layout) vertical-margins - (bottom-margin-of layout) vertical-margins))) + (setf (top-margin-of self) vertical-margins + (bottom-margin-of self) vertical-margins))) + +(defmethod (setf layout-of) :after ((self layout-manager) (container layout-managed)) + (let ((orig-layout (layout-of container))) + (if orig-layout + (setf (data-of self) (loop for item in (data-of orig-layout) + when (not (gfs:disposed-p (first item))) + collect item) + (data-of orig-layout) nil) + (if (typep container 'window) + (setf (data-of self) (mapchildren container (lambda (parent child) + (declare (ignore parent)) + (list child nil)))))))) (defmethod perform ((self layout-manager) (container layout-managed) width-hint height-hint) - (when (layout-p container) - (arrange-children (compute-layout self container width-hint height-hint) - (lambda (item) - (declare (ignore item)) - +window-pos-flags+)))) + (if (layout-p container) + (arrange-hwnds (compute-layout self container width-hint height-hint) + (lambda (item) + (declare (ignore item)) + +window-pos-flags+)))) Modified: trunk/src/uitoolkit/widgets/thread-context.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/thread-context.lisp (original) +++ trunk/src/uitoolkit/widgets/thread-context.lisp Fri Aug 18 13:18:48 2006 @@ -40,7 +40,7 @@ (display-visitor-results :initform nil :accessor display-visitor-results) (job-table :initform (make-hash-table :test #'equal)) (job-table-lock :initform nil) - (event-time :initform 0 :accessor event-time) + (event-time :initform 0 :accessor event-time) ; FIXME: GetMessageTime (virtual-key :initform 0 :accessor virtual-key) (menuitems-by-id :initform (make-hash-table :test #'equal)) (mouse-event-pnt :initform (gfs:make-point) :accessor mouse-event-pnt) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Fri Aug 18 13:18:48 2006 @@ -50,11 +50,7 @@ (:documentation "Instances of this class employ a layout manager to organize their children.")) (defclass group (layout-managed) - ((children - :accessor children-of - :initarg :children - :initform nil) - (location + ((location :accessor location-of :initarg :location :initform nil) Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Fri Aug 18 13:18:48 2006 @@ -219,37 +219,37 @@ (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod initialize-instance :after ((w widget) &key style &allow-other-keys) - (setf (slot-value w 'style) (if (listp style) style (list style)))) +(defmethod initialize-instance :after ((self widget) &key style &allow-other-keys) + (setf (slot-value self 'style) (if (listp style) style (list style)))) -(defmethod location :before ((w widget)) - (if (gfs:disposed-p w) +(defmethod location :before ((self widget)) + (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod location ((w widget)) +(defmethod location ((self widget)) (cffi:with-foreign-object (wi-ptr 'gfs::windowinfo) (cffi:with-foreign-slots ((gfs::cbsize gfs::clientleft gfs::clienttop) wi-ptr gfs::windowinfo) (setf gfs::cbsize (cffi::foreign-type-size 'gfs::windowinfo)) - (when (zerop (gfs::get-window-info (gfs:handle w) wi-ptr)) + (when (zerop (gfs::get-window-info (gfs:handle self) wi-ptr)) (error 'gfs:win32-error :detail "get-window-info failed")) (cffi:with-foreign-object (pnt-ptr 'gfs::point) (cffi:with-foreign-slots ((gfs::x gfs::y) pnt-ptr gfs::point) (setf gfs::x gfs::clientleft) (setf gfs::y gfs::clienttop) - (gfs::screen-to-client (gfs:handle w) pnt-ptr) + (gfs::screen-to-client (gfs:handle self) pnt-ptr) (gfs:make-point :x gfs::x :y gfs::y)))))) -(defmethod (setf location) :before ((pnt gfs:point) (w widget)) +(defmethod (setf location) :before ((pnt gfs:point) (self widget)) (declare (ignore pnt)) - (if (gfs:disposed-p w) + (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod (setf location) ((pnt gfs:point) (w widget)) - (if (zerop (gfs::set-window-pos (gfs:handle w) +(defmethod (setf location) ((pnt gfs:point) (self widget)) + (if (zerop (gfs::set-window-pos (gfs:handle self) (cffi:null-pointer) (gfs:point-x pnt) (gfs:point-y pnt) @@ -272,12 +272,12 @@ nil (get-widget (thread-context) hwnd)))) -(defmethod pack :before ((w widget)) - (if (gfs:disposed-p w) +(defmethod pack :before ((self widget)) + (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod pack ((w widget)) - (setf (size w) (preferred-size w -1 -1))) +(defmethod pack ((self widget)) + (setf (size self) (preferred-size self -1 -1))) (defmethod parent ((self widget)) ;; Unlike the owner method, this method should Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Fri Aug 18 13:18:48 2006 @@ -58,7 +58,13 @@ (error 'gfs:win32-error :detail "create-window failed")) (if (find :keyboard-navigation (style-of win)) (put-kbdnav-widget tc win)) - (put-widget tc win)))) + (put-widget tc win)) + ;; FIXME: this is a temporary hack to allow layout management testing; + ;; it breaks in the presence of virtual containers like group + ;; + (let ((parent (parent win))) + (if (and parent (layout-of parent)) + (append-layout-item (layout-of parent) win))))) (defun child-window-visitor (hwnd lparam) (let* ((tc (thread-context))

1 0

[graphic-forms-cvs] r219 - in trunk: docs/manual src/uitoolkit/widgets
by junrue＠common-lisp.net 17 Aug '06

17 Aug '06

Author: junrue Date: Thu Aug 17 18:53:32 2006 New Revision: 219 Modified: trunk/docs/manual/widgets-api.texinfo trunk/src/uitoolkit/widgets/heap-layout.lisp trunk/src/uitoolkit/widgets/layout.lisp Log: refactored gfw:perform implementations Modified: trunk/docs/manual/widgets-api.texinfo ============================================================================== --- trunk/docs/manual/widgets-api.texinfo (original) +++ trunk/docs/manual/widgets-api.texinfo Thu Aug 17 18:53:32 2006 @@ -694,14 +694,16 @@ @node layout types @subsection layout types -@strong{NOTE:} A future release will provide additional layout -manager classes. - @anchor{flow-layout} @deftp Class flow-layout spacing -This @ref{layout-manager} subclass arranges dialog or window children -in a row or column, with optional spacing (specified in pixels) -between children. +This @ref{layout-manager} subclass arranges container children +in a row or column. There are no child-specific layout attributes +defined for this class. +@table @var +@item spacing +A pixel value specifying how far apart each child should be from +the next. +@end table @deffn Initarg :style This initarg accepts a list containing one of the following style keywords: @@ -725,13 +727,15 @@ @anchor{heap-layout} @deftp Class heap-layout top-child This @ref{layout-manager} subclass resizes all children to the same -size and stacks them on top of each other. -@deffn Initarg :top-child +size and stacks them on top of each other. There are no child-specific +layout attributes defined for this class. +@table @var +@item top-child Use this initarg to specify the child widget that should be visible. The corresponding accessor @code{top-child-of} can be set subsequently, followed by calling @ref{layout} on the container, in order to make a different child visible. -@end deffn +@end table @end deftp @anchor{layout-manager} @@ -1741,11 +1745,12 @@ @anchor{layout-attribute} @defun layout-attribute @ref{layout-manager} thing symbol => value (setf (@strong{layout-attribute} @var{layout-manager} @var{thing} @var{symbol}) @var{value})@*@* -This function returns @var{value} if the attribute named by @var{symbol} -is set in @var{layout-manager}; @sc{nil} otherwise. The corresponding -@sc{setf} function allows the attribute to be set. Each layout-manager -subclass supports 0 or more attributes that apply to each @var{thing}. -This function does not restrict application code +Each layout-manager subclass supports 0 or more attributes that apply +to each @var{thing}. This function returns @var{value} if the attribute +named by @var{symbol} is set for @var{thing} in @var{layout-manager}; +it returns @sc{nil} otherwise. The corresponding @sc{setf} function +allows the attribute to be set (note: call @ref{layout} on @var{container} +after doing so). This function does not restrict application code from querying or setting attributes that are not supported by the layout manager. @table @var @@ -1763,22 +1768,22 @@ @end defun @anchor{perform} -@deffn GenericFunction perform @var{layout-manager} container width-hint height-hint -Calls @ref{compute-layout} for @code{container} and then moves and -resizes @code{container}'s children. Layout subclasses may override +@deffn GenericFunction perform @ref{layout-manager} @ref{layout-managed} width-hint height-hint +Calls @ref{compute-layout} for @var{layout-managed} and then moves and +resizes @var{layout-managed}'s children. Subclasses may override this method -- however, most derivations should call @sc{CALL-NEXT-METHOD} to allow the base implementation to execute. @table @var @item layout-manager -The layout object dictating how children of @var{container} +The layout object dictating how children of @var{layout-managed} are to be arranged. @item container -The @var{layout-manager} arranges the elements of @var{container}. +The @var{layout-manager} arranges the elements of @var{layout-managed}. @item width-hint -A hypothetical width value, or negative if @var{container}'s width is +A hypothetical width value, or negative if @var{layout-managed}'s width is not constrained. @item height-hint -A hypothetical height value, or negative if @var{container}'s height is +A hypothetical height value, or negative if @var{layout-managed}'s height is not constrained. @end table @end deffn Modified: trunk/src/uitoolkit/widgets/heap-layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/heap-layout.lisp (original) +++ trunk/src/uitoolkit/widgets/heap-layout.lisp Thu Aug 17 18:53:32 2006 @@ -69,38 +69,11 @@ (cons kid bounds))))) (defmethod perform ((self heap-layout) (container layout-managed) width-hint height-hint) - (let ((kids nil) - (hdwp (cffi:null-pointer)) - (top (top-child-of self))) - (when (layout-p container) - (setf kids (compute-layout self container width-hint height-hint)) - (unless top - (setf top (car (first kids)))) - (setf hdwp (gfs::begin-defer-window-pos (length kids))) - (loop for k in kids - do (let* ((rect (cdr k)) - (sz (gfs:size rect)) - (pnt (gfs:location rect)) - (kid-win (car k)) - (hwnd-after (cffi:null-pointer)) - (flags (logior +window-pos-flags+ gfs::+swp-hidewindow+))) - (when (cffi:pointer-eq (gfs:handle kid-win) (gfs:handle top)) - (setf flags (logior +window-pos-flags+ gfs::+swp-showwindow+))) - (if (gfs:null-handle-p hdwp) - (gfs::set-window-pos (gfs:handle kid-win) - hwnd-after - (gfs:point-x pnt) - (gfs:point-y pnt) - (gfs:size-width sz) - (gfs:size-height sz) - flags) - (setf hdwp (gfs::defer-window-pos hdwp - (gfs:handle kid-win) - hwnd-after - (gfs:point-x pnt) - (gfs:point-y pnt) - (gfs:size-width sz) - (gfs:size-height sz) - flags))))) - (unless (gfs:null-handle-p hdwp) - (gfs::end-defer-window-pos hdwp))))) + (let ((top (top-child-of self)) + (kid-specs (compute-layout self container width-hint height-hint))) + (unless top + (setf top (car (first kid-specs)))) + (arrange-children kid-specs (lambda (item) + (if (cffi:pointer-eq (gfs:handle top) (gfs:handle item)) + (logior +window-pos-flags+ gfs::+swp-showwindow+) + (logior +window-pos-flags+ gfs::+swp-hidewindow+)))))) Modified: trunk/src/uitoolkit/widgets/layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/layout.lisp (original) +++ trunk/src/uitoolkit/widgets/layout.lisp Thu Aug 17 18:53:32 2006 @@ -63,6 +63,32 @@ (defsetf layout-attribute set-layout-attribute) +(defun arrange-children (kid-specs flags-func) + (let ((hdwp (gfs::begin-defer-window-pos (length kid-specs)))) + (loop for k in kid-specs + for rect = (cdr k) + for size = (gfs:size rect) + for pnt = (gfs:location rect) + do (progn + (if (gfs:null-handle-p hdwp) + (gfs::set-window-pos (gfs:handle (car k)) + (cffi:null-pointer) + (gfs:point-x pnt) + (gfs:point-y pnt) + (gfs:size-width size) + (gfs:size-height size) + (funcall flags-func (car k))) + (gfs::defer-window-pos hdwp + (gfs:handle (car k)) + (cffi:null-pointer) + (gfs:point-x pnt) + (gfs:point-y pnt) + (gfs:size-width size) + (gfs:size-height size) + (funcall flags-func (car k)))))) + (unless (gfs:null-handle-p hdwp) + (gfs::end-defer-window-pos hdwp)))) + ;;; ;;; methods ;;; @@ -84,31 +110,8 @@ (bottom-margin-of layout) vertical-margins))) (defmethod perform ((self layout-manager) (container layout-managed) width-hint height-hint) - "Calls compute-layout for a container and then handles the actual moving and resizing of its children." - (let ((kids nil) - (hdwp (cffi:null-pointer))) - (when (layout-p container) - (setf kids (compute-layout self container width-hint height-hint)) - (setf hdwp (gfs::begin-defer-window-pos (length kids))) - (loop for k in kids - do (let* ((rect (cdr k)) - (sz (gfs:size rect)) - (pnt (gfs:location rect))) - (if (gfs:null-handle-p hdwp) - (gfs::set-window-pos (gfs:handle (car k)) - (cffi:null-pointer) - (gfs:point-x pnt) - (gfs:point-y pnt) - (gfs:size-width sz) - (gfs:size-height sz) - +window-pos-flags+) - (setf hdwp (gfs::defer-window-pos hdwp - (gfs:handle (car k)) - (cffi:null-pointer) - (gfs:point-x pnt) - (gfs:point-y pnt) - (gfs:size-width sz) - (gfs:size-height sz) - +window-pos-flags+))))) - (unless (gfs:null-handle-p hdwp) - (gfs::end-defer-window-pos hdwp))))) + (when (layout-p container) + (arrange-children (compute-layout self container width-hint height-hint) + (lambda (item) + (declare (ignore item)) + +window-pos-flags+))))

1 0

[graphic-forms-cvs] r218 - in trunk: docs/manual src src/tests/uitoolkit src/uitoolkit/graphics/plugins/default src/uitoolkit/widgets
by junrue＠common-lisp.net 17 Aug '06

17 Aug '06

Author: junrue Date: Thu Aug 17 17:55:50 2006 New Revision: 218 Modified: trunk/docs/manual/graphics-api.texinfo trunk/docs/manual/widgets-api.texinfo trunk/src/packages.lisp trunk/src/tests/uitoolkit/layout-unit-tests.lisp trunk/src/tests/uitoolkit/mock-objects.lisp trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp trunk/src/uitoolkit/widgets/layout-classes.lisp trunk/src/uitoolkit/widgets/layout-generics.lisp trunk/src/uitoolkit/widgets/layout.lisp Log: implemented and documented gfw:layout-attribute function Modified: trunk/docs/manual/graphics-api.texinfo ============================================================================== --- trunk/docs/manual/graphics-api.texinfo (original) +++ trunk/docs/manual/graphics-api.texinfo Thu Aug 17 17:55:50 2006 @@ -551,8 +551,12 @@ @item :large Identifies the largest image of the @var{icon-bundle}. @item :small -Identifies the smallest image of the @var{icon-bundle}. +Identifies the smallest image of the @var{icon-bundle}.@*@* @end table +@strong{Note:} there are actually four icon sizes that Windows +defines for various contexts. A future release will add keywords to +better distinguish amongst all four, and to help ensure the correct +sizes are chosen when an icon-bundle is passed to @sc{(setf gfw:image)}. @end table To find out how many images are stored in @var{icon-bundle}, and hence what constitutes a valid range of subscripts for this function, Modified: trunk/docs/manual/widgets-api.texinfo ============================================================================== --- trunk/docs/manual/widgets-api.texinfo (original) +++ trunk/docs/manual/widgets-api.texinfo Thu Aug 17 17:55:50 2006 @@ -735,12 +735,28 @@ @end deftp @anchor{layout-manager} -@deftp Class layout-manager style left-margin top-margin right-margin bottom-margin -Subclasses implement layout strategies on behalf of window -objects. Every layout manager allows optional margins (specified in -pixels) within the perimeter of the container being managed.@*@* The -values accepted by the @code{:style} initarg vary depending on the -actual @code{layout-manager} subclass being used. +@deftp Class layout-manager bottom-margin data left-margin right-margin top-margin style +Subclasses implement layout strategies to manage space within containers. +@table @var +@item bottom-margin +This slot holds a margin value in pixels for the bottom side of +the container. +@item data +This slot holds a @sc{alist} of pairs, each one associating a +@sc{plist} of layout-specific attributes with an item from a +container. +@item left-margin +This slot holds a margin value in pixels for the left side of +the container. +@item right-margin +This slot holds a margin value in pixels for the right side of +the container. +@item style +The values appropriate for this slot are subclass-specific. +@item top-margin +This slot holds a margin value in pixels for the top side of +the container. +@end table @deffn Initarg :horizontal-margins This initarg accepts a horizontal margin value that is applied to both the left and right sides of the container. @@ -1665,40 +1681,104 @@ @node layout functions @subsection layout functions -These functions comprise the protocol for @ref{layout-manager}s. As -such, they are not normally called by application code, but instead -are the concern of layout-manager implementers. - -The @code{width-hint} and @code{height-hint} parameters are a -mechanism to express the @emph{what-if} scenario where the total width -or height of the container is fixed; the proper response is to -calculate the container's desired dimension on the opposite -axis. While this behavior is primarily the concern of child windows -and/or controls, layout manager implementations should look for -non-negative values for either @code{width-hint} or -@code{height-hint}, indicating that the container's size is -constrained. +The functions @ref{compute-layout}, @ref{compute-size}, and +@ref{perform} comprise the internal protocol for +@ref{layout-manager}s. As such, they are not normally called by +application code, being instead the concern of layout-manager +implementations. The @var{width-hint} and @var{height-hint} parameters +passed to the following functions are a mechanism to express the +@emph{what-if} scenario where the total width or height of the +container is fixed; the proper response is to calculate the +container's desired dimension on the opposite axis. While this +behavior is primarily the concern of child windows and/or controls, +layout manager implementations should look for non-negative values for +either @var{width-hint} or @var{height-hint}, indicating that the +container's size is constrained. @anchor{compute-layout} -@deffn GenericFunction compute-layout layout container width-hint height-hint -Returns a list of conses @code{(child . rectangle)} describing the -new bounds of each child window or control. A @ref{layout-manager} subclass +@deffn GenericFunction compute-layout @ref{layout-manager} container width-hint height-hint +Returns a list of pairs @code{(item rectangle)} describing the +new bounds of each child within @var{container}. A layout-manager subclass implements this method based on its particular layout strategy, taking -into account attributes set by the user. Certain Graphic-Forms functions -call this method to accomplish layout within a container. +into account attributes set by the user via @ref{layout-attribute}. Certain +Graphic-Forms functions call this method to accomplish layout within a container. +@table @var +@item layout-manager +The layout object dictating how children of @var{container} +are to be arranged. +@item container +The @var{layout-manager} arranges the elements of @var{container}. +@item width-hint +A hypothetical width value, or negative if @var{container}'s width is +not constrained. +@item height-hint +A hypothetical height value, or negative if @var{container}'s height is +not constrained. +@end table @end deffn -@deffn GenericFunction compute-size layout container width-hint height-hint +@anchor{compute-size} +@deffn GenericFunction compute-size @ref{layout-manager} container width-hint height-hint Computes and returns the new @ref{size} of the @code{container}'s -client area. A @ref{layout-manager} subclass implements this method +client area. A layout-manager subclass implements this method based on its particular layout strategy, taking into account -attributes set by the user. The @ref{pack} function ultimately calls -this method. +attributes set by the user via @ref{layout-attribute}. +@table @var +@item layout-manager +The layout object dictating how children of @var{container} +are to be arranged. +@item container +The @var{layout-manager} arranges the elements of @var{container}. +@item width-hint +A hypothetical width value, or negative if @var{container}'s width is +not constrained. +@item height-hint +A hypothetical height value, or negative if @var{container}'s height is +not constrained. +@end table @end deffn -@deffn GenericFunction perform layout container width-hint height-hint +@anchor{layout-attribute} +@defun layout-attribute @ref{layout-manager} thing symbol => value +(setf (@strong{layout-attribute} @var{layout-manager} @var{thing} @var{symbol}) @var{value})@*@* +This function returns @var{value} if the attribute named by @var{symbol} +is set in @var{layout-manager}; @sc{nil} otherwise. The corresponding +@sc{setf} function allows the attribute to be set. Each layout-manager +subclass supports 0 or more attributes that apply to each @var{thing}. +This function does not restrict application code +from querying or setting attributes that are not supported by the +layout manager. +@table @var +@item layout-manager +The layout object dictating how children of @var{container} +are to be arranged. +@item thing +The object being managed by @var{layout-manager}. +@item symbol +A @sc{symbol} identifying an item-specific attribute supported +by @var{layout-manager}. +@item value +The data of an attribute which configures the behavior of @var{layout-manager}. +@end table +@end defun + +@anchor{perform} +@deffn GenericFunction perform @var{layout-manager} container width-hint height-hint Calls @ref{compute-layout} for @code{container} and then moves and resizes @code{container}'s children. Layout subclasses may override -this method -- most derivations should call @sc{CALL-NEXT-METHOD} to -allow the base implementation to execute. +this method -- however, most derivations should call @sc{CALL-NEXT-METHOD} +to allow the base implementation to execute. +@table @var +@item layout-manager +The layout object dictating how children of @var{container} +are to be arranged. +@item container +The @var{layout-manager} arranges the elements of @var{container}. +@item width-hint +A hypothetical width value, or negative if @var{container}'s width is +not constrained. +@item height-hint +A hypothetical height value, or negative if @var{container}'s height is +not constrained. +@end table @end deffn Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Thu Aug 17 17:55:50 2006 @@ -440,6 +440,7 @@ #:key-toggled-p #:label #:layout + #:layout-attribute #:layout-of #:layout-p #:left-margin-of 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 Thu Aug 17 17:55:50 2006 @@ -54,6 +54,25 @@ expected-rects actual-rects))) +(define-test layout-attributes-test + (let ((widget1 (make-instance 'mock-widget :handle 1234)) + (widget2 (make-instance 'mock-widget :handle 5678))) + (let ((data1 `(,(cffi:make-pointer 1234) (a 1 b 2))) + (data2 `(,(cffi:make-pointer 5678) (a 10 c 30))) + (layout (make-instance 'gfw:layout-manager))) + (setf (slot-value layout 'gfw::data) (list data1 data2)) + (assert-equal 1 (gfw:layout-attribute layout widget1 'a)) + (assert-equal 2 (gfw:layout-attribute layout widget1 'b)) + (assert-equal 10 (gfw:layout-attribute layout widget2 'a)) + (assert-equal 30 (gfw:layout-attribute layout widget2 'c)) + (setf (gfw:layout-attribute layout widget1 'b) 66 + (gfw:layout-attribute layout widget2 'd) 100) + (assert-equal 1 (gfw:layout-attribute layout widget1 'a)) + (assert-equal 66 (gfw:layout-attribute layout widget1 'b)) + (assert-equal 10 (gfw:layout-attribute layout widget2 'a)) + (assert-equal 30 (gfw:layout-attribute layout widget2 'c)) + (assert-equal 100 (gfw:layout-attribute layout widget2 'd))))) + (define-test flow-layout-test1 ;; orient: horizontal ;; normalize: disabled Modified: trunk/src/tests/uitoolkit/mock-objects.lisp ============================================================================== --- trunk/src/tests/uitoolkit/mock-objects.lisp (original) +++ trunk/src/tests/uitoolkit/mock-objects.lisp Thu Aug 17 17:55:50 2006 @@ -57,8 +57,8 @@ :initarg :min-size :initform (gfs:make-size)))) -(defmethod initialize-instance :after ((widget mock-widget) &key) - (setf (slot-value widget 'gfs:handle) (cffi:make-pointer #xFFFFFFFF))) +(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 gfw:location ((widget mock-widget)) (gfs:make-point)) Modified: trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp (original) +++ trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp Thu Aug 17 17:55:50 2006 @@ -104,7 +104,7 @@ (load-bmp-data stream t t))))) (defun loader (path) - (let* ((file-type (string-downcase (pathname-type path))) + (let* ((file-type (pathname-type path)) (helper (cond ((string-equal file-type "bmp") #'load-bmp-data) ((string-equal file-type "ico") #'load-icon-data) Modified: trunk/src/uitoolkit/widgets/layout-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/layout-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/layout-classes.lisp Thu Aug 17 17:55:50 2006 @@ -53,8 +53,11 @@ (bottom-margin :accessor bottom-margin-of :initarg :bottom-margin - :initform 0)) - (:documentation "Subclasses implement layout strategies on behalf of window objects.")) + :initform 0) + (data + :accessor data-of + :initform nil)) + (:documentation "Subclasses implement layout strategies to manage space within windows.")) (defclass flow-layout (layout-manager) ((spacing Modified: trunk/src/uitoolkit/widgets/layout-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/layout-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/layout-generics.lisp Thu Aug 17 17:55:50 2006 @@ -33,11 +33,16 @@ (in-package :graphic-forms.uitoolkit.widgets) -(defgeneric compute-size (layout win width-hint height-hint) +(defgeneric compute-size (self win width-hint height-hint) (:documentation "Computes and returns the size of the window's client area based on the layout's strategy.")) -(defgeneric compute-layout (layout win width-hint height-hint) +(defgeneric compute-layout (self win width-hint height-hint) (:documentation "Returns a list of conses (window . rectangle) describing the new bounds of each child window.")) -(defgeneric perform (layout window widget-hint height-hint) +(defgeneric obtain-default (self) + (:documentation "Returns an instance representing default values to be used when none is supplied by the application.") + (:method (self) + (declare (ignorable self)))) + +(defgeneric perform (self window widget-hint height-hint) (:documentation "Moves and resizes window children based on layout strategy.")) Modified: trunk/src/uitoolkit/widgets/layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/layout.lisp (original) +++ trunk/src/uitoolkit/widgets/layout.lisp Thu Aug 17 17:55:50 2006 @@ -40,6 +40,30 @@ gfs::+swp-nocopybits+))) ;;; +;;; helper functions +;;; + +(defun layout-attribute (layout widget name) + "Return the value associated with name for widget; or NIL if no value is set." + (if (gfs:disposed-p widget) + (error 'gfs:disposed-error)) + (let ((attrs (assoc (gfs:handle widget) (data-of layout) :test #'cffi:pointer-eq))) + (unless attrs + (error 'gfs:toolkit-error :detail (format nil "~a is not managed ~a" widget layout))) + (getf (first (rest attrs)) name))) + +(defun set-layout-attribute (layout widget name value) + "Sets a value associated with name for widget in the specified layout." + (if (gfs:disposed-p widget) + (error 'gfs:disposed-error)) + (let ((attrs (assoc (gfs:handle widget) (data-of layout) :test #'cffi:pointer-eq))) + (unless attrs + (error 'gfs:toolkit-error :detail (format nil "~a is not managed ~a" widget layout))) + (setf (getf (first (rest attrs)) name) value))) + +(defsetf layout-attribute set-layout-attribute) + +;;; ;;; methods ;;; @@ -48,16 +72,16 @@ &allow-other-keys) (setf (style-of layout) (if (listp style) style (list style))) (unless (null margins) - (setf (left-margin-of layout) margins) - (setf (right-margin-of layout) margins) - (setf (top-margin-of layout) margins) - (setf (bottom-margin-of layout) margins)) + (setf (left-margin-of layout) margins + (right-margin-of layout) margins + (top-margin-of layout) margins + (bottom-margin-of layout) margins)) (unless (null horizontal-margins) - (setf (left-margin-of layout) horizontal-margins) - (setf (right-margin-of layout) horizontal-margins)) + (setf (left-margin-of layout) horizontal-margins + (right-margin-of layout) horizontal-margins)) (unless (null vertical-margins) - (setf (top-margin-of layout) vertical-margins) - (setf (bottom-margin-of layout) vertical-margins))) + (setf (top-margin-of layout) vertical-margins + (bottom-margin-of layout) vertical-margins))) (defmethod perform ((self layout-manager) (container layout-managed) width-hint height-hint) "Calls compute-layout for a container and then handles the actual moving and resizing of its children."

1 0

[graphic-forms-cvs] r217 - in trunk/src/uitoolkit/graphics/plugins: default imagemagick
by junrue＠common-lisp.net 14 Aug '06

14 Aug '06

Author: junrue Date: Sun Aug 13 23:15:27 2006 New Revision: 217 Modified: trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp Log: fixed graphics plugin lookup by extension to be case-insensitive Modified: trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp (original) +++ trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp Sun Aug 13 23:15:27 2006 @@ -104,7 +104,7 @@ (load-bmp-data stream t t))))) (defun loader (path) - (let* ((file-type (pathname-type path)) + (let* ((file-type (string-downcase (pathname-type path))) (helper (cond ((string-equal file-type "bmp") #'load-bmp-data) ((string-equal file-type "ico") #'load-icon-data) Modified: trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp (original) +++ trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp Sun Aug 13 23:15:27 2006 @@ -40,7 +40,7 @@ (unless *magick-initialized* (initialize-magick (cffi:null-pointer)) (setf *magick-initialized* t)) - (if (gethash (pathname-type path) gfg:*image-file-types*) + (if (gethash (string-downcase (pathname-type path)) gfg:*image-file-types*) (with-image-path ((if (typep path 'pathname) (namestring path) path) info ex) (let ((images-ptr (read-image info ex))) (if (not (eql (cffi:foreign-slot-value ex 'exception-info 'severity) :undefined))

1 0

[graphic-forms-cvs] r216 - in trunk/src: tests/uitoolkit uitoolkit/graphics/plugins/default
by junrue＠common-lisp.net 14 Aug '06

14 Aug '06

Author: junrue Date: Sun Aug 13 23:07:35 2006 New Revision: 216 Modified: trunk/src/tests/uitoolkit/drawing-tester.lisp trunk/src/tests/uitoolkit/event-tester.lisp trunk/src/tests/uitoolkit/image-tester.lisp trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/tests/uitoolkit/windlg.lisp trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp Log: implemented icon file loading in default graphics plugin Modified: trunk/src/tests/uitoolkit/drawing-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/drawing-tester.lisp (original) +++ trunk/src/tests/uitoolkit/drawing-tester.lisp Sun Aug 13 23:07:35 2006 @@ -362,7 +362,6 @@ (setf (gfw:menu-bar *drawing-win*) menubar) (setf (gfw:size *drawing-win*) (gfs:make-size :width 390 :height 310)) (setf (gfw:text *drawing-win*) "Drawing Tester") -#+load-imagemagick-plugin (setf (gfw:image *drawing-win*) (make-instance 'gfg:icon-bundle :file (merge-pathnames "default.ico"))) (gfw:show *drawing-win* t))) Modified: trunk/src/tests/uitoolkit/event-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/event-tester.lisp (original) +++ trunk/src/tests/uitoolkit/event-tester.lisp Sun Aug 13 23:07:35 2006 @@ -253,6 +253,7 @@ (:item "&Help" :dispatcher echo-md :submenu ((:item "&About" :dispatcher echo-md)))))) (setf (gfw:menu-bar *event-tester-window*) menubar) + (setf (gfw:image *event-tester-window*) (make-instance 'gfg:icon-bundle :file (merge-pathnames "default.ico"))) (gfw:show *event-tester-window* t))) (defun event-tester () Modified: trunk/src/tests/uitoolkit/image-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/image-tester.lisp (original) +++ trunk/src/tests/uitoolkit/image-tester.lisp Sun Aug 13 23:07:35 2006 @@ -109,6 +109,7 @@ (setf menubar (gfw:defmenu ((:item "&File" :submenu ((:item "E&xit" :callback #'exit-image-fn)))))) (setf (gfw:menu-bar *image-win*) menubar) + (setf (gfw:image *image-win*) (make-instance 'gfg:icon-bundle :file (merge-pathnames "default.ico"))) (gfw:show *image-win* t))) (defun image-tester () Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Sun Aug 13 23:07:35 2006 @@ -441,6 +441,7 @@ (dotimes (i 3) (add-layout-tester-widget 'gfw:button :push-button)) (setf (gfw:text *layout-tester-win*) "Layout Tester") + (setf (gfw:image *layout-tester-win*) (make-instance 'gfg:icon-bundle :file (merge-pathnames "default.ico"))) (gfw:pack *layout-tester-win*) (gfw:show *layout-tester-win* t))) Modified: trunk/src/tests/uitoolkit/windlg.lisp ============================================================================== --- trunk/src/tests/uitoolkit/windlg.lisp (original) +++ trunk/src/tests/uitoolkit/windlg.lisp Sun Aug 13 23:07:35 2006 @@ -246,6 +246,7 @@ (:item "&Mini Frame" :callback #'create-miniframe-win) (:item "&Palette" :callback #'create-palette-win)))))) (setf (gfw:menu-bar *main-win*) menubar) + (setf (gfw:image *main-win*) (make-instance 'gfg:icon-bundle :file (merge-pathnames "default.ico"))) (gfw:show *main-win* t))) (defun windlg () Modified: trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp (original) +++ trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp Sun Aug 13 23:07:35 2006 @@ -45,13 +45,15 @@ (defmacro bitmap-pixel-row-length (width bit-count) `(ash (logand (+ (* ,width ,bit-count) 31) (lognot 31)) -3)) -(defun load-bmp-data (stream) - (let* ((header (read-value 'BITMAPFILEHEADER stream)) - (info (read-value 'BASE-BITMAPINFOHEADER stream)) +(defun load-bmp-data (stream &optional no-header-p half-height-p) + (unless no-header-p + (read-value 'BITMAPFILEHEADER stream)) + (let* ((info (read-value 'BASE-BITMAPINFOHEADER stream)) (data (make-instance 'default-data-plugin :handle info))) - (declare (ignore header)) (unless (= (biCompression info) gfs::+bi-rgb+) (error 'gfs:toolkit-error :detail "FIXME: non-RGB not yet implemented")) + (if half-height-p + (setf (biHeight info) (/ (biHeight info) 2))) ;; load color table ;; @@ -93,7 +95,13 @@ (list data))) (defun load-icon-data (stream) - (declare (ignore stream))) + (let ((offsets (loop for i upto (1- (idCount (read-value 'ICONDIR stream))) + for entry = (read-value 'ICONDIRENTRY stream) + collect (ideImageOffset entry)))) + (loop for offset in offsets + append (progn + (file-position stream offset) + (load-bmp-data stream t t))))) (defun loader (path) (let* ((file-type (pathname-type path))

1 0

[graphic-forms-cvs] r215 - in trunk: . docs/manual src/tests/uitoolkit src/uitoolkit/graphics src/uitoolkit/graphics/plugins/imagemagick src/uitoolkit/system src/uitoolkit/widgets
by junrue＠common-lisp.net 14 Aug '06

14 Aug '06

Author: junrue Date: Sun Aug 13 22:04:18 2006 New Revision: 215 Modified: trunk/README.txt trunk/docs/manual/widgets-api.texinfo trunk/graphic-forms-tests.asd trunk/src/tests/uitoolkit/default.ico trunk/src/tests/uitoolkit/drawing-tester.lisp trunk/src/tests/uitoolkit/event-tester.lisp trunk/src/tests/uitoolkit/hello-world.lisp trunk/src/tests/uitoolkit/image-tester.lisp trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/tests/uitoolkit/windlg.lisp trunk/src/uitoolkit/graphics/icon-bundle.lisp trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-core-api.lisp trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/widgets/widget.lisp trunk/src/uitoolkit/widgets/window.lisp Log: fixed problems in multiple-image icon bundles and in the ImageMagick plugin Modified: trunk/README.txt ============================================================================== --- trunk/README.txt (original) +++ trunk/README.txt Sun Aug 13 22:04:18 2006 @@ -157,21 +157,26 @@ (asdf:operate 'asdf:load-op :graphic-forms-tests) - ;; execute one or more of the following: + ;; execute demos and test programs ;; + (gft:unblocked) - (in-package :gft) - (run-tests) ;; runs the unit tests (many more to be added) + (gft:textedit) + + (gft:drawing-tester) - (gft::run-drawing-tester) + (gft:event-tester) - (gft::run-event-tester) + (gft:image-tester) - (gft::run-image-tester) + (gft:layout-tester) - (gft::run-windlg) + (gft:windlg) - (gft::run-layout-tester) + ;; execute the unit-tests + ;; + (in-package :gft) + (run-tests) Support and Feedback Modified: trunk/docs/manual/widgets-api.texinfo ============================================================================== --- trunk/docs/manual/widgets-api.texinfo (original) +++ trunk/docs/manual/widgets-api.texinfo Sun Aug 13 22:04:18 2006 @@ -1333,6 +1333,16 @@ scrollbar; @sc{nil} otherwise. @xref{enable-scrollbars}. @end deffn +@deffn GenericFunction image self => @ref{image} + +(setf (@strong{image} @var{self}) @var{image})@* + +Returns the image currently associated with @var{self}. The @sc{setf} function +changes the image. If @var{self} is a @ref{window}, then this function returns +an @ref{icon-bundle}. And in that case, the @sc{setf} function accepts either +an image or an icon-bundle. +@end deffn + @deffn GenericFunction item-index self item Return the zero-based index of the location of the other object in this object. @end deffn Modified: trunk/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Sun Aug 13 22:04:18 2006 @@ -37,14 +37,14 @@ (:nicknames #:gft) (:use :common-lisp :lisp-unit) (:export - #:run-drawing-tester - #:run-event-tester - #:run-hello-world - #:run-image-tester - #:run-layout-tester - #:run-windlg + #:drawing-tester + #:event-tester + #:hello-world + #:image-tester + #:layout-tester #:textedit - #:unblocked)) + #:unblocked + #:windlg)) (print "Graphic-Forms UI Toolkit Tests") (print "Copyright (c) 2006 by Jack D. Unrue") Modified: trunk/src/tests/uitoolkit/default.ico ============================================================================== Binary files. No diff available. Modified: trunk/src/tests/uitoolkit/drawing-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/drawing-tester.lisp (original) +++ trunk/src/tests/uitoolkit/drawing-tester.lisp Sun Aug 13 22:04:18 2006 @@ -342,7 +342,7 @@ (setf (draw-func-of *drawing-dispatcher*) #'draw-wedges) (gfw:redraw *drawing-win*)) -(defun run-drawing-tester-internal () +(defun drawing-tester-internal () (setf *last-checked-drawing-item* nil) (let ((menubar (gfw:defmenu ((:item "&File" :submenu ((:item "E&xit" :callback #'drawing-exit-fn))) @@ -362,7 +362,9 @@ (setf (gfw:menu-bar *drawing-win*) menubar) (setf (gfw:size *drawing-win*) (gfs:make-size :width 390 :height 310)) (setf (gfw:text *drawing-win*) "Drawing Tester") +#+load-imagemagick-plugin + (setf (gfw:image *drawing-win*) (make-instance 'gfg:icon-bundle :file (merge-pathnames "default.ico"))) (gfw:show *drawing-win* t))) -(defun run-drawing-tester () - (gfw:startup "Drawing Tester" #'run-drawing-tester-internal)) +(defun drawing-tester () + (gfw:startup "Drawing Tester" #'drawing-tester-internal)) Modified: trunk/src/tests/uitoolkit/event-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/event-tester.lisp (original) +++ trunk/src/tests/uitoolkit/event-tester.lisp Sun Aug 13 22:04:18 2006 @@ -233,7 +233,7 @@ (gfw:delay-of *timer*))))) (gfw:redraw *event-tester-window*)) -(defun run-event-tester-internal () +(defun event-tester-internal () (setf *event-tester-text* "Hello!") (setf *event-counter* 0) (let ((echo-md (make-instance 'event-tester-echo-dispatcher)) @@ -255,5 +255,5 @@ (setf (gfw:menu-bar *event-tester-window*) menubar) (gfw:show *event-tester-window* t))) -(defun run-event-tester () - (gfw:startup "Event Tester" #'run-event-tester-internal)) +(defun event-tester () + (gfw:startup "Event Tester" #'event-tester-internal)) Modified: trunk/src/tests/uitoolkit/hello-world.lisp ============================================================================== --- trunk/src/tests/uitoolkit/hello-world.lisp (original) +++ trunk/src/tests/uitoolkit/hello-world.lisp Sun Aug 13 22:04:18 2006 @@ -56,7 +56,7 @@ (setf (gfg:foreground-color gc) gfg:*color-green*) (gfg:draw-text gc "Hello World!" (gfs:make-point))) -(defun run-hello-world-internal () +(defun hello-world-internal () (let ((menubar nil)) (setf *hello-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'hellowin-events) :style '(:frame))) @@ -65,5 +65,5 @@ (setf (gfw:menu-bar *hello-win*) menubar) (gfw:show *hello-win* t))) -(defun run-hello-world () - (gfw:startup "Hello World" #'run-hello-world-internal)) +(defun hello-world () + (gfw:startup "Hello World" #'hello-world-internal)) Modified: trunk/src/tests/uitoolkit/image-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/image-tester.lisp (original) +++ trunk/src/tests/uitoolkit/image-tester.lisp Sun Aug 13 22:04:18 2006 @@ -93,7 +93,7 @@ (setf *image-win* nil) (gfw:shutdown 0)) -(defun run-image-tester-internal () +(defun image-tester-internal () (setf *default-pathname-defaults* (parse-namestring gfsys::*gf-tests-dir*)) (let ((menubar nil)) (setf *happy-image* (make-instance 'gfg:image)) @@ -111,5 +111,5 @@ (setf (gfw:menu-bar *image-win*) menubar) (gfw:show *image-win* t))) -(defun run-image-tester () - (gfw:startup "Image Tester" #'run-image-tester-internal)) +(defun image-tester () + (gfw:startup "Image Tester" #'image-tester-internal)) Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Sun Aug 13 22:04:18 2006 @@ -387,7 +387,7 @@ (declare (ignorable disp item)) (exit-layout-tester)) -(defun run-layout-tester-internal () +(defun layout-tester-internal () (setf *default-pathname-defaults* (parse-namestring gfsys::*gf-tests-dir*)) (setf *widget-counter* 0) (let ((menubar nil) @@ -444,5 +444,5 @@ (gfw:pack *layout-tester-win*) (gfw:show *layout-tester-win* t))) -(defun run-layout-tester () - (gfw:startup "Layout Tester" #'run-layout-tester-internal)) +(defun layout-tester () + (gfw:startup "Layout Tester" #'layout-tester-internal)) Modified: trunk/src/tests/uitoolkit/windlg.lisp ============================================================================== --- trunk/src/tests/uitoolkit/windlg.lisp (original) +++ trunk/src/tests/uitoolkit/windlg.lisp Sun Aug 13 22:04:18 2006 @@ -228,7 +228,7 @@ (declare (ignore disp item)) (open-dlg "Modeless" '(:modeless))) -(defun run-windlg-internal () +(defun windlg-internal () (let ((menubar nil)) (setf *main-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'main-win-events) :style '(:workspace))) @@ -248,5 +248,5 @@ (setf (gfw:menu-bar *main-win*) menubar) (gfw:show *main-win* t))) -(defun run-windlg () - (gfw:startup "Window/Dialog Tester" #'run-windlg-internal)) +(defun windlg () + (gfw:startup "Window/Dialog Tester" #'windlg-internal)) Modified: trunk/src/uitoolkit/graphics/icon-bundle.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/icon-bundle.lisp (original) +++ trunk/src/uitoolkit/graphics/icon-bundle.lisp Sun Aug 13 22:04:18 2006 @@ -164,7 +164,9 @@ (resource-id (setf (slot-value self 'gfs:handle) (gfs::load-icon (cffi:null-pointer) resource-id))) ((typep file 'pathname) - (setf image-list (list (make-instance 'image :file file)))) + (let ((data (load-image-data file))) + (setf image-list (loop for entry in data + collect (make-instance 'gfg:image :handle (data->image entry)))))) ((listp images) (setf image-list images))) (when image-list Modified: trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-core-api.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-core-api.lisp (original) +++ trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-core-api.lisp Sun Aug 13 22:04:18 2006 @@ -149,6 +149,11 @@ (images :pointer)) ;; Image* (defcfun + ("GetImageListLength" get-image-list-length) + :unsigned-long + (images :pointer)) ;; Image* + +(defcfun ("GetNextImageInList" get-next-image-in-list) :pointer ;; Image* (images :pointer)) ;; Image* Modified: trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp (original) +++ trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp Sun Aug 13 22:04:18 2006 @@ -41,15 +41,15 @@ (initialize-magick (cffi:null-pointer)) (setf *magick-initialized* t)) (if (gethash (pathname-type path) gfg:*image-file-types*) - (with-image-path (path info ex) + (with-image-path ((if (typep path 'pathname) (namestring path) path) info ex) (let ((images-ptr (read-image info ex))) (if (not (eql (cffi:foreign-slot-value ex 'exception-info 'severity) :undefined)) (error 'gfs:toolkit-error :detail (format nil "exception reason: ~s" (cffi:foreign-slot-value ex 'exception-info 'reason)))) - (loop for ptr = (get-next-image-in-list images-ptr) - until (cffi:null-pointer-p ptr) - collect (make-instance 'magic-data-plugin :handle ptr)))) + (loop for ptr = images-ptr then (get-next-image-in-list ptr) + while (and ptr (not (gfs:null-handle-p ptr))) + collect (make-instance 'magick-data-plugin :handle ptr)))) nil)) (push #'loader gfg::*image-plugins*) Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Sun Aug 13 22:04:18 2006 @@ -480,6 +480,10 @@ (defconstant +icc-standard-classes+ #x00004000) (defconstant +icc-link-class+ #x00008000) +(defconstant +icon-small+ 0) +(defconstant +icon-big+ 1) +(defconstant +icon-small2+ 2) + (defconstant +idok+ 1) (defconstant +idcancel+ 2) (defconstant +idabort+ 3) @@ -1004,6 +1008,12 @@ (defconstant +wm-chartoitem+ #x002F) (defconstant +wm-setfont+ #x0030) (defconstant +wm-getfont+ #x0031) +(defconstant +wm-contextmenu+ #x007B) +(defconstant +wm-stylechanging+ #x007C) +(defconstant +wm-stylechanged+ #x007D) +(defconstant +wm-displaychange+ #x007E) +(defconstant +wm-geticon+ #x007F) +(defconstant +wm-seticon+ #x0080) (defconstant +wm-ncmousemove+ #x00A0) (defconstant +wm-nclbuttondown+ #x00A1) (defconstant +wm-nclbuttonup+ #x00A2) Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Sun Aug 13 22:04:18 2006 @@ -210,6 +210,15 @@ (defmethod enabled-p ((w widget)) (not (zerop (gfs::is-window-enabled (gfs:handle w))))) +(defmethod image :before ((self widget)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + +(defmethod (setf image) :before (image (self widget)) + (declare (ignore image)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + (defmethod initialize-instance :after ((w widget) &key style &allow-other-keys) (setf (slot-value w 'style) (if (listp style) style (list style)))) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Sun Aug 13 22:04:18 2006 @@ -165,43 +165,65 @@ (delete-kbdnav-widget (thread-context) self) (call-next-method)) -(defmethod enable-layout :before ((win window) flag) +(defmethod enable-layout :before ((self window) flag) (declare (ignore flag)) - (if (gfs:disposed-p win) + (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod enable-layout ((win window) flag) - (setf (slot-value win 'layout-p) flag) - (if (and flag (layout-of win)) - (let ((sz (client-size win))) - (perform (layout-of win) win (gfs:size-width sz) (gfs:size-height sz))))) +(defmethod enable-layout ((self window) flag) + (setf (slot-value self 'layout-p) flag) + (if (and flag (layout-of self)) + (let ((sz (client-size self))) + (perform (layout-of self) self (gfs:size-width sz) (gfs:size-height sz))))) -(defmethod event-resize ((d event-dispatcher) (win window) size type) +(defmethod event-resize ((d event-dispatcher) (self window) size type) (declare (ignore size type)) - (unless (null (layout-of win)) - (let ((sz (client-size win))) - (perform (layout-of win) win (gfs:size-width sz) (gfs:size-height sz))))) + (unless (null (layout-of self)) + (let ((sz (client-size self))) + (perform (layout-of self) self (gfs:size-width sz) (gfs:size-height sz))))) -(defmethod focus-p :before ((win window)) - (if (gfs:disposed-p win) +(defmethod focus-p :before ((self window)) + (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod focus-p ((win window)) +(defmethod focus-p ((self window)) (let ((focus-hwnd (gfs::get-focus))) - (and (not (gfs:null-handle-p focus-hwnd)) (cffi:pointer-eq focus-hwnd (gfs:handle win))))) + (and (not (gfs:null-handle-p focus-hwnd)) (cffi:pointer-eq focus-hwnd (gfs:handle self))))) -(defmethod give-focus :before ((win window)) - (if (gfs:disposed-p win) +(defmethod give-focus :before ((self window)) + (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod give-focus ((win window)) - (gfs::set-focus (gfs:handle win))) +(defmethod give-focus ((self window)) + (gfs::set-focus (gfs:handle self))) -(defmethod location ((win window)) - (if (gfs:disposed-p win) +(defmethod image ((self window)) + (let ((small (gfs::send-message (gfs:handle self) gfs::+wm-geticon+ gfs::+icon-small+ 0)) + (large (gfs::send-message (gfs:handle self) gfs::+wm-geticon+ gfs::+icon-big+ 0)) + (handles nil)) + (unless (zerop small) + (push (cffi:make-pointer small) handles)) + (unless (zerop large) + (push (cffi:make-pointer large) handles)) + (make-instance 'gfg:icon-bundle :handle handles))) + +(defmethod (setf image) ((image gfg:image) (self window)) + (setf (image self) (make-instance 'gfg:icon-bundle :images (list image)))) + +(defmethod (setf image) ((bundle gfg:icon-bundle) (self window)) + (let ((hwnd (gfs:handle self)) + (small (gfg::icon-handle-ref bundle :small)) + (large (gfg::icon-handle-ref bundle :large))) + (unless (gfs:null-handle-p small) + (gfs::send-message hwnd gfs::+wm-seticon+ gfs::+icon-small+ (cffi:pointer-address small))) + (unless (gfs:null-handle-p large) + (gfs::send-message hwnd gfs::+wm-seticon+ gfs::+icon-big+ (cffi:pointer-address large))))) + +(defmethod location ((self window)) + (if (gfs:disposed-p self) (error 'gfs:disposed-error)) (let ((pnt (gfs:make-point))) - (outer-location win pnt) + (outer-location self pnt) pnt)) (defmethod layout ((self window))

1 0

[graphic-forms-cvs] r214 - in trunk/src: tests/uitoolkit uitoolkit/graphics
by junrue＠common-lisp.net 13 Aug '06

13 Aug '06

Author: junrue Date: Sun Aug 13 17:28:31 2006 New Revision: 214 Modified: trunk/src/tests/uitoolkit/icon-bundle-unit-tests.lisp trunk/src/uitoolkit/graphics/icon-bundle.lisp Log: implemented setf icon-image-ref unit-test, fixed bug Modified: trunk/src/tests/uitoolkit/icon-bundle-unit-tests.lisp ============================================================================== --- trunk/src/tests/uitoolkit/icon-bundle-unit-tests.lisp (original) +++ trunk/src/tests/uitoolkit/icon-bundle-unit-tests.lisp Sun Aug 13 17:28:31 2006 @@ -99,3 +99,22 @@ (validate-image (gfg:icon-image-ref bundle :large) size 8)) (gfs:dispose bundle)) (assert-true (gfs:disposed-p bundle)))) + +(define-test setf-images-icon-bundle-test + (let ((bundle (make-instance 'gfg:icon-bundle + :images (list (make-instance 'gfg:image :file (merge-pathnames "happy.bmp")) + (make-instance 'gfg:image :file (merge-pathnames "truecolor16x16.bmp"))))) + (happy-image (make-instance 'gfg:image :file (merge-pathnames "happy.bmp"))) + (bw-image (make-instance 'gfg:image :file (merge-pathnames "blackwhite20x16.bmp"))) + (happy-size (gfs:make-size :width 32 :height 32)) + (bw-size (gfs:make-size :width 20 :height 16))) + (unwind-protect + (progn + (assert-equal 2 (gfg:icon-bundle-length bundle)) + (setf (gfg:icon-image-ref bundle 0) bw-image) + (setf (gfg:icon-image-ref bundle 1) happy-image) + (assert-equal 2 (gfg:icon-bundle-length bundle)) + (validate-image (gfg:icon-image-ref bundle 0) bw-size 16000000) + (validate-image (gfg:icon-image-ref bundle 1) happy-size 8)) + (gfs:dispose bundle)) + (assert-true (gfs:disposed-p bundle)))) Modified: trunk/src/uitoolkit/graphics/icon-bundle.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/icon-bundle.lisp (original) +++ trunk/src/uitoolkit/graphics/icon-bundle.lisp Sun Aug 13 17:28:31 2006 @@ -114,6 +114,9 @@ (hicon->image (icon-handle-ref bundle index))) (defun set-icon-image (bundle index image) + (let ((hicon (icon-handle-ref bundle index))) + (if (and (not (gfs:null-handle-p hicon)) (listp (gfs:handle bundle))) + (gfs::destroy-icon hicon))) (setf (icon-handle-ref bundle index) (image->hicon image))) (defsetf icon-image-ref set-icon-image)

1 0