[graphic-forms-cvs] r200 - in trunk/src: . uitoolkit/graphics uitoolkit/graphics/plugins/default uitoolkit/graphics/plugins/imagemagick uitoolkit/system
junrue at common-lisp.net
junrue at common-lisp.net
Sat Aug 5 02:50:30 UTC 2006
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)
More information about the Graphic-forms-cvs
mailing list