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")))
