Author: junrue Date: Sat Aug 12 01:44:13 2006 New Revision: 210 Added: trunk/src/tests/uitoolkit/icon-bundle-unit-tests.lisp trunk/src/tests/uitoolkit/test-utils.lisp Modified: trunk/docs/manual/api.texinfo trunk/docs/manual/graphics-api.texinfo trunk/docs/manual/system-api.texinfo trunk/docs/manual/widgets-api.texinfo trunk/graphic-forms-tests.asd trunk/src/packages.lisp trunk/src/uitoolkit/graphics/icon-bundle.lisp Log: icon-bundle testing and bug fixing Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Sat Aug 12 01:44:13 2006 @@ -14,9 +14,9 @@ of the package names are prefixed with @code{graphic-forms.uitoolkit}. @menu -* graphics package:: -* system package:: -* widgets package:: +* GFS package:: +* GFG package:: +* GFW package:: @end menu @include graphics-api.texinfo Modified: trunk/docs/manual/graphics-api.texinfo ============================================================================== --- trunk/docs/manual/graphics-api.texinfo (original) +++ trunk/docs/manual/graphics-api.texinfo Sat Aug 12 01:44:13 2006 @@ -5,15 +5,15 @@ @c Copyright (c) 2006, Jack D. Unrue -@node graphics package, widgets package, system package, API -@section graphics package -@cindex graphics package - -Nickname: GFG - -This package represents graphical functionality, particularly drawing -operations. Support for the ImageMagick library is defined here. This -package and GFW together constitute the bulk of the public API. +@node GFG package +@section GFG package +@cindex GFG package + +Full package name: @emph{graphic-forms.uitoolkit.graphics} + +This package contains the symbols corresponding to graphics-related +classes, drawing operations, and meta-data. This package and +@sc{gfw} together comprise the bulk of the library API. @menu * graphics types:: @@ -205,23 +205,26 @@ Windows Start menu. See the @samp{Icons in Win32} topic of the MSDN documentation for further discussion of standard icon sizes, color depths and file format.@*@* +The implementation of @code{icon-bundle} includes the concept of +there being large and small versions. The actual size to be used +depends on the context in which the icon is needed. To retrieve +or set an individual image, call @ref{icon-image-ref}. To find +out how many @ref{image}s are stored, call @ref{icon-bundle-length}.@*@* @code{icon-bundle} derives from @ref{native-object}. @deffn Initarg :file This initarg accepts a @sc{cl:pathname} identifying a file -with @ref{image-data} to be loaded, as described for the @ref{image} -class @code{:file} initarg. Note that the @sc{ico} format can -store multiple icons, all of which will be loaded. Application -code should not assume that load order is preserved. Since +with in a supported format to be loaded, as described for the +image class @code{:file} initarg. Note that the @sc{ico} format +can store multiple images, all of which will be loaded. Since @code{icon-bundle} needs a transparency mask for each image in order to create Windows icons, a value may be supplied for the @code{:transparency-pixel} initarg of this class to select the -proper transparency @ref{color}; by default, the pixel color at -@code{(0, 0)} in each image will be used. @emph{FIXME: link -to documentation of graphics plugins here}. +proper transparency @ref{color}; or else by default, the pixel +color at @code{(0, 0)} in each image will be used. @emph{FIXME: +link to documentation of graphics plugins here}. @end deffn @deffn Initarg :images -This initarg accepts a @sc{cl:list} of image objects. Application -code should not assume that image order is preserved. Since +This initarg accepts a @sc{cl:list} of image objects. Since @code{icon-bundle} needs a transparency mask for each image in order to create Windows icons, the application may either @sc{setf} @ref{transparency-pixel} for each image ahead of time (especially @@ -527,28 +530,38 @@ Returns a color object corresponding to the current foreground color. @end deffn -@anchor{icon-image} -@defun icon-image @ref{icon-bundle} index => @ref{image} -This function uses an integer or keyword -based @var{index} to address -the images comprising an icon-bundle, either to retrieve an image -or add/replace an image via @sc{setf}. Application code should not -assume that image load order was preserved when this function is called. +@anchor{icon-bundle-length} +@defun icon-bundle-length @ref{icon-bundle} => integer +Returns a count of the number of icon handles held by @var{icon-bundle}. +@end defun + +@anchor{icon-image-ref} +@defun icon-image-ref @ref{icon-bundle} subscript => @ref{image} +(setf (@strong{icon-image-ref} @var{icon-bundle} @var{subscript}) @var{image})@*@* +This function uses an integer or keyword -based @var{subscript} to address +the images comprising @var{icon-bundle}, either to retrieve an image +or add/replace an image via @sc{setf}. @table @var @item icon-bundle -This is an icon-bundle containing images to be updated or retrieved. -@item index -This argument can be a zero-based, with new images added by -specifying @var{index} 0. Or @var{index} can be one of the following -keywords: +Contains images to be used for frame decorations. +@item subscript +This argument can be zero-based, in which case @var{icon-bundle} +is treated as though it were an array of images. Add a new image +by specifying @var{subscript} 0.@*@* +Alternatively, @var{subscript} +can be one of the following keywords:@*@* @table @code @item :large -Specifies the largest image of the icon-bundle. +Identifies the largest image of the @var{icon-bundle}. @item :small -Specifies the smallest image of the icon-bundle. +Identifies the smallest image of the @var{icon-bundle}.@*@* @end table +Note that adding an image addressed by one of these +keywords will succeed, but the result may be counter-intuitive. @end table -To find out how many images are stored in an icon-bundle, call -@ref{size}. +To find out how many images are stored in @var{icon-bundle}, and hence +what constitutes a valid range of subscripts for this function, +call @ref{icon-bundle-length}. @end defun @anchor{load} Modified: trunk/docs/manual/system-api.texinfo ============================================================================== --- trunk/docs/manual/system-api.texinfo (original) +++ trunk/docs/manual/system-api.texinfo Sat Aug 12 01:44:13 2006 @@ -5,16 +5,16 @@ @c Copyright (c) 2006, Jack D. Unrue -@node system package, graphics package, , API -@section system package -@cindex system package +@node GFS package +@section GFS package +@cindex GFS package -Nickname: GFS +Full package name: @emph{graphic-forms.uitoolkit.system} The symbols in this package correspond to system-level functionality, -examples of which include bindings for Win32 API functions and associated -constants. The majority of the symbols herein are not exported, except for -a few fundamental types and methods +such as foreign function declarations for the Win32 @sc{api}. The +majority of the symbols herein are not exported, except +for a few fundamental types, conditions, and methods. @menu * system types:: Modified: trunk/docs/manual/widgets-api.texinfo ============================================================================== --- trunk/docs/manual/widgets-api.texinfo (original) +++ trunk/docs/manual/widgets-api.texinfo Sat Aug 12 01:44:13 2006 @@ -5,15 +5,16 @@ @c Copyright (c) 2006, Jack D. Unrue -@node widgets package, , graphics package, API -@section widgets package -@cindex widgets package - -Nickname: GFW - -This package contains symbols for all of the widgets, event methods, -and other UI objects defined by Graphic-Forms. This package and GFG -together constitute the bulk of the public API. +@node GFW package +@section GFW package +@cindex GFW package + +Full package name: @emph{graphic-forms.uitoolkit.widgets} + +This package contains symbols for user interface widget +classes, event-handling methods, and management functions. This +package and @sc{gfg} together constitute the bulk of the library +API. @menu * event functions:: Modified: trunk/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Sat Aug 12 01:44:13 2006 @@ -65,6 +65,7 @@ ((:file "textedit-document") (:file "textedit-window"))) (:module "unblocked" + :serial t :components ((:file "tiles") (:file "unblocked-model") @@ -75,11 +76,14 @@ (:module "tests" :components ((:module "uitoolkit" + :serial t :components - ((:file "mock-objects") + ((:file "test-utils") + (:file "mock-objects") (:file "color-unit-tests") (:file "graphics-context-unit-tests") (:file "image-unit-tests") + (:file "icon-bundle-unit-tests") (:file "layout-unit-tests") (:file "widget-unit-tests") (:file "misc-unit-tests") Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Sat Aug 12 01:44:13 2006 @@ -188,7 +188,8 @@ #:green-mask #:green-shift #:height - #:icon-image + #:icon-bundle-length + #:icon-image-ref #:invert #:leading #:line-cap-style Added: trunk/src/tests/uitoolkit/icon-bundle-unit-tests.lisp ============================================================================== --- (empty file) +++ trunk/src/tests/uitoolkit/icon-bundle-unit-tests.lisp Sat Aug 12 01:44:13 2006 @@ -0,0 +1,38 @@ +;;;; +;;;; icon-bundle-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) + + + + Added: trunk/src/tests/uitoolkit/test-utils.lisp ============================================================================== --- (empty file) +++ trunk/src/tests/uitoolkit/test-utils.lisp Sat Aug 12 01:44:13 2006 @@ -0,0 +1,40 @@ +;;;; +;;;; test-utils.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) + +#| +(defun validate-image (image expected-size expected-depth) + (assert-equality #'gfs:equal-size-p expected-size (gfg:size image)) + (assert-equal expected-depth (gfg:depth image))) +|# Modified: trunk/src/uitoolkit/graphics/icon-bundle.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/icon-bundle.lisp (original) +++ trunk/src/uitoolkit/graphics/icon-bundle.lisp Sat Aug 12 01:44:13 2006 @@ -41,11 +41,28 @@ (cffi:with-foreign-object (info-ptr 'gfs::iconinfo) (gfs::zero-mem info-ptr gfs::iconinfo) (if (zerop (gfs::get-icon-info hicon info-ptr)) - (error 'gfs::win32-error :detail "get-icon-info failed")) + (error 'gfs:win32-error :detail "get-icon-info failed")) (cffi:with-foreign-slots ((gfs::hmask gfs::hcolor) info-ptr gfs::iconinfo) (gfs::delete-object gfs::hmask) (make-instance 'image :handle gfs::hcolor)))) +(defun image->hicon (image &optional point) + (unless (typep point 'gfs:point) + (setf point (transparency-pixel-of image)) + (unless point + (setf point (gfs:make-point)))) + (cffi:with-foreign-object (info-ptr 'gfs::iconinfo) + (cffi:with-foreign-slots ((gfs::flag gfs::hcolor gfs::hmask) info-ptr gfs::iconinfo) + (gfs::zero-mem info-ptr gfs::iconinfo) + (setf gfs::flag 1) + (with-image-transparency (image point) + (setf gfs::hcolor (gfs:handle image)) + (setf gfs::hmask (gfs:handle (transparency-mask image))) + (let ((hicon (gfs::create-icon-indirect info-ptr))) + (if (gfs:null-handle-p hicon) + (error 'gfs:win32-error :detail "create-icon-indirect failed")) + hicon))))) + (defun icon-extent (hicon) (let ((im (hicon->image hicon)) (extent 0)) @@ -54,30 +71,63 @@ (gfs:dispose im)) extent)) -(defun icon-handle (bundle index) +;;; Note: this function needs to return a place not +;;; just a handle, to facilitate a defsetf further +;;; on below +;;; +(defun icon-handle-ref (bundle index) (let ((handles (gfs:handle bundle))) (unless handles (error 'gfs:disposed-error)) (cond ((typep index 'integer) - (if (zerop index) - (if (listp handles) + (if (listp handles) + (if (< index (length handles)) (elt handles index) - handles))) + (error 'gfs:toolkit-error :detail "invalid image index")) + (if (zerop index) + (gfs:handle bundle) + (error 'gfs:toolkit-error :detail "invalid image index")))) ((eql index :small) (if (listp handles) (first (stable-sort handles #'< :key #'icon-extent)) - handles)) + (gfs:handle bundle))) ((eql index :large) (if (listp handles) (first (last (stable-sort handles #'< :key #'icon-extent))) - handles)) + (gfs:handle bundle))) (t (error 'gfs:toolkit-error :detail "an integer index, or one of :small or :large, is required"))))) -(defun icon-image (bundle index) - (hicon->image (icon-handle bundle index))) +(defsetf icon-handle-ref (bundle index) (hicon) + `(progn + (if (gfs:null-handle-p ,hicon) + (error 'gfs:disposed-error)) + (cond + ((listp (gfs:handle ,bundle)) + (replace (gfs:handle ,bundle) (list ,hicon) :start1 ,index)) + ((and (zerop ,index) (not (null (gfs:handle ,bundle)))) + (setf (slot-value ,bundle 'gfs:handle) ,hicon)) + (t + (error 'gfs:toolkit-error :detail "illegal arguments for (setf icon-handle-ref)"))) + ,hicon)) + +(defun icon-image-ref (bundle index) + (hicon->image (icon-handle-ref bundle index))) + +(defun set-icon-image (bundle index image) + (setf (icon-handle-ref bundle index) (image->hicon image))) + +(defsetf icon-image-ref set-icon-image) + +(defun icon-bundle-length (bundle) + (let ((handles (gfs:handle bundle))) + (unless handles + (error 'gfs:disposed-error)) + (if (listp handles) + (length handles) + 1))) ;;; ;;; methods @@ -104,26 +154,14 @@ (otherwise nil)))) (cond (resource-id - (setf (slot-value self 'gfs:handle) (gfs::load-icon (cffi:null-pointer) resource-id))) - (file - (let ((tmp-image (make-instance 'image))) - (setf image-list (load tmp-image file)))) - (images - (setf image-list images))) + (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)))) + ((listp images) + (setf image-list images))) (when image-list - (let ((handles nil) - (default-pnt (gfs:make-point))) - (cffi:with-foreign-object (info-ptr 'gfs::iconinfo) - (cffi:with-foreign-slots ((gfs::flag gfs::hcolor gfs::hmask) info-ptr gfs::iconinfo) - (gfs::zero-mem info-ptr gfs::iconinfo) - (setf gfs::flag 1) - (loop for tmp-image in image-list - do (with-image-transparency (tmp-image (or transparency-pixel default-pnt)) - (setf gfs::hcolor (gfs:handle tmp-image)) - (setf gfs::hmask (gfs:handle (transparency-mask tmp-image))) - (let ((hicon (gfs::create-icon-indirect info-ptr))) - (unless (gfs:null-handle-p hicon) - (push hicon handles))))))) - (setf (slot-value self 'gfs:handle) handles)))) + (let ((tr-pnt (or transparency-pixel (gfs:make-point)))) + (setf (slot-value self 'gfs:handle) (loop for tmp-image in image-list + collect (image->hicon tmp-image tr-pnt)))))) (unless (gfs:handle self) (error 'gfs:toolkit-error :detail "could not initialize icon bundle")))