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