Author: junrue Date: Mon Aug 21 17:23:22 2006 New Revision: 229
Modified: trunk/src/packages.lisp trunk/src/uitoolkit/graphics/graphics-generics.lisp trunk/src/uitoolkit/graphics/icon-bundle.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-core-api.lisp trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-core-types.lisp trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp Log: refactored graphics plugins slightly for common code
Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Mon Aug 21 17:23:22 2006 @@ -151,7 +151,7 @@ #:copy-color #:copy-font-data #:copy-font-metrics - #:data->image + #:copy-pixels #:data-object #:depth #:descent
Modified: trunk/src/uitoolkit/graphics/graphics-generics.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-generics.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-generics.lisp Mon Aug 21 17:23:22 2006 @@ -39,9 +39,6 @@ (defgeneric (setf background-color) (color self) (:documentation "Sets the current background color."))
-(defgeneric data->image (self) - (:documentation "Plugins implement this to translate from a data structure to an HGDIOBJ.")) - (defgeneric data-object (self &optional gc) (:documentation "Returns the data structure representing the raw form of self."))
@@ -132,6 +129,9 @@ (defgeneric metrics (self font) (:documentation "Returns a font-metrics object describing key attributes of the specified font."))
+(defgeneric obtain-pixels (self pixels-pointer) + (:documentation "Plugins implement this to populate pixels-pointer with image pixel data.")) + (defgeneric size (self) (:documentation "Returns a size object describing the dimensions of self."))
Modified: trunk/src/uitoolkit/graphics/icon-bundle.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/icon-bundle.lisp (original) +++ trunk/src/uitoolkit/graphics/icon-bundle.lisp Mon Aug 21 17:23:22 2006 @@ -166,7 +166,7 @@ ((typep file 'pathname) (let ((data (load-image-data file))) (setf image-list (loop for entry in data - collect (make-instance 'gfg:image :handle (data->image entry)))))) + collect (make-instance 'gfg:image :handle (plugin->image entry)))))) ((listp images) (setf image-list images))) (when image-list
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 21 17:23:22 2006 @@ -78,12 +78,47 @@ ;;; helper functions ;;;
+(defun make-initial-bitmapinfo (plugin) + (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 (depth plugin) + gfs::bicompression gfs::+bi-rgb+) + (let ((im-size (size plugin))) + (setf gfs::biwidth (gfs:size-width im-size) + gfs::biheight (- (gfs:size-height im-size))))) + bi-ptr)) + (defun load-image-data (path) (loop for loader in *image-plugins* for data = (funcall loader path) until data finally (return data)))
+(defun plugin->image (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 + plugin + 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")) + (copy-pixels plugin (cffi:mem-ref pix-bits-ptr :pointer))) + (gfs::release-dc (cffi:null-pointer) screen-dc)) + hbmp)) + +(defun data->image (self) + (plugin->image (data-plugin-of self))) + (defun image->data (hbmp) (declare (ignore hbmp))) #| (defun image->data (hbmp) @@ -175,9 +210,6 @@ ;;; methods ;;;
-(defmethod data->image ((self image-data)) - (data->image (data-plugin-of self))) - (defmethod depth ((self image-data)) (depth (data-plugin-of self)))
@@ -208,7 +240,7 @@ (size (data-plugin-of self)))
(defmethod (setf size) (size (self image-data)) - (setf (gfg:size (data-plugin-of self)) size)) + (setf (size (data-plugin-of self)) size))
(defmethod print-object ((self image-data) stream) (if (or (null (gfs:handle self)) (cffi:null-pointer-p (gfs:handle 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 21 17:23:22 2006 @@ -114,26 +114,6 @@
(push #'loader 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 @@ -143,59 +123,42 @@ (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:copy-pixels ((self default-data-plugin) pixels-pointer) + (let ((plugin-pixels (pixels-of self))) + (dotimes (i (length plugin-pixels)) + (setf (cffi:mem-aref pixels-pointer :uint8 i) (aref plugin-pixels i)))) + pixels-pointer) + (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)))) + (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))) + (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)))))) + (let ((bi-ptr (gfg::make-initial-bitmapinfo lisp-obj)) + (colors (gfg:color-table (palette-of lisp-obj)))) + (let ((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::rgbreserved 0 + gfs::rgbblue (gfg:color-blue clr) + gfs::rgbgreen (gfg:color-green clr) + gfs::rgbred (gfg:color-red clr)))))) bi-ptr))
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 21 17:23:22 2006 @@ -136,6 +136,11 @@ (width :unsigned-long) (height :unsigned-long))
+(defcfun + ("GetIndexes" get-indexes) + :pointer ;; IndexPacket* + (image :pointer)) ;; Image* + (defun scale-quantum-to-byte (quant) (floor quant 257))
Modified: trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-core-types.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-core-types.lisp (original) +++ trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-core-types.lisp Mon Aug 21 17:23:22 2006 @@ -63,6 +63,8 @@
(defctype quantum :unsigned-short)
+(defctype index-packet quantum) + (defcenum boolean-type (:false 0) (:true 1))
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 21 17:23:22 2006 @@ -54,73 +54,16 @@
(push #'loader gfg::*image-plugins*)
-(defmethod gfg:data->image ((self magick-data-plugin)) - (cffi:with-foreign-object (bi-ptr 'gfs::bitmapinfo) - (cffi:with-foreign-slots ((gfs::bisize - gfs::biwidth - gfs::biheight - gfs::biplanes - gfs::bibitcount - gfs::bicompression - gfs::bisizeimage - gfs::bixpels - gfs::biypels - gfs::biclrused - gfs::biclrimp - gfs::bmicolors) - bi-ptr gfs::bitmapinfo) - (let* ((handle (gfs:handle self)) - (sz (gfg:size self)) - (pix-count (* (gfs:size-width sz) (gfs:size-height sz))) - (hbmp (cffi:null-pointer)) - (screen-dc (gfs::get-dc (cffi:null-pointer)))) - (setf gfs::bisize (cffi:foreign-type-size 'gfs::bitmapinfoheader) - gfs::biwidth (gfs:size-width sz) - gfs::biheight (- 0 (gfs:size-height sz)) - gfs::biplanes 1 - gfs::bibitcount 32 ;; 32bpp even if original image file is not - gfs::bicompression gfs::+bi-rgb+ - gfs::bisizeimage 0 - gfs::bixpels 0 - gfs::biypels 0 - gfs::biclrused 0 - gfs::biclrimp 0) - - ;; create the bitmap - ;; - (cffi:with-foreign-object (pix-bits-ptr :pointer) - (setf hbmp (gfs::create-dib-section screen-dc - bi-ptr - 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")) - - ;; update the RGBQUADs - ;; - (let ((tmp (get-image-pixels handle 0 0 (gfs:size-width sz) (gfs:size-height sz))) - (ptr (cffi:mem-ref pix-bits-ptr :pointer))) - (dotimes (i pix-count) - (cffi:with-foreign-slots ((blue green red reserved) - (cffi:mem-aref tmp 'pixel-packet i) - pixel-packet) - (cffi:with-foreign-slots ((gfs::rgbred gfs::rgbgreen gfs::rgbblue gfs::rgbreserved) - (cffi:mem-aref ptr 'gfs::rgbquad i) gfs::rgbquad) - (setf gfs::rgbreserved 0) - (setf gfs::rgbred (scale-quantum-to-byte red)) - (setf gfs::rgbgreen (scale-quantum-to-byte green)) - (setf gfs::rgbblue (scale-quantum-to-byte blue))))))) - (unless (gfs:null-handle-p screen-dc) - (gfs::release-dc (cffi:null-pointer) screen-dc)) - hbmp)))) - (defmethod gfg:depth ((self magick-data-plugin)) + ;; FIXME: further debugging of non-true-color format required throughout + ;; this plugin, reverting back to assumption of 32bpp for now. +#| (let ((handle (gfs:handle self))) (if (null handle) (error 'gfs:disposed-error)) (cffi:foreign-slot-value handle 'magick-image 'depth))) +|# + 32)
(defmethod gfs:dispose ((self magick-data-plugin)) (let ((victim (gfs:handle self))) @@ -128,6 +71,22 @@ (destroy-image victim))) (setf (slot-value self 'gfs:handle) nil))
+(defmethod gfg:copy-pixels ((self magick-data-plugin) pixels-pointer) + (let* ((handle (gfs:handle self)) + (im-size (gfg:size self)) + (pixel-count (* (gfs:size-width im-size) (gfs:size-height im-size))) + (pix-tmp (get-image-pixels handle 0 0 (gfs:size-width im-size) (gfs:size-height im-size)))) + (dotimes (i pixel-count) + (cffi:with-foreign-slots ((blue green red reserved) + (cffi:mem-aref pix-tmp 'pixel-packet i) pixel-packet) + (cffi:with-foreign-slots ((gfs::rgbred gfs::rgbgreen gfs::rgbblue gfs::rgbreserved) + (cffi:mem-aref pixels-pointer 'gfs::rgbquad i) gfs::rgbquad) + (setf gfs::rgbreserved 0 + gfs::rgbred (scale-quantum-to-byte red) + gfs::rgbgreen (scale-quantum-to-byte green) + gfs::rgbblue (scale-quantum-to-byte blue)))))) + pixels-pointer) + (defmethod gfg:size ((self magick-data-plugin)) (let ((handle (gfs:handle self)) (size (gfs:make-size))) @@ -161,3 +120,9 @@ (destroy-image handle)) (destroy-exception-info ex))) size) + +(defmethod cffi:translate-to-foreign ((lisp-obj magick-data-plugin) + (name (eql 'gfs::bitmapinfo-pointer))) + ;; FIXME: assume true-color for now + ;; + (gfg::make-initial-bitmapinfo lisp-obj))