[graphic-forms-cvs] r229 - in trunk/src: . uitoolkit/graphics uitoolkit/graphics/plugins/default uitoolkit/graphics/plugins/imagemagick
junrue at common-lisp.net
junrue at common-lisp.net
Mon Aug 21 21:23:24 UTC 2006
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))
More information about the Graphic-forms-cvs
mailing list