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

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

08 Aug '06

Author: junrue Date: Tue Aug 8 01:47:29 2006 New Revision: 202 Modified: trunk/docs/manual/api.texinfo trunk/src/uitoolkit/system/system-types.lisp trunk/src/uitoolkit/system/user32.lisp Log: further work towards supporting icon display Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Tue Aug 8 01:47:29 2006 @@ -2020,11 +2020,76 @@ @end deffn @end deftp +@anchor{icon-bundle} +@deftp Class icon-bundle +This class encapsulates a collection of Win32 icon handles. +Icons are used to decorate @ref{window} title bars, to represent +a file or application on the desktop, to represent an application +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}. +@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 +@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}. +@end deffn +@deffn Initarg :images +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 +important when the pixel location is different from one image +to the next), or provide a value for the @code{:transparency-pixel} +initarg of this class; or else by default, the pixel color at +@code{(0, 0)} in each image will be used. +@end deffn +@deffn Initarg :system +This initarg causes the @code{icon-bundle} to be loaded with a +system-provided standard icon, identified by one of the following +constants: +@table @code +@item +application-icon+ +Default application icon. +@item +error-icon+ +Icon for error notifications. +@item +information-icon+ +Icon for informational notifications. +@item +question-icon+ +Icon to be used when prompting the user for more input. +@item +warning-icon+ +Icon for warning notifications. +@end table +@end deffn +@deffn Initarg :transparency-pixel +This initarg is similar in purpose to the same initarg for +the image class, except that in this case the specified @ref{point} +applies to all images (except pre-defined system icons) +encapsulated by the @code{icon-bundle} object. +@end deffn +@end deftp + @anchor{image} -@deftp Class image -This subclass of @ref{native-object} wraps a native image object. -Instances may be drawn directly via a graphics-context (see -@ref{draw-image}) or set as the content of a @ref{label} control. +@deftp Class image transparency-pixel +This subclass of @ref{native-object} wraps a Win32 bitmap handle. +Instances may be drawn using @ref{draw-image} or displayed within +certain @ref{control}s such as a @ref{label}. Images may originate +from a variety of formats. @emph{FIXME: link to documentation +of graphics plugins here}. +@table @var +@anchor{transparency-pixel} +@item transparency-pixel +This slot holds a @ref{point} that identifies a pixel within the +image whose color will be used by @ref{transparency-mask}. +@xref{with-image-transparency}. +@end table @deffn Initarg :file Supply a path to a file containing image data to be loaded. @end deffn @@ -2036,9 +2101,28 @@ @end deftp @anchor{image-data} -@deftp Class image-data -This subclass of @ref{native-object} maintains image attributes, -color, and pixel data. @xref{image}. +@deftp Class image-data data-plugin +This class represents an image in an external format. Such formats +may be loaded (via the @ref{load} method) and then converted to an +@ref{image} object by the @ref{data-object} @sc{setf} function.@*@* +@code{image-data} serves as an integration point between Graphic-Forms +and third-party graphics libraries such as ImageMagick. @emph{FIXME: +link to documentation of graphics plugins here}. +@table @var +@item data-plugin +This slot holds a subclass of @ref{image-data-plugin} encapsulating +format and functionality from a particular third-party graphics library. +Many of the features offered by @code{image-data} are delegated to +this plugin object. +@end table +@end deftp + +@anchor{image-data-plugin} +@deftp Class image-data-plugin +This is a base class for plugin objects that encapsulate third-party +library representations of images. @emph{FIXME: +link to documentation of graphics plugins here}. It derives from +@ref{native-object}. @end deftp @node graphics functions @@ -2053,6 +2137,7 @@ Returns a color object corresponding to the current background color. @end deffn +@anchor{data-object} @deffn GenericFunction data-object self &optional gc => object Returns the data structure representing the raw data form of the object. The @code{gc} argument must be supplied when calling this @@ -2261,6 +2346,7 @@ Returns a color object corresponding to the current foreground color. @end deffn +@anchor{load} @deffn GenericFunction load self path => list Certain graphics objects have a persistent representation, which may be deserialized with the appropriate implementation of this function. @@ -2296,8 +2382,16 @@ @end table @end deffn -@deffn GenericFunction transparency-mask self +@anchor{transparency-mask} +@deffn GenericFunction transparency-mask self => @ref{image} Returns an image object that will serve as the transparency mask for the original image, based on the original image's assigned transparency. @end deffn + +@anchor{with-image-transparency} +@defmac with-image-transparency (image point) &body body +This macro wraps @var{body} in an @sc{unwind-protect} form with +@var{point} set as the @ref{transparency-pixel} for @var{image}. +Any existing point set in @var{image} is restored. +@end defmac Modified: trunk/src/uitoolkit/system/system-types.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-types.lisp (original) +++ trunk/src/uitoolkit/system/system-types.lisp Tue Aug 8 01:47:29 2006 @@ -167,6 +167,15 @@ (hookfn LPTR) ; FIXME: not yet used, but eventually should be FRHookProc (templname :string)) +(defcstruct iconinfo + (flag BOOL) + (hotspotx DWORD) + (hotspoty DWORD) + (maskbm HANDLE) + (colorbm HANDLE)) + +(defctype iconinfo-pointer :pointer) + (defcstruct initcommoncontrolsex (size DWORD) (icc DWORD)) Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Tue Aug 8 01:47:29 2006 @@ -72,6 +72,11 @@ (ch UINT)) (defcfun + ("CreateIconIndirect" create-icon-indirect) + HANDLE + (iconinfo iconinfo-pointer)) + +(defcfun ("CreateMenu" create-menu) HANDLE) @@ -124,6 +129,11 @@ (lp LPARAM)) (defcfun + ("DestroyIcon" destroy-icon) + BOOL + (hicon HANDLE)) + +(defcfun ("DestroyMenu" destroy-menu) BOOL (hwnd HANDLE)) @@ -487,6 +497,12 @@ (name LPTR)) ; LPTR to make it easier to pass constants like +obm-checkboxes+ (defcfun + ("LoadIconA" load-icon) + HANDLE + (instance HANDLE) + (name LPCTSTR)) + +(defcfun ("LoadImageA" load-image) HANDLE (instance HANDLE)

1 0

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

07 Aug '06

Author: junrue Date: Mon Aug 7 12:14:19 2006 New Revision: 201 Modified: trunk/docs/manual/api.texinfo trunk/graphic-forms-tests.asd trunk/graphic-forms-uitoolkit.asd trunk/src/uitoolkit/graphics/graphics-classes.lisp trunk/src/uitoolkit/graphics/image-data.lisp trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp trunk/src/uitoolkit/graphics/plugins/default/file-formats.lisp trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-core-api.lisp trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp Log: refactored plugin loading to accomodate multiple-image formats Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Mon Aug 7 12:14:19 2006 @@ -2261,12 +2261,24 @@ Returns a color object corresponding to the current foreground color. @end deffn -@deffn GenericFunction metrics self font -Returns a @ref{font-metrics} object describing key attributes of @code{font}. +@deffn GenericFunction load self path => list +Certain graphics objects have a persistent representation, which may +be deserialized with the appropriate implementation of this function. +@var{self} will be re-initialized with data loaded from @var{path}. +Certain serialized object formats (e.g., @sc{ico}) may actually +describe multiple instances. To facilitate such formats, @code{load} +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}. @end deffn -@deffn GenericFunction size self -Returns a size object describing the dimensions of the object. +@deffn GenericFunction metrics self font => @ref{font-metrics} +Returns a font-metrics object describing key attributes of @var{font}, +where @var{self} is a @ref{graphics-context}. +@end deffn + +@deffn GenericFunction size self => @ref{size} +Returns a size object describing the dimensions of @var{self}. @end deffn @deffn GenericFunction text-extent self text &optional style tab-width Modified: trunk/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Mon Aug 7 12:14:19 2006 @@ -50,7 +50,7 @@ (defsystem graphic-forms-tests :description "Graphic-Forms UI Toolkit Tests" - :version "0.3.0" + :version "0.5.0" :author "Jack D. Unrue" :licence "BSD" :depends-on ("cells") Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Mon Aug 7 12:14:19 2006 @@ -39,7 +39,7 @@ (defsystem graphic-forms-uitoolkit :description "Graphic-Forms UI Toolkit" - :version "0.3.0" + :version "0.5.0" :author "Jack D. Unrue" :licence "BSD" :depends-on ("cffi" "lw-compat" "closer-mop" "macro-utilities" "binary-data") Modified: trunk/src/uitoolkit/graphics/graphics-classes.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-classes.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-classes.lisp Mon Aug 7 12:14:19 2006 @@ -90,6 +90,7 @@ (defclass image-data () ((data-plugin :reader data-plugin-of + :initarg :data-plugin :initform nil)) (:documentation "This class maintains image attributes, color, and pixel data.")) Modified: trunk/src/uitoolkit/graphics/image-data.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/image-data.lisp (original) +++ trunk/src/uitoolkit/graphics/image-data.lisp Mon Aug 7 12:14:19 2006 @@ -78,11 +78,11 @@ ;;; helper functions ;;; -(defun find-image-plugin (path) - (loop for acceptor in *image-plugins* - for plugin = (funcall acceptor path) - until plugin - finally (return plugin))) +(defun load-image-data (path) + (loop for loader in *image-plugins* + for data = (funcall loader path) + until data + finally (return data))) (defun image->data (hbmp) (declare (ignore hbmp))) #| @@ -193,14 +193,16 @@ ((typep path 'string) (namestring (merge-pathnames path))) (t (error 'gfs:toolkit-error :detail "pathname or string required")))) - - (let ((plugin (data-plugin-of self))) - (unless plugin - (setf plugin (find-image-plugin path))) - (unless plugin + (let ((plugin (data-plugin-of self)) + (plugins nil)) + (if plugin + (setf plugins (load plugin path)) + (setf plugins (load-image-data path))) + (unless plugins (error 'gfs:toolkit-error :detail (format nil "no image data plugin supports: ~a" path))) - (load plugin path) - (setf (slot-value self 'data-plugin) plugin))) + (setf (slot-value self 'data-plugin) (first plugins)) + (append (list self) (loop for p in (rest plugins) + collect (make-instance 'image-data :data-plugin p))))) (defmethod size ((self image-data)) (size (data-plugin-of self))) 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 Mon Aug 7 12:14:19 2006 @@ -45,22 +45,66 @@ (defmacro bitmap-pixel-row-length (width bit-count) `(ash (logand (+ (* ,width ,bit-count) 31) (lognot 31)) -3)) -(defun accepts-file-p (path) - (cond - ((parse-namestring path)) ; syntax check - ((typep path 'pathname) - (setf path (namestring path))) - (t - (error 'gfs:toolkit-error :detail (format nil "~s must be a string or pathname" path)))) - (let ((ext (pathname-type path))) -; (if (or (string-equal ext "ico") (string-equal ext "bmp")) - (if (string-equal ext "bmp") - (let ((plugin (make-instance 'default-data-plugin))) - (gfg:load plugin path) - plugin) - nil))) +(defun load-bmp-data (stream) + (let* ((header (read-value 'BITMAPFILEHEADER stream)) + (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")) + + ;; load color table + ;; + (let ((used (biClrUsed info)) + (rgbs nil)) + (ecase (biBitCount info) + (1 + (setf rgbs (make-array 2))) + (4 + (if (or (= used 0) (= used 16)) + (setf rgbs (make-array 16)) + (setf rgbs (make-array used)))) + (8 + (if (or (= used 0) (= used 256)) + (setf rgbs (make-array 256)) + (setf rgbs (make-array used)))) + (16 + (unless (/= used 0) + (setf rgbs (make-array used)))) + (24 + (unless (/= used 0) + (setf rgbs (make-array used)))) + (32 + (unless (/= used 0) + (setf rgbs (make-array used))))) + (dotimes (i (length rgbs)) + (let ((quad (read-value 'RGBQUAD stream))) + (setf (aref rgbs i) (gfg:make-color :red (rgbRed quad) + :green (rgbGreen quad) + :blue (rgbBlue quad))))) + (setf (palette-of data) (gfg:make-palette :direct nil :table rgbs))) + + ;; load pixel bits + ;; + (let ((row-len (bitmap-pixel-row-length (biWidth info) (biBitCount info)))) + (setf (pixels-of data) (make-array (* row-len (biHeight info)) :element-type '(unsigned-byte 8))) + (read-sequence (pixels-of data) stream)) + + (list data))) + +(defun load-icon-data (stream) + (declare (ignore stream))) + +(defun loader (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) + (t (return-from loader nil))))) + (with-open-file (stream path :element-type '(unsigned-byte 8)) + (funcall helper stream)))) -(push #'accepts-file-p gfg::*image-plugins*) +(push #'loader gfg::*image-plugins*) (defmethod gfg:data->image ((self default-data-plugin)) (let ((screen-dc (gfs::get-dc (cffi:null-pointer))) @@ -99,55 +143,6 @@ (declare (ignore param)) (cffi:foreign-free bi-ptr)) -(defmethod gfg:load ((self default-data-plugin) path) - (with-open-file (in path :element-type '(unsigned-byte 8)) - (let ((header (read-value 'BITMAPFILEHEADER in)) - (info (read-value 'BASE-BITMAPINFOHEADER in))) - (declare (ignore header)) - (unless (= (biCompression info) gfs::+bi-rgb+) - (error 'gfs:toolkit-error :detail "FIXME: non-RGB not yet implemented")) - - ;; load color table - ;; - (let ((used (biClrUsed info)) - (rgbs nil)) - (ecase (biBitCount info) - (1 - (setf rgbs (make-array 2))) - (4 - (if (or (= used 0) (= used 16)) - (setf rgbs (make-array 16)) - (setf rgbs (make-array used)))) - (8 - (if (or (= used 0) (= used 256)) - (setf rgbs (make-array 256)) - (setf rgbs (make-array used)))) - (16 - (unless (/= used 0) - (setf rgbs (make-array used)))) - (24 - (unless (/= used 0) - (setf rgbs (make-array used)))) - (32 - (unless (/= used 0) - (setf rgbs (make-array used))))) - (dotimes (i (length rgbs)) - (let ((quad (read-value 'RGBQUAD in))) - (setf (aref rgbs i) (gfg:make-color :red (rgbRed quad) - :green (rgbGreen quad) - :blue (rgbBlue quad))))) - (setf (palette-of self) (gfg:make-palette :direct nil :table rgbs))) - - ;; load pixel bits - ;; - (let ((row-len (bitmap-pixel-row-length (biWidth info) (biBitCount info)))) - (setf (pixels-of self) (make-array (* row-len (biHeight info)) :element-type '(unsigned-byte 8))) - (read-sequence (pixels-of self) in)) - - ;; complete load - ;; - (setf (slot-value self 'gfs:handle) info)))) - (defmethod gfg:size ((self default-data-plugin)) (let ((info (gfs:handle self))) (unless info Modified: trunk/src/uitoolkit/graphics/plugins/default/file-formats.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/plugins/default/file-formats.lisp (original) +++ trunk/src/uitoolkit/graphics/plugins/default/file-formats.lisp Mon Aug 7 12:14:19 2006 @@ -138,3 +138,22 @@ (rgbGreen BYTE) (rgbRed BYTE) (rgbReserved BYTE))) + +;;; +;;; Win32 GDI Icon Formats +;;; + +(define-binary-class ICONDIR () + ((idReserved WORD) + (idType WORD) + (idCount WORD))) ; ICONDIRENTRY array read separately + +(define-binary-class ICONDIRENTRY () + ((ideWidth BYTE) + (ideHeight BYTE) + (ideColorCount BYTE) + (ideReserved BYTE) + (idePlanes WORD) + (ideBitCount WORD) + (ideBytesInRes DWORD) + (ideImageOffset DWORD))) 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 Mon Aug 7 12:14:19 2006 @@ -140,6 +140,20 @@ (floor quant 257)) ;;; +;;; translated from list.h +;;; + +(defcfun + ("GetFirstImageInList" get-first-image-in-list) + :pointer ;; Image* + (images :pointer)) ;; Image* + +(defcfun + ("GetNextImageInList" get-next-image-in-list) + :pointer ;; Image* + (images :pointer)) ;; Image* + +;;; ;;; translated from magick.h ;;; 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 Mon Aug 7 12:14:19 2006 @@ -36,23 +36,23 @@ (defclass magick-data-plugin (gfg:image-data-plugin) () (:documentation "ImageMagick library plugin for the graphics package.")) -(defun accepts-file-p (path) +(defun loader (path) (unless *magick-initialized* (initialize-magick (cffi:null-pointer)) (setf *magick-initialized* t)) - (cond - ((parse-namestring path)) ; syntax check - ((typep path 'pathname) - (setf path (namestring path))) - (t - (error 'gfs:toolkit-error :detail (format nil "~s must be a string or pathname" path)))) (if (gethash (pathname-type path) gfg:*image-file-types*) - (let ((plugin (make-instance 'magick-data-plugin))) - (gfg:load plugin path) - plugin) + (with-image-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)))) nil)) -(push #'accepts-file-p gfg::*image-plugins*) +(push #'loader gfg::*image-plugins*) (defmethod gfg:data->image ((self magick-data-plugin)) (cffi:with-foreign-object (bi-ptr 'gfs::bitmapinfo) @@ -128,22 +128,6 @@ (destroy-image victim))) (setf (slot-value self 'gfs:handle) nil)) -(defmethod gfg:load ((self magick-data-plugin) path) - (let ((handle (gfs:handle self))) - (when (and handle (not (cffi:null-pointer-p handle))) - (destroy-image handle) - (setf (slot-value self 'gfs:handle) nil) - (setf handle nil)) - (with-image-path (path info ex) - (setf handle (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)))) - (if (cffi:null-pointer-p handle) - (error 'gfs:toolkit-error :detail (format nil "could not load image: ~a" path))) - (setf (slot-value self 'gfs:handle) handle)))) - (defmethod gfg:size ((self magick-data-plugin)) (let ((handle (gfs:handle self)) (size (gfs:make-size)))

1 0

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

05 Aug '06

Author: junrue Date: Fri Aug 4 22:50:30 2006 New Revision: 200 Modified: trunk/src/packages.lisp trunk/src/uitoolkit/graphics/graphics-classes.lisp trunk/src/uitoolkit/graphics/image-data.lisp trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp trunk/src/uitoolkit/system/gdi32.lisp trunk/src/uitoolkit/system/system-types.lisp Log: default graphics data plugin is now working for BMPs Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Fri Aug 4 22:50:30 2006 @@ -193,6 +193,7 @@ #:make-color #:make-font-data #:make-image-data + #:make-palette #:matrix #:maximum-char-width #:metrics Modified: trunk/src/uitoolkit/graphics/graphics-classes.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-classes.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-classes.lisp Fri Aug 4 22:50:30 2006 @@ -79,7 +79,10 @@ (green-shift 0) (blue-shift 0) (direct nil) - (table nil))) ; vector of COLOR structs + (table nil)) ; vector of COLOR structs + + (defmacro color-table (data) + `(gfg::palette-table ,data))) (defclass image-data-plugin (gfs:native-object) () (:documentation "Graphics library plugin implementation objects.")) @@ -151,9 +154,6 @@ (defmacro red-shift (data) `(gfg::palette-red-shift ,data)) -(defmacro color-table (data) - `(gfg::palette-table ,data)) - (defclass pattern (gfs:native-object) () (:documentation "This class represents a pattern to be used with a brush.")) Modified: trunk/src/uitoolkit/graphics/image-data.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/image-data.lisp (original) +++ trunk/src/uitoolkit/graphics/image-data.lisp Fri Aug 4 22:50:30 2006 @@ -34,7 +34,9 @@ (in-package :graphic-forms.uitoolkit.graphics) (eval-when (:compile-toplevel :load-toplevel :execute) - (defvar *image-plugins* nil)) + (defvar *image-plugins* nil) + + (cffi:defctype bmp-pointer :pointer)) ;; ;; list the superset of file extensions for formats that any @@ -193,10 +195,8 @@ (error 'gfs:toolkit-error :detail "pathname or string required")))) (let ((plugin (data-plugin-of self))) - (when plugin - (gfs:dispose plugin) - (setf (slot-value self 'data-plugin) nil)) - (setf plugin (find-image-plugin path)) + (unless plugin + (setf plugin (find-image-plugin path))) (unless plugin (error 'gfs:toolkit-error :detail (format nil "no image data plugin supports: ~a" path))) (load plugin path) 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 Fri Aug 4 22:50:30 2006 @@ -33,9 +33,18 @@ (in-package :graphic-forms.uitoolkit.graphics.default) -(defclass default-data-plugin (gfg:image-data-plugin) () +(defclass default-data-plugin (gfg:image-data-plugin) + ((palette + :accessor palette-of + :initform nil) + (pixels + :accessor pixels-of + :initform nil)) (:documentation "Default library plugin for the graphics package.")) +(defmacro bitmap-pixel-row-length (width bit-count) + `(ash (logand (+ (* ,width ,bit-count) 31) (lognot 31)) -3)) + (defun accepts-file-p (path) (cond ((parse-namestring path)) ; syntax check @@ -44,10 +53,146 @@ (t (error 'gfs:toolkit-error :detail (format nil "~s must be a string or pathname" path)))) (let ((ext (pathname-type path))) - (if (or (string-equal ext "ico") (string-equal ext "bmp")) +; (if (or (string-equal ext "ico") (string-equal ext "bmp")) + (if (string-equal ext "bmp") (let ((plugin (make-instance 'default-data-plugin))) (gfg:load plugin path) plugin) nil))) (push #'accepts-file-p gfg::*image-plugins*) + +(defmethod gfg:data->image ((self default-data-plugin)) + (let ((screen-dc (gfs::get-dc (cffi:null-pointer))) + (hbmp (cffi:null-pointer))) + (unwind-protect + (cffi:with-foreign-object (pix-bits-ptr :pointer) + (setf hbmp (gfs::create-dib-section screen-dc + self + gfs::+dib-rgb-colors+ + pix-bits-ptr + (cffi:null-pointer) + 0)) + (if (gfs:null-handle-p hbmp) + (error 'gfs:win32-error :detail "create-dib-section failed")) + (let ((plugin-pixels (pixels-of self)) + (ptr (cffi:mem-ref pix-bits-ptr :pointer))) + (dotimes (i (length plugin-pixels)) + (setf (cffi:mem-aref ptr :uint8 i) (aref plugin-pixels i))))) + (gfs::release-dc (cffi:null-pointer) screen-dc)) + hbmp)) + +(defmethod gfg:depth ((self default-data-plugin)) + (let ((info (gfs:handle self))) + (unless info + (error 'gfs:disposed-error)) + (biBitCount info))) + +(defmethod gfs:dispose ((self default-data-plugin)) + (setf (slot-value self 'gfs:handle) nil)) + +(defmethod cffi:free-translated-object (pixels-ptr (name (eql 'gfs::bitmap-pixels-pointer)) param) + (declare (ignore param)) + (cffi:foreign-free pixels-ptr)) + +(defmethod cffi:free-translated-object (bi-ptr (name (eql 'gfs::bitmap-info-pointer)) param) + (declare (ignore param)) + (cffi:foreign-free bi-ptr)) + +(defmethod gfg:load ((self default-data-plugin) path) + (with-open-file (in path :element-type '(unsigned-byte 8)) + (let ((header (read-value 'BITMAPFILEHEADER in)) + (info (read-value 'BASE-BITMAPINFOHEADER in))) + (declare (ignore header)) + (unless (= (biCompression info) gfs::+bi-rgb+) + (error 'gfs:toolkit-error :detail "FIXME: non-RGB not yet implemented")) + + ;; load color table + ;; + (let ((used (biClrUsed info)) + (rgbs nil)) + (ecase (biBitCount info) + (1 + (setf rgbs (make-array 2))) + (4 + (if (or (= used 0) (= used 16)) + (setf rgbs (make-array 16)) + (setf rgbs (make-array used)))) + (8 + (if (or (= used 0) (= used 256)) + (setf rgbs (make-array 256)) + (setf rgbs (make-array used)))) + (16 + (unless (/= used 0) + (setf rgbs (make-array used)))) + (24 + (unless (/= used 0) + (setf rgbs (make-array used)))) + (32 + (unless (/= used 0) + (setf rgbs (make-array used))))) + (dotimes (i (length rgbs)) + (let ((quad (read-value 'RGBQUAD in))) + (setf (aref rgbs i) (gfg:make-color :red (rgbRed quad) + :green (rgbGreen quad) + :blue (rgbBlue quad))))) + (setf (palette-of self) (gfg:make-palette :direct nil :table rgbs))) + + ;; load pixel bits + ;; + (let ((row-len (bitmap-pixel-row-length (biWidth info) (biBitCount info)))) + (setf (pixels-of self) (make-array (* row-len (biHeight info)) :element-type '(unsigned-byte 8))) + (read-sequence (pixels-of self) in)) + + ;; complete load + ;; + (setf (slot-value self 'gfs:handle) info)))) + +(defmethod gfg:size ((self default-data-plugin)) + (let ((info (gfs:handle self))) + (unless info + (error 'gfs:disposed-error)) + (gfs:make-size :width (biWidth info) :height (biHeight info)))) + +(defmethod (setf gfg:size) (size (self default-data-plugin)) + (let ((info (gfs:handle self))) + (unless info + (error 'gfs:disposed-error)) + (setf (biWidth info) (gfs:size-width size) + (biHeight info) (gfs:size-height size))) + size) + +(defmethod cffi:translate-to-foreign ((lisp-obj default-data-plugin) + (name (eql 'gfs::bitmap-pixels-pointer))) + (let* ((plugin-pixels (pixels-of lisp-obj)) + (pixels-ptr (cffi:foreign-alloc :uint8 :count (length plugin-pixels)))) + (dotimes (i (length plugin-pixels)) + (setf (cffi:mem-aref pixels-ptr :uint8 i) (aref plugin-pixels i))) + pixels-ptr)) + +(defmethod cffi:translate-to-foreign ((lisp-obj default-data-plugin) + (name (eql 'gfs::bitmapinfo-pointer))) + (let ((bi-ptr (cffi:foreign-alloc 'gfs::bitmapinfo))) + (cffi:with-foreign-slots ((gfs::bisize gfs::biwidth gfs::biheight gfs::biplanes gfs::bibitcount + gfs::bicompression gfs::bmicolors) + bi-ptr gfs::bitmapinfo) + (gfs::zero-mem bi-ptr gfs::bitmapinfo) + (setf gfs::bisize (cffi:foreign-type-size 'gfs::bitmapinfoheader) + gfs::biplanes 1 + gfs::bibitcount (gfg:depth lisp-obj) + gfs::bicompression gfs::+bi-rgb+) + (let ((im-size (gfg:size lisp-obj))) + (setf gfs::biwidth (gfs:size-width im-size) + gfs::biheight (gfs:size-height im-size))) + (let ((colors (gfg:color-table (palette-of lisp-obj))) + (ptr (cffi:foreign-slot-pointer bi-ptr 'gfs::bitmapinfo 'gfs::bmicolors))) + (dotimes (i (length colors)) + (let ((clr (aref colors i))) + (cffi:with-foreign-slots ((gfs::rgbblue gfs::rgbgreen + gfs::rgbred gfs::rgbreserved) + (cffi:mem-aref ptr 'gfs::rgbquad i) gfs::rgbquad) + (setf gfs::rgbblue (gfg:color-blue clr) + gfs::rgbgreen (gfg:color-green clr) + gfs::rgbred (gfg:color-red clr) + gfs::rgbreserved 0)))))) + bi-ptr)) 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 Fri Aug 4 22:50:30 2006 @@ -55,7 +55,6 @@ (push #'accepts-file-p gfg::*image-plugins*) (defmethod gfg:data->image ((self magick-data-plugin)) - "Convert the image-data object to a bitmap and return the native handle." (cffi:with-foreign-object (bi-ptr 'gfs::bitmapinfo) (cffi:with-foreign-slots ((gfs::bisize gfs::biwidth @@ -127,7 +126,7 @@ (let ((victim (gfs:handle self))) (unless (or (null victim) (cffi:null-pointer-p victim)) (destroy-image victim))) - (setf (slot-value self 'gfs:handle) (cffi:null-pointer))) + (setf (slot-value self 'gfs:handle) nil)) (defmethod gfg:load ((self magick-data-plugin) path) (let ((handle (gfs:handle self))) @@ -176,4 +175,5 @@ 'reason)))) (setf (slot-value self 'gfs:handle) new-handle) (destroy-image handle)) - (destroy-exception-info ex)))) + (destroy-exception-info ex))) + size) Modified: trunk/src/uitoolkit/system/gdi32.lisp ============================================================================== --- trunk/src/uitoolkit/system/gdi32.lisp (original) +++ trunk/src/uitoolkit/system/gdi32.lisp Fri Aug 4 22:50:30 2006 @@ -117,7 +117,7 @@ (hdc HANDLE) (pheader LPTR) (option DWORD) - (pinit LPTR) + (pinit bitmap-pixels-pointer) (pbmp LPTR) (usage UINT)) @@ -125,7 +125,7 @@ ("CreateDIBSection" create-dib-section) HANDLE (hdc HANDLE) - (bmi LPTR) + (bmi bitmapinfo-pointer) (usage UINT) (values LPTR) ;; VOID ** (section HANDLE) Modified: trunk/src/uitoolkit/system/system-types.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-types.lisp (original) +++ trunk/src/uitoolkit/system/system-types.lisp Fri Aug 4 22:50:30 2006 @@ -114,6 +114,9 @@ (biclrimp DWORD) (bmicolors BYTE :count 1024)) ; allocate space for max palette (256 RGBQUADs) +(defctype bitmapinfo-pointer :pointer) +(defctype bitmap-pixels-pointer :pointer) + (defcstruct bitmapinfoheader (bisize DWORD) (biwidth LONG)

1 0

[graphic-forms-cvs] r199 - in trunk: . src/external-libraries src/external-libraries/practicals-1.0.3 src/external-libraries/practicals-1.0.3/Chapter08 src/external-libraries/practicals-1.0.3/Chapter24 src/uitoolkit/graphics src/uitoolkit/graphics/plugins src/uitoolkit/graphics/plugins/default
by junrue＠common-lisp.net 02 Aug '06

02 Aug '06

Author: junrue Date: Wed Aug 2 17:37:56 2006 New Revision: 199 Added: trunk/src/external-libraries/ trunk/src/external-libraries/practicals-1.0.3/ trunk/src/external-libraries/practicals-1.0.3/Chapter08/ trunk/src/external-libraries/practicals-1.0.3/Chapter08/chapter-8.asd trunk/src/external-libraries/practicals-1.0.3/Chapter08/macro-utilities.asd trunk/src/external-libraries/practicals-1.0.3/Chapter08/macro-utilities.lisp trunk/src/external-libraries/practicals-1.0.3/Chapter08/packages.lisp trunk/src/external-libraries/practicals-1.0.3/Chapter24/ trunk/src/external-libraries/practicals-1.0.3/Chapter24/binary-data.asd trunk/src/external-libraries/practicals-1.0.3/Chapter24/binary-data.lisp trunk/src/external-libraries/practicals-1.0.3/Chapter24/chapter-24.asd trunk/src/external-libraries/practicals-1.0.3/Chapter24/packages.lisp trunk/src/external-libraries/practicals-1.0.3/LICENSE trunk/src/external-libraries/practicals-1.0.3/readme.txt trunk/src/uitoolkit/graphics/plugins/default/ trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp trunk/src/uitoolkit/graphics/plugins/default/file-formats.lisp Modified: trunk/build.lisp trunk/config.lisp trunk/graphic-forms-uitoolkit.asd trunk/src/uitoolkit/graphics/image-data.lisp trunk/src/uitoolkit/graphics/plugins/graphics-plugin-packages.lisp Log: initial work on default graphics data plugin Modified: trunk/build.lisp ============================================================================== --- trunk/build.lisp (original) +++ trunk/build.lisp Wed Aug 2 17:37:56 2006 @@ -44,14 +44,16 @@ (defvar *asdf-repo-root* (concatenate 'string *library-root* "asdf-repo/")) (defvar *project-root* "c:/projects/public/") -(setf *cells-dir* (concatenate 'string *asdf-repo-root* "cells/")) -(setf *cffi-dir* (concatenate 'string *asdf-repo-root* "cffi-060606/")) -(setf *closer-mop-dir* (concatenate 'string *asdf-repo-root* "closer-mop/")) -(setf *lw-compat-dir* (concatenate 'string *asdf-repo-root* "lw-compat/")) -(setf *gf-dir* (concatenate 'string *project-root* "graphic-forms/")) -(setf *lisp-unit-file* (concatenate 'string *library-root* "lisp-unit")) +(setf *cells-dir* (concatenate 'string *asdf-repo-root* "cells/")) +(setf *cffi-dir* (concatenate 'string *asdf-repo-root* "cffi-060606/")) +(setf *closer-mop-dir* (concatenate 'string *asdf-repo-root* "closer-mop/")) +(setf *lw-compat-dir* (concatenate 'string *asdf-repo-root* "lw-compat/")) +(setf *gf-dir* (concatenate 'string *project-root* "graphic-forms/")) +(setf *lisp-unit-file* (concatenate 'string *library-root* "lisp-unit")) +(setf *binary-data-dir* (concatenate 'string *gf-dir* "src/external-libraries/practicals-1.0.3/Chapter08/")) +(setf *macro-utilities-dir* (concatenate 'string *gf-dir* "src/external-libraries/practicals-1.0.3/Chapter24/")) -(defvar *gf-tests-dir* (concatenate 'string *gf-dir* "src/tests/uitoolkit/")) +(defvar *gf-tests-dir* (concatenate 'string *gf-dir* "src/tests/uitoolkit/")) (defun build () (setf cl-user::*asdf-cache* "c:/projects/public/build/") Modified: trunk/config.lisp ============================================================================== --- trunk/config.lisp (original) +++ trunk/config.lisp Wed Aug 2 17:37:56 2006 @@ -39,16 +39,20 @@ (in-package #:graphic-forms-system) -(defvar *cells-dir* "cells/") -(defvar *cffi-dir* "cffi-060606/") -(defvar *closer-mop-dir* "closer-mop/") -(defvar *lw-compat-dir* "lw-compat/") -(defvar *gf-dir* "graphic-forms/") +(defvar *binary-data-dir* (merge-pathnames "src/external-libraries/practicals-1.0.3/binary-data/")) +(defvar *cells-dir* "cells/") +(defvar *cffi-dir* "cffi-060606/") +(defvar *closer-mop-dir* "closer-mop/") +(defvar *lw-compat-dir* "lw-compat/") +(defvar *macro-utilities-dir* "macro-utilities/") +(defvar *gf-dir* "graphic-forms/") -(defvar *lisp-unit-file* "lisp-unit") +(defvar *lisp-unit-file* "lisp-unit") (defun configure-asdf () - (pushnew *cells-dir* asdf:*central-registry* :test #'equal) - (pushnew *cffi-dir* asdf:*central-registry* :test #'equal) - (pushnew *closer-mop-dir* asdf:*central-registry* :test #'equal) - (pushnew *lw-compat-dir* asdf:*central-registry* :test #'equal)) + (pushnew *binary-data-dir* asdf:*central-registry* :test #'equal) + (pushnew *cells-dir* asdf:*central-registry* :test #'equal) + (pushnew *cffi-dir* asdf:*central-registry* :test #'equal) + (pushnew *closer-mop-dir* asdf:*central-registry* :test #'equal) + (pushnew *lw-compat-dir* asdf:*central-registry* :test #'equal) + (pushnew *macro-utilities-dir* asdf:*central-registry* :test #'equal)) Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Wed Aug 2 17:37:56 2006 @@ -42,7 +42,7 @@ :version "0.3.0" :author "Jack D. Unrue" :licence "BSD" - :depends-on ("cffi" "lw-compat" "closer-mop") + :depends-on ("cffi" "lw-compat" "closer-mop" "macro-utilities" "binary-data") :components ((:module "src" :components @@ -82,14 +82,16 @@ (:module "plugins" :components ((:file "graphics-plugin-packages") -#+load-imagemagick-plugin - (:module "imagemagick" - ; :depends-on ("graphics") - :components - ((:file "magick-core-types") - (:file "magick-core-api") - (:file "magick-data-plugin" - :depends-on ("magick-core-types" "magick-core-api")))))))) +#-skip-default-plugin (:module "default" + :components + ((:file "file-formats") + (:file "default-data-plugin"))) +#+load-imagemagick-plugin (:module "imagemagick" + :components + ((:file "magick-core-types") + (:file "magick-core-api") + (:file "magick-data-plugin" + :depends-on ("magick-core-types" "magick-core-api")))))))) (:module "widgets" :depends-on ("graphics") :components Added: trunk/src/external-libraries/practicals-1.0.3/Chapter08/chapter-8.asd ============================================================================== --- (empty file) +++ trunk/src/external-libraries/practicals-1.0.3/Chapter08/chapter-8.asd Wed Aug 2 17:37:56 2006 @@ -0,0 +1,14 @@ +(defpackage :com.gigamonkeys.chapter-8-system (:use :asdf :cl)) +(in-package :com.gigamonkeys.chapter-8-system) + +(defsystem chapter-8 + :name "chapter-8" + :author "Peter Seibel <peter(a)gigamonkeys.com>" + :version "1.0" + :maintainer "Peter Seibel <peter(a)gigamonkeys.com>" + :licence "BSD" + :description "Code from Chapter 8 of Practical Common Lisp" + :long-description "" + :depends-on ("macro-utilities")) + + Added: trunk/src/external-libraries/practicals-1.0.3/Chapter08/macro-utilities.asd ============================================================================== --- (empty file) +++ trunk/src/external-libraries/practicals-1.0.3/Chapter08/macro-utilities.asd Wed Aug 2 17:37:56 2006 @@ -0,0 +1,17 @@ +(defpackage :com.gigamonkeys.macro-utilities-system (:use :asdf :cl)) +(in-package :com.gigamonkeys.macro-utilities-system) + +(defsystem macro-utilities + :name "macro-utilities" + :author "Peter Seibel <peter(a)gigamonkeys.com>" + :version "1.0" + :maintainer "Peter Seibel <peter(a)gigamonkeys.com>" + :licence "BSD" + :description "Utilities for writing macros" + :long-description "" + :components + ((:file "packages") + (:file "macro-utilities" :depends-on ("packages"))) + :depends-on ()) + + Added: trunk/src/external-libraries/practicals-1.0.3/Chapter08/macro-utilities.lisp ============================================================================== --- (empty file) +++ trunk/src/external-libraries/practicals-1.0.3/Chapter08/macro-utilities.lisp Wed Aug 2 17:37:56 2006 @@ -0,0 +1,28 @@ +(in-package :com.gigamonkeys.macro-utilities) + +(defmacro with-gensyms ((&rest names) &body body) + `(let ,(loop for n in names collect `(,n (make-symbol ,(string n)))) + ,@body)) + +(defmacro once-only ((&rest names) &body body) + (let ((gensyms (loop for n in names collect (gensym (string n))))) + `(let (,@(loop for g in gensyms collect `(,g (gensym)))) + `(let (,,@(loop for g in gensyms for n in names collect ``(,,g ,,n))) + ,(let (,@(loop for n in names for g in gensyms collect `(,n ,g))) + ,@body))))) + +(defun spliceable (value) + (if value (list value))) + +(defmacro ppme (form &environment env) + (progn + (write (macroexpand-1 form env) + :length nil + :level nil + :circle nil + :pretty t + :gensym nil + :right-margin 83 + :case :downcase) + nil)) + Added: trunk/src/external-libraries/practicals-1.0.3/Chapter08/packages.lisp ============================================================================== --- (empty file) +++ trunk/src/external-libraries/practicals-1.0.3/Chapter08/packages.lisp Wed Aug 2 17:37:56 2006 @@ -0,0 +1,11 @@ +(in-package :cl-user) + +(defpackage :com.gigamonkeys.macro-utilities + (:use :common-lisp) + (:export + :with-gensyms + :with-gensymed-defuns + :once-only + :spliceable + :ppme)) + Added: trunk/src/external-libraries/practicals-1.0.3/Chapter24/binary-data.asd ============================================================================== --- (empty file) +++ trunk/src/external-libraries/practicals-1.0.3/Chapter24/binary-data.asd Wed Aug 2 17:37:56 2006 @@ -0,0 +1,17 @@ +(defpackage :com.gigamonkeys.binary-data-system (:use :asdf :cl)) +(in-package :com.gigamonkeys.binary-data-system) + +(defsystem binary-data + :name "binary-data" + :author "Peter Seibel <peter(a)gigamonkeys.com>" + :version "1.0" + :maintainer "Peter Seibel <peter(a)gigamonkeys.com>" + :licence "BSD" + :description "Parser for binary data files. " + :long-description "" + :components + ((:file "packages") + (:file "binary-data" :depends-on ("packages"))) + :depends-on (:macro-utilities)) + + Added: trunk/src/external-libraries/practicals-1.0.3/Chapter24/binary-data.lisp ============================================================================== --- (empty file) +++ trunk/src/external-libraries/practicals-1.0.3/Chapter24/binary-data.lisp Wed Aug 2 17:37:56 2006 @@ -0,0 +1,160 @@ +(in-package :com.gigamonkeys.binary-data) + +(defvar *in-progress-objects* nil) + +(defconstant +null+ (code-char 0)) + +(defgeneric read-value (type stream &key) + (:documentation "Read a value of the given type from the stream.")) + +(defgeneric write-value (type stream value &key) + (:documentation "Write a value as the given type to the stream.")) + +(defgeneric read-object (object stream) + (:method-combination progn :most-specific-last) + (:documentation "Fill in the slots of object from stream.")) + +(defgeneric write-object (object stream) + (:method-combination progn :most-specific-last) + (:documentation "Write out the slots of object to the stream.")) + +(defmethod read-value ((type symbol) stream &key) + (let ((object (make-instance type))) + (read-object object stream) + object)) + +(defmethod write-value ((type symbol) stream value &key) + (assert (typep value type)) + (write-object value stream)) + + +;;; Binary types + +(defmacro define-binary-type (name (&rest args) &body spec) + (with-gensyms (type stream value) + `(progn + (defmethod read-value ((,type (eql ',name)) ,stream &key ,@args) + (declare (ignorable ,@args)) + ,(type-reader-body spec stream)) + (defmethod write-value ((,type (eql ',name)) ,stream ,value &key ,@args) + (declare (ignorable ,@args)) + ,(type-writer-body spec stream value))))) + +(defun type-reader-body (spec stream) + (ecase (length spec) + (1 (destructuring-bind (type &rest args) (mklist (first spec)) + `(read-value ',type ,stream ,@args))) + (2 (destructuring-bind ((in) &body body) (cdr (assoc :reader spec)) + `(let ((,in ,stream)) ,@body))))) + +(defun type-writer-body (spec stream value) + (ecase (length spec) + (1 (destructuring-bind (type &rest args) (mklist (first spec)) + `(write-value ',type ,stream ,value ,@args))) + (2 (destructuring-bind ((out v) &body body) (cdr (assoc :writer spec)) + `(let ((,out ,stream) (,v ,value)) ,@body))))) + + +;;; Binary classes + +(defmacro define-generic-binary-class (name (&rest superclasses) slots read-method) + (with-gensyms (objectvar streamvar) + `(progn + (eval-when (:compile-toplevel :load-toplevel :execute) + (setf (get ',name 'slots) ',(mapcar #'first slots)) + (setf (get ',name 'superclasses) ',superclasses)) + + (defclass ,name ,superclasses + ,(mapcar #'slot->defclass-slot slots)) + + ,read-method + + (defmethod write-object progn ((,objectvar ,name) ,streamvar) + (declare (ignorable ,streamvar)) + (with-slots ,(new-class-all-slots slots superclasses) ,objectvar + ,@(mapcar #'(lambda (x) (slot->write-value x streamvar)) slots)))))) + +(defmacro define-binary-class (name (&rest superclasses) slots) + (with-gensyms (objectvar streamvar) + `(define-generic-binary-class ,name ,superclasses ,slots + (defmethod read-object progn ((,objectvar ,name) ,streamvar) + (declare (ignorable ,streamvar)) + (with-slots ,(new-class-all-slots slots superclasses) ,objectvar + ,@(mapcar #'(lambda (x) (slot->read-value x streamvar)) slots)))))) + +(defmacro define-tagged-binary-class (name (&rest superclasses) slots &rest options) + (with-gensyms (typevar objectvar streamvar) + `(define-generic-binary-class ,name ,superclasses ,slots + (defmethod read-value ((,typevar (eql ',name)) ,streamvar &key) + (let* ,(mapcar #'(lambda (x) (slot->binding x streamvar)) slots) + (let ((,objectvar + (make-instance + ,@(or (cdr (assoc :dispatch options)) + (error "Must supply :disptach form.")) + ,@(mapcan #'slot->keyword-arg slots)))) + (read-object ,objectvar ,streamvar) + ,objectvar)))))) + +(defun as-keyword (sym) (intern (string sym) :keyword)) + +(defun normalize-slot-spec (spec) + (list (first spec) (mklist (second spec)))) + +(defun mklist (x) (if (listp x) x (list x))) + +(defun slot->defclass-slot (spec) + (let ((name (first spec))) + `(,name :initarg ,(as-keyword name) :accessor ,name))) + +(defun slot->read-value (spec stream) + (destructuring-bind (name (type &rest args)) (normalize-slot-spec spec) + `(setf ,name (read-value ',type ,stream ,@args)))) + +(defun slot->write-value (spec stream) + (destructuring-bind (name (type &rest args)) (normalize-slot-spec spec) + `(write-value ',type ,stream ,name ,@args))) + +(defun slot->binding (spec stream) + (destructuring-bind (name (type &rest args)) (normalize-slot-spec spec) + `(,name (read-value ',type ,stream ,@args)))) + +(defun slot->keyword-arg (spec) + (let ((name (first spec))) + `(,(as-keyword name) ,name))) + +;;; Keeping track of inherited slots + +(defun direct-slots (name) + (copy-list (get name 'slots))) + +(defun inherited-slots (name) + (loop for super in (get name 'superclasses) + nconc (direct-slots super) + nconc (inherited-slots super))) + +(defun all-slots (name) + (nconc (direct-slots name) (inherited-slots name))) + +(defun new-class-all-slots (slots superclasses) + "Like all slots but works while compiling a new class before slots +and superclasses have been saved." + (nconc (mapcan #'all-slots superclasses) (mapcar #'first slots))) + +;;; In progress Object stack + +(defun current-binary-object () + (first *in-progress-objects*)) + +(defun parent-of-type (type) + (find-if #'(lambda (x) (typep x type)) *in-progress-objects*)) + +(defmethod read-object :around (object stream) + (declare (ignore stream)) + (let ((*in-progress-objects* (cons object *in-progress-objects*))) + (call-next-method))) + +(defmethod write-object :around (object stream) + (declare (ignore stream)) + (let ((*in-progress-objects* (cons object *in-progress-objects*))) + (call-next-method))) + Added: trunk/src/external-libraries/practicals-1.0.3/Chapter24/chapter-24.asd ============================================================================== --- (empty file) +++ trunk/src/external-libraries/practicals-1.0.3/Chapter24/chapter-24.asd Wed Aug 2 17:37:56 2006 @@ -0,0 +1,14 @@ +(defpackage :com.gigamonkeys.chapter-24-system (:use :asdf :cl)) +(in-package :com.gigamonkeys.chapter-24-system) + +(defsystem chapter-24 + :name "chapter-24" + :author "Peter Seibel <peter(a)gigamonkeys.com>" + :version "1.0" + :maintainer "Peter Seibel <peter(a)gigamonkeys.com>" + :licence "BSD" + :description "Code from Chapter 24 of Practical Common Lisp" + :long-description "" + :depends-on ("binary-data")) + + Added: trunk/src/external-libraries/practicals-1.0.3/Chapter24/packages.lisp ============================================================================== --- (empty file) +++ trunk/src/external-libraries/practicals-1.0.3/Chapter24/packages.lisp Wed Aug 2 17:37:56 2006 @@ -0,0 +1,13 @@ +(in-package :cl-user) + +(defpackage :com.gigamonkeys.binary-data + (:use :common-lisp :com.gigamonkeys.macro-utilities) + (:export :define-binary-class + :define-tagged-binary-class + :define-binary-type + :read-value + :write-value + :*in-progress-objects* + :parent-of-type + :current-binary-object + :+null+)) Added: trunk/src/external-libraries/practicals-1.0.3/LICENSE ============================================================================== --- (empty file) +++ trunk/src/external-libraries/practicals-1.0.3/LICENSE Wed Aug 2 17:37:56 2006 @@ -0,0 +1,29 @@ +Copyright (c) 2005, Peter Seibel All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * 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. + + * Neither the name of the Peter Seibel 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 COPYRIGHT HOLDERS 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 DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR 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. Added: trunk/src/external-libraries/practicals-1.0.3/readme.txt ============================================================================== --- (empty file) +++ trunk/src/external-libraries/practicals-1.0.3/readme.txt Wed Aug 2 17:37:56 2006 @@ -0,0 +1,12 @@ +This directory contains a subset of the source code for +_Practical Common Lisp_ by Peter Seibel. The subset consists +of the code from two chapters of that book: Chapter 8 defining +a set of macro utilities that is needed by the binary file +input/output library featured in Chapter 24. + +The LICENSE file contains Peter Seibel's license statement +for this code. + +The complete distribution may be downloaded from: + + http://gigamonkeys.com/book/practicals-1.0.3.zip Modified: trunk/src/uitoolkit/graphics/image-data.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/image-data.lisp (original) +++ trunk/src/uitoolkit/graphics/image-data.lisp Wed Aug 2 17:37:56 2006 @@ -33,7 +33,8 @@ (in-package :graphic-forms.uitoolkit.graphics) -(defvar *image-plugins* nil) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defvar *image-plugins* nil)) ;; ;; list the superset of file extensions for formats that any Added: trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp Wed Aug 2 17:37:56 2006 @@ -0,0 +1,53 @@ +;;;; +;;;; default-data-plugin.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.default) + +(defclass default-data-plugin (gfg:image-data-plugin) () + (:documentation "Default library plugin for the graphics package.")) + +(defun accepts-file-p (path) + (cond + ((parse-namestring path)) ; syntax check + ((typep path 'pathname) + (setf path (namestring path))) + (t + (error 'gfs:toolkit-error :detail (format nil "~s must be a string or pathname" path)))) + (let ((ext (pathname-type path))) + (if (or (string-equal ext "ico") (string-equal ext "bmp")) + (let ((plugin (make-instance 'default-data-plugin))) + (gfg:load plugin path) + plugin) + nil))) + +(push #'accepts-file-p gfg::*image-plugins*) Added: trunk/src/uitoolkit/graphics/plugins/default/file-formats.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/graphics/plugins/default/file-formats.lisp Wed Aug 2 17:37:56 2006 @@ -0,0 +1,140 @@ +;;;; +;;;; file-formats.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.default) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (use-package :com.gigamonkeys.binary-data)) + +;;; +;;; fundamental binary types used by image definitions +;;; + +;; This utility was copied from Peter Seibel's id3v2 package, +;; renamed to signify that it is for big-endian values. +;; +(define-binary-type unsigned-integer-be (bytes bits-per-byte) + (:reader (in) + (loop with value = 0 + for low-bit downfrom (* bits-per-byte (1- bytes)) to 0 by bits-per-byte do + (setf (ldb (byte bits-per-byte low-bit) value) (read-byte in)) + finally (return value))) + (:writer (out value) + (loop for low-bit downfrom (* bits-per-byte (1- bytes)) to 0 by bits-per-byte + do (write-byte (ldb (byte bits-per-byte low-bit) value) out)))) + +;; This utility is based on the same unsigned-integer binary type, +;; but this one is for little-endian types. +;; +(define-binary-type unsigned-integer-le (bytes bits-per-byte) + (:reader (in) + (loop with value = 0 + for low-bit from 0 to (* bits-per-byte (1- bytes)) by bits-per-byte do + (setf (ldb (byte bits-per-byte low-bit) value) (read-byte in)) + finally (return value))) + (:writer (out value) + (loop for low-bit from 0 to (* bits-per-byte (1- bytes)) by bits-per-byte + do (write-byte (ldb (byte bits-per-byte low-bit) value) out)))) + +;;; aliases for single-byte and 32-bit types with names +;;; matching the GDI docs +;;; +(define-binary-type BYTE () (unsigned-integer-le :bytes 1 :bits-per-byte 8)) +(define-binary-type DWORD () (unsigned-integer-le :bytes 4 :bits-per-byte 8)) +(define-binary-type FXPT2DOT30 () (unsigned-integer-le :bytes 4 :bits-per-byte 8)) +(define-binary-type LONG () (unsigned-integer-le :bytes 4 :bits-per-byte 8)) +(define-binary-type WORD () (unsigned-integer-le :bytes 2 :bits-per-byte 8)) + +;;; +;;; Win32 GDI Bitmap Formats +;;; + +(define-binary-class BITMAPFILEHEADER () + ((bfType WORD) + (bfSize DWORD) + (bfReserved1 WORD) + (bfReserved2 WORD) + (bfOffBits DWORD))) + +(define-binary-class CIEXYZ () + ((ciexyzX FXPT2DOT30) + (ciexyzY FXPT2DOT30) + (ciexyzZ FXPT2DOT30))) + +(define-binary-class CIEXYZTRIPLE () + ((ciexyzRed CIEXYZ) + (ciexyzGreen CIEXYZ) + (ciexyzBlue CIEXYZ))) + +(define-tagged-binary-class BASE-BITMAPINFOHEADER () + ((biSize DWORD) + (biWidth LONG) + (biHeight LONG) + (biPlanes WORD) + (biBitCount WORD) + (biCompression DWORD) + (biSizeImage DWORD) + (biXPelsPerMeter LONG) + (biYPelsPerMeter LONG) + (biClrUsed DWORD) + (biClrImportant DWORD)) + (:dispatch + (ecase biSize + (40 'BITMAPINFOHEADER) + (120 'BITMAPV4HEADER) + (124 'BITMAPV5HEADER)))) + +(define-binary-class BITMAPINFOHEADER (BASE-BITMAPINFOHEADER) ()) + +(define-binary-class BITMAPV4HEADER (BASE-BITMAPINFOHEADER) + ((bv4RedMask DWORD) + (bv4GreenMask DWORD) + (bv4BlueMask DWORD) + (bv4AlphaMask DWORD) + (bv4CSType DWORD) + (bv4Endpoints CIEXYZTRIPLE) + (bv4GammaRed DWORD) + (bv4GammaGreen DWORD) + (bv4GammaBlue DWORD))) + +(define-binary-class BITMAPV5HEADER (BITMAPV4HEADER) + ((bv5Intent DWORD) + (bv5ProfileData DWORD) + (bv5ProfileSize DWORD) + (bv5Reserved DWORD))) + +(define-binary-class RGBQUAD () + ((rgbBlue BYTE) + (rgbGreen BYTE) + (rgbRed BYTE) + (rgbReserved BYTE))) Modified: trunk/src/uitoolkit/graphics/plugins/graphics-plugin-packages.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/plugins/graphics-plugin-packages.lisp (original) +++ trunk/src/uitoolkit/graphics/plugins/graphics-plugin-packages.lisp Wed Aug 2 17:37:56 2006 @@ -34,10 +34,10 @@ (in-package #:cl-user) ;;; -;;; package for base Win32 graphics plugin +;;; package for default Win32 graphics plugin ;;; -(defpackage #:graphic-forms.uitoolkit.graphics.win32 - (:nicknames #:gfgw32) +(defpackage #:graphic-forms.uitoolkit.graphics.default + (:nicknames #:gfgd) (:shadow #:load #:type) (:use #:common-lisp) (:export

1 0