[graphic-forms-cvs] r203 - in trunk: . docs/manual src src/tests/uitoolkit src/uitoolkit/graphics src/uitoolkit/system
junrue at common-lisp.net
junrue at common-lisp.net
Thu Aug 10 04:15:09 UTC 2006
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.@*@*
+ at 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
- at code{(0, 0)} in each image will be used. @emph{FIXME: link to
-documentation of graphics plugins here}.
+ 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. 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
+ at anchor{icon-image}
+ at 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.
+ at table @var
+ at item icon-bundle
+This is an icon-bundle containing images to be updated or retrieved.
+ at 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:
+ at table @code
+ at item :large
+Specifies the largest image of the icon-bundle.
+ at item :small
+Specifies the smallest image of the icon-bundle.
+ at end table
+ at end table
+To find out how many images are stored in an icon-bundle, call
+ at ref{size}.
+ at 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}.
+ at table @var
+ at item self
+The graphics object that will be populated with data.
+ at item path
+A @sc{cl:pathname} identifying a file with graphics data appropriate
+for @var{self}.
+ at 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))
More information about the Graphic-forms-cvs
mailing list