Author: junrue Date: Thu Aug 10 00:15:08 2006 New Revision: 203
Added: trunk/src/tests/uitoolkit/default.ico (contents, props changed) trunk/src/uitoolkit/graphics/icon-bundle.lisp Modified: trunk/docs/manual/api.texinfo trunk/graphic-forms-uitoolkit.asd trunk/src/packages.lisp trunk/src/uitoolkit/graphics/graphics-classes.lisp trunk/src/uitoolkit/graphics/graphics-constants.lisp trunk/src/uitoolkit/graphics/image.lisp trunk/src/uitoolkit/system/system-types.lisp trunk/src/uitoolkit/system/user32.lisp Log: implemented and documented icon-bundle class and related functions
Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Thu Aug 10 00:15:08 2006 @@ -2028,21 +2028,24 @@ in the @code{<Alt><Tab>} task switching dialog, and in the 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. @code{icon-bundle} derives from @ref{native-object}. +depths and file format.@*@* +@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. Since +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 @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}. +@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. Since +This initarg accepts a @sc{cl:list} of image objects. Application +code should not assume that image order is preserved. 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 @@ -2346,6 +2349,30 @@ 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. +@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: +@table @code +@item :large +Specifies the largest image of the icon-bundle. +@item :small +Specifies the smallest image of the icon-bundle. +@end table +@end table +To find out how many images are stored in an icon-bundle, call +@ref{size}. +@end defun + @anchor{load} @deffn GenericFunction load self path => list Certain graphics objects have a persistent representation, which may @@ -2356,6 +2383,13 @@ returns @var{self} plus any additional instances in a @sc{list}, ordered the same as they are read from @var{path}. @emph{Note:} @sc{gfg:load} shadows @sc{cl:load}. +@table @var +@item self +The graphics object that will be populated with data. +@item path +A @sc{cl:pathname} identifying a file with graphics data appropriate +for @var{self}. +@end table @end deffn
@deffn GenericFunction metrics self font => @ref{font-metrics}
Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Thu Aug 10 00:15:08 2006 @@ -76,6 +76,8 @@ (:file "palette") (:file "image-data") (:file "image") + (:file "icon-bundle" + :depends-on ("graphics-constants" "image")) (:file "font-data") (:file "font") (:file "graphics-context")
Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Thu Aug 10 00:15:08 2006 @@ -109,6 +109,7 @@ #:font-data #:font-metrics #:graphics-context + #:icon-bundle #:image #:image-data #:image-data-plugin @@ -123,6 +124,11 @@ #:*color-red* #:*color-white* #:*image-file-types* + #:+application-icon+ + #:+error-icon+ + #:+information-icon+ + #:+question-icon+ + #:+warning-icon+
;; methods, functions, macros #:accepts-file-p @@ -182,6 +188,7 @@ #:green-mask #:green-shift #:height + #:icon-image #:invert #:leading #:line-cap-style
Added: trunk/src/tests/uitoolkit/default.ico ============================================================================== Binary file. No diff available.
Modified: trunk/src/uitoolkit/graphics/graphics-classes.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-classes.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-classes.lisp Thu Aug 10 00:15:08 2006 @@ -1,5 +1,5 @@ ;;;; -;;;; classes.lisp +;;;; graphics-classes.lisp ;;;; ;;;; Copyright (C) 2006, Jack D. Unrue ;;;; All rights reserved. @@ -127,12 +127,15 @@ :initform (cffi:null-pointer))) (:documentation "This class represents the context associated with drawing primitives."))
+(defclass icon-bundle (gfs:native-object) () + (:documentation "This class encapsulates a set of Win32 icon handles.")) + (defclass image (gfs:native-object) ((transparency-pixel :accessor transparency-pixel-of :initarg :transparency-pixel :initform nil)) - (:documentation "This class wraps a native image object.")) + (:documentation "This class encapsulates a Win32 bitmap handle."))
(defmacro blue-mask (data) `(gfg::palette-blue-mask ,data))
Modified: trunk/src/uitoolkit/graphics/graphics-constants.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-constants.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-constants.lisp Thu Aug 10 00:15:08 2006 @@ -57,3 +57,13 @@ (defconstant +russian-charset+ 204) (defconstant +mac-charset+ 77) (defconstant +baltic-charset+ 186) + +;;; The following are from WinUser.h; specify one of +;;; them as the value of the :system keyword arg when +;;; creating an icon-bundle +;;; +(defconstant +application-icon+ 32512) +(defconstant +error-icon+ 32513) +(defconstant +information-icon+ 32516) +(defconstant +question-icon+ 32514) +(defconstant +warning-icon+ 32515)
Added: trunk/src/uitoolkit/graphics/icon-bundle.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/graphics/icon-bundle.lisp Thu Aug 10 00:15:08 2006 @@ -0,0 +1,129 @@ +;;;; +;;;; icon-bundle.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.graphics) + +;;; +;;; helper functions +;;; + +(defun hicon->image (hicon) + (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")) + (cffi:with-foreign-slots ((gfs::hmask gfs::hcolor) info-ptr gfs::iconinfo) + (gfs::delete-object gfs::hmask) + (make-instance 'image :handle gfs::hcolor)))) + +(defun icon-extent (hicon) + (let ((im (hicon->image hicon)) + (extent 0)) + (unwind-protect + (setf extent (gfs:size-height (gfg:size im))) + (gfs:dispose im)) + extent)) + +(defun icon-handle (bundle index) + (let ((handles (gfs:handle bundle))) + (unless handles + (error 'gfs:disposed-error)) + (cond + ((typep index 'integer) + (if (zerop index) + (if (listp handles) + (elt handles index) + handles))) + ((eql index :small) + (if (listp handles) + (first (stable-sort handles #'< :key #'icon-extent)) + handles)) + ((eql index :large) + (if (listp handles) + (first (last (stable-sort handles #'< :key #'icon-extent))) + handles)) + (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))) + +;;; +;;; methods +;;; + +(defmethod gfs:dispose ((self icon-bundle)) + (let ((handles (gfs:handle self))) + (setf (slot-value self 'gfs:handle) nil) + ;; note: if handles is a cffi:pointer, then self was + ;; instantiated as a system icon and we don't need + ;; to destroy the handle + ;; + (if (and handles (listp handles)) + (loop for hicon in handles do (gfs::destroy-icon hicon))))) + +(defmethod initialize-instance :after ((self icon-bundle) &key file images system transparency-pixel) + (let ((image-list nil) + (resource-id (case system + (#.+application-icon+ (cffi:make-pointer system)) + (#.+error-icon+ (cffi:make-pointer system)) + (#.+information-icon+ (cffi:make-pointer system)) + (#.+question-icon+ (cffi:make-pointer system)) + (#.+warning-icon+ (cffi:make-pointer system)) + (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))) + (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)))) + (unless (gfs:handle self) + (error 'gfs:toolkit-error :detail "could not initialize icon bundle")))
Modified: trunk/src/uitoolkit/graphics/image.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/image.lisp (original) +++ trunk/src/uitoolkit/graphics/image.lisp Thu Aug 10 00:15:08 2006 @@ -83,10 +83,10 @@ (gfs:dispose self)) (setf (slot-value self 'gfs:handle) (data->image id)))
-(defmethod initialize-instance :after ((image image) &key file size &allow-other-keys) +(defmethod initialize-instance :after ((self image) &key file size &allow-other-keys) (cond (file - (load image file)) + (load self file)) (size (cffi:with-foreign-object (bih-ptr 'gfs::bitmapinfoheader) (gfs::zero-mem bih-ptr gfs::bitmapinfoheader) @@ -104,19 +104,19 @@ (cffi:with-foreign-object (buffer :pointer) (gfs::with-compatible-dcs (nptr memdc) (setf hbmp (gfs::create-dib-section memdc bih-ptr gfs::+dib-rgb-colors+ buffer nptr 0)))) - (setf (slot-value image 'gfs:handle) hbmp))))))) + (setf (slot-value self 'gfs:handle) hbmp)))))))
-(defmethod load ((im image) path) +(defmethod load ((self image) path) (let ((data (make-instance 'image-data))) (load data path) - (setf (data-object im) data) + (setf (data-object self) data) data))
-(defmethod size ((image image)) - (if (gfs:disposed-p image) +(defmethod size ((self image)) + (if (gfs:disposed-p self) (error 'gfs:disposed-error)) (let ((size (gfs:make-size)) - (himage (gfs:handle image))) + (himage (gfs:handle self))) (cffi:with-foreign-object (bmp-ptr 'gfs::bitmap) (cffi:with-foreign-slots ((gfs::width gfs::height) bmp-ptr gfs::bitmap) (gfs::get-object himage (cffi:foreign-type-size 'gfs::bitmap) bmp-ptr) @@ -124,17 +124,17 @@ (gfs:size-height size) gfs::height))) size))
-(defmethod transparency-mask ((im image)) - (if (gfs:disposed-p im) +(defmethod transparency-mask ((self image)) + (if (gfs:disposed-p self) (error 'gfs:disposed-error)) - (let ((pixel-pnt (transparency-pixel-of im)) - (hbmp (gfs:handle im)) + (let ((pixel-pnt (transparency-pixel-of self)) + (hbmp (gfs:handle self)) (hmask (cffi:null-pointer)) (nptr (cffi:null-pointer))) (if pixel-pnt (progn (cffi:with-foreign-object (bmp-ptr 'gfs::bitmap) - (gfs::get-object (gfs:handle im) (cffi:foreign-type-size 'gfs::bitmap) bmp-ptr) + (gfs::get-object (gfs:handle self) (cffi:foreign-type-size 'gfs::bitmap) bmp-ptr) (cffi:with-foreign-slots ((gfs::width gfs::height) bmp-ptr gfs::bitmap) (setf hmask (gfs::create-bitmap gfs::width gfs::height 1 1 (cffi:null-pointer))) (if (gfs:null-handle-p hmask)
Modified: trunk/src/uitoolkit/system/system-types.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-types.lisp (original) +++ trunk/src/uitoolkit/system/system-types.lisp Thu Aug 10 00:15:08 2006 @@ -171,8 +171,8 @@ (flag BOOL) (hotspotx DWORD) (hotspoty DWORD) - (maskbm HANDLE) - (colorbm HANDLE)) + (hmask HANDLE) + (hcolor HANDLE))
(defctype iconinfo-pointer :pointer)
Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Thu Aug 10 00:15:08 2006 @@ -347,6 +347,12 @@ HANDLE)
(defcfun + ("GetIconInfo" get-icon-info) + BOOL + (hicon HANDLE) + (iconinfo LPTR)) + +(defcfun ("GetKeyState" get-key-state) SHORT (virtkey INT))