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)