[graphic-forms-cvs] r201 - in trunk: . docs/manual src/uitoolkit/graphics src/uitoolkit/graphics/plugins/default src/uitoolkit/graphics/plugins/imagemagick
junrue at common-lisp.net
junrue at common-lisp.net
Mon Aug 7 16:14:20 UTC 2006
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
- at deffn GenericFunction metrics self font
-Returns a @ref{font-metrics} object describing key attributes of @code{font}.
+ at deffn GenericFunction load self path => list
+Certain graphics objects have a persistent representation, which may
+be deserialized with the appropriate implementation of this function.
+ at 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:}
+ at sc{gfg:load} shadows @sc{cl:load}.
@end deffn
- at deffn GenericFunction size self
-Returns a size object describing the dimensions of the object.
+ at 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}.
+ at end deffn
+
+ at 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)))
More information about the Graphic-forms-cvs
mailing list