Author: junrue Date: Sun Mar 19 16:35:26 2006 New Revision: 51 Modified: trunk/src/packages.lisp trunk/src/tests/uitoolkit/image-tester.lisp trunk/src/uitoolkit/graphics/color.lisp trunk/src/uitoolkit/graphics/graphics-classes.lisp trunk/src/uitoolkit/graphics/graphics-context.lisp trunk/src/uitoolkit/graphics/graphics-generics.lisp trunk/src/uitoolkit/graphics/image-data.lisp trunk/src/uitoolkit/graphics/image.lisp trunk/src/uitoolkit/graphics/magick-core-types.lisp trunk/src/uitoolkit/system/gdi32.lisp Log: initial transparency work Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Sun Mar 19 16:35:26 2006 @@ -195,8 +195,10 @@ #:transform #:transform-coordinates #:translate - #:transparency-color + #:transparency + #:transparency-of #:transparency-mask + #:with-transparency #:xor-mode-p ;; conditions Modified: trunk/src/tests/uitoolkit/image-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/image-tester.lisp (original) +++ trunk/src/tests/uitoolkit/image-tester.lisp Sun Mar 19 16:35:26 2006 @@ -40,29 +40,54 @@ (defclass image-events (gfw:event-dispatcher) ()) -(defmethod gfw:event-close ((d image-events) window time) - (declare (ignore window time)) +(defun dispose-images () (gfi:dispose *happy-image*) (setf *happy-image* nil) (gfi:dispose *bw-image*) (setf *bw-image* nil) (gfi:dispose *true-image*) - (setf *true-image* nil) + (setf *true-image* nil)) + +(defmethod gfw:event-close ((d image-events) window time) + (declare (ignore window time)) + (dispose-images) (gfi:dispose *image-win*) (setf *image-win* nil) (gfw:shutdown 0)) (defmethod gfw:event-paint ((d image-events) window time gc rect) (declare (ignore window time rect)) - (let ((pnt (gfi:make-point))) + (let ((pnt (gfi:make-point)) + (tr-color (gfg:make-color :red 192 :green 192 :blue 192))) + (gfg:draw-image gc *happy-image* pnt) (incf (gfi:point-x pnt) 36) + (gfg:with-transparency (*happy-image* tr-color) + (gfg:draw-image gc (gfg:transparency-mask *happy-image*) pnt) + (incf (gfi:point-x pnt) 36) + (gfg:draw-image gc *happy-image* pnt)) + + (setf (gfi:point-x pnt) 0) + (incf (gfi:point-y pnt) 36) (gfg:draw-image gc *bw-image* pnt) (incf (gfi:point-x pnt) 24) - (gfg:draw-image gc *true-image* pnt))) + (gfg:with-transparency (*bw-image* gfg:+color-black+) + (gfg:draw-image gc (gfg:transparency-mask *bw-image*) pnt) + (incf (gfi:point-x pnt) 24) + (gfg:draw-image gc *bw-image* pnt)) + + (setf (gfi:point-x pnt) 0) + (incf (gfi:point-y pnt) 20) + (gfg:draw-image gc *true-image* pnt) + (incf (gfi:point-x pnt) 20) + (gfg:with-transparency (*true-image* tr-color) + (gfg:draw-image gc (gfg:transparency-mask *true-image*) pnt) + (incf (gfi:point-x pnt) 20) + (gfg:draw-image gc *true-image* pnt)))) (defun exit-image-fn (disp item time rect) (declare (ignorable disp item time rect)) + (dispose-images) (gfi:dispose *image-win*) (setf *image-win* nil) (gfw:shutdown 0)) @@ -77,6 +102,7 @@ (gfg::load *true-image* "truecolor16x16.bmp") (setf *image-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'image-events) :style '(:style-workspace))) + (setf (gfw:size *image-win*) (gfi:make-size :width 250 :height 200)) (setf menubar (gfw:defmenusystem ((:item "&File" :submenu ((:item "E&xit" :callback #'exit-image-fn)))))) (setf (gfw:menu-bar *image-win*) menubar) Modified: trunk/src/uitoolkit/graphics/color.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/color.lisp (original) +++ trunk/src/uitoolkit/graphics/color.lisp Sun Mar 19 16:35:26 2006 @@ -33,13 +33,13 @@ (in-package :graphic-forms.uitoolkit.graphics) -(defconstant +color-black+ (make-color :red 0 :green 0 :blue 0)) -(defconstant +color-blue+ (make-color :red 0 :green 0 :blue #xFF)) -(defconstant +color-green+ (make-color :red 0 :green #xFF :blue 0)) -(defconstant +color-red+ (make-color :red #xFF :green 0 :blue 0)) -(defconstant +color-white+ (make-color :red #xFF :green #xFF :blue #xFF)) - (eval-when (:compile-toplevel :load-toplevel :execute) + (defconstant +color-black+ (make-color :red 0 :green 0 :blue 0)) + (defconstant +color-blue+ (make-color :red 0 :green 0 :blue #xFF)) + (defconstant +color-green+ (make-color :red 0 :green #xFF :blue 0)) + (defconstant +color-red+ (make-color :red #xFF :green 0 :blue 0)) + (defconstant +color-white+ (make-color :red #xFF :green #xFF :blue #xFF)) + (defmacro color-as-rgb (color) (let ((result (gensym))) `(let ((,result 0)) Modified: trunk/src/uitoolkit/graphics/graphics-classes.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-classes.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-classes.lisp Sun Mar 19 16:35:26 2006 @@ -87,10 +87,10 @@ (defclass image (gfi:native-object) ((transparency - :accessor transparency-color - :initarg :transparency-color - :initform (make-color))) - (:documentation "This class represents an image of a particular type (BMP, PNG, etc.).")) + :accessor transparency-of + :initarg :transparency + :initform nil)) + (:documentation "This class wraps a native image object.")) (defmacro blue-mask (data) `(gfg::palette-blue-mask ,data)) Modified: trunk/src/uitoolkit/graphics/graphics-context.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-context.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-context.lisp Sun Mar 19 16:35:26 2006 @@ -82,30 +82,42 @@ 0 (cffi:null-pointer)))))) +;;; +;;; TODO: support addressing elements within bitmap as if it were an array +;;; (defmethod draw-image ((gc graphics-context) (im image) (pnt gfi:point)) (if (gfi:disposed-p gc) (error 'gfi:disposed-error)) (if (gfi:disposed-p im) (error 'gfi:disposed-error)) - ;; TODO: support addressing elements within bitmap as if it were an array - ;; - (let ((memdc (gfs::create-compatible-dc (gfi:handle gc))) - (oldhbm (cffi:null-pointer))) - (if (gfi:null-handle-p memdc) - (error 'gfs:win32-error :detail "create-compatible-dc failed")) - (setf oldhbm (gfs::select-object memdc (gfi:handle im))) - (cffi:with-foreign-object (bmp-ptr 'gfs::bitmap) - (gfs::get-object (gfi:handle im) (cffi:foreign-type-size 'gfs::bitmap) bmp-ptr) - (gfs::bit-blt (gfi:handle gc) - (gfi:point-x pnt) - (gfi:point-y pnt) - (cffi:foreign-slot-value bmp-ptr 'gfs::bitmap 'gfs::width) - (cffi:foreign-slot-value bmp-ptr 'gfs::bitmap 'gfs::height) - memdc - 0 0 - gfs::+blt-srccopy+)) - (gfs::select-object memdc oldhbm) - (gfs::delete-dc memdc))) + (let* ((gc-dc (gfi:handle gc)) + (himage (gfi:handle im)) + (memdc (gfs::create-compatible-dc gc-dc)) + (tr-color (transparency-of im)) + (op gfs::+blt-srccopy+)) + (unwind-protect + (cffi:with-foreign-object (bmp-ptr 'gfs::bitmap) + (cffi:with-foreign-slots ((gfs::width gfs::height) bmp-ptr gfs::bitmap) + (gfs::get-object himage (cffi:foreign-type-size 'gfs::bitmap) bmp-ptr) + (when (not (null tr-color)) + (setf op gfs::+blt-srcpaint+) + (gfs::select-object memdc (gfi:handle (transparency-mask im))) + (gfs::bit-blt gc-dc + (gfi:point-x pnt) + (gfi:point-y pnt) + gfs::width + gfs::height + memdc + 0 0 gfs::+blt-srcand+)) + (gfs::select-object memdc himage) + (gfs::bit-blt gc-dc + (gfi:point-x pnt) + (gfi:point-y pnt) + gfs::width + gfs::height + memdc + 0 0 op))) + (gfs::delete-dc memdc)))) (defmethod draw-text ((gc graphics-context) text (pnt gfi:point)) (if (gfi:disposed-p gc) Modified: trunk/src/uitoolkit/graphics/graphics-generics.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-generics.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-generics.lisp Sun Mar 19 16:35:26 2006 @@ -175,7 +175,7 @@ (:documentation "Returns a modified version of the object which is the result of translating the original by the specified mathematical vector.")) (defgeneric transparency-mask (object) - (:documentation "Returns an image-data object specifying the transparency mask for the image.")) + (:documentation "Returns an image object that will serve as the transparency mask for the original image, based on the original image's assigned transparency.")) (defgeneric xor-mode-p (object) (:documentation "Returns T if colors are combined in XOR mode; nil otherwise.")) Modified: trunk/src/uitoolkit/graphics/image-data.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/image-data.lisp (original) +++ trunk/src/uitoolkit/graphics/image-data.lisp Sun Mar 19 16:35:26 2006 @@ -145,12 +145,8 @@ (let* ((handle (gfi:handle data)) (sz (size data)) (pix-count (* (gfi:size-width sz) (gfi:size-height sz))) - (bit-count (depth data)) (hbmp (cffi:null-pointer)) (screen-dc (gfs::get-dc (cffi:null-pointer)))) -(format t "bi-size: ~a~%" (cffi:foreign-type-size 'gfs::bitmapinfoheader)) -(format t "bit-count: ~a~%" bit-count) -(format t "size: ~a ~a~%" (gfi:size-width sz) (gfi:size-height sz)) (setf gfs::bisize (cffi:foreign-type-size 'gfs::bitmapinfoheader)) (setf gfs::biwidth (gfi:size-width sz)) (setf gfs::biheight (- 0 (gfi:size-height sz))) Modified: trunk/src/uitoolkit/graphics/image.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/image.lisp (original) +++ trunk/src/uitoolkit/graphics/image.lisp Sun Mar 19 16:35:26 2006 @@ -34,9 +34,18 @@ (in-package :graphic-forms.uitoolkit.graphics) ;;; -;;; helper functions +;;; helper macros ;;; +(defmacro with-transparency ((image color) &body body) + (let ((orig-color (gensym))) + `(let ((,orig-color (transparency-of ,image))) + (unwind-protect + (progn + (setf (transparency-of ,image) ,color) + ,@body) + (setf (transparency-of ,image) ,orig-color))))) + ;;; ;;; methods ;;; @@ -45,7 +54,6 @@ (let ((hgdi (gfi:handle im))) (unless (gfi:null-handle-p hgdi) (gfs::delete-object hgdi))) - (setf (transparency-color im) nil) (setf (slot-value im 'gfi:handle) nil)) (defmethod data-obj ((im image)) @@ -63,3 +71,30 @@ (load data path) (setf (data-obj im) data) data)) + +(defmethod transparency-mask ((im image)) + (if (gfi:disposed-p im) + (error 'gfi:disposed-error)) + (let ((hbmp (gfi:handle im)) + (tr-color (transparency-of im)) + (hmask (cffi:null-pointer))) + (if (null tr-color) + (setf tr-color +color-black+)) ;; FIXME: upper-left pixel might be better choice + (cffi:with-foreign-object (bmp-ptr 'gfs::bitmap) + (gfs::get-object (gfi:handle im) (cffi:foreign-type-size 'gfs::bitmap) bmp-ptr) + (cffi:with-foreign-slots ((gfs::width gfs::height) bmp-ptr gfs::bitmap) + (setf hmask (gfs::create-bitmap gfs::width gfs::height 1 1 (cffi:null-pointer))) + (if (gfi:null-handle-p hmask) + (error 'gfs:win32-error :detail "create-bitmap failed")) + (let ((memdc1 (gfs::create-compatible-dc (cffi:null-pointer))) + (memdc2 (gfs::create-compatible-dc (cffi:null-pointer)))) + (unwind-protect + (progn + (gfs::select-object memdc1 hbmp) + (gfs::select-object memdc2 hmask) + (gfs::set-bk-color memdc1 (color-as-rgb tr-color)) + (gfs::bit-blt memdc2 0 0 gfs::width gfs::height memdc1 0 0 gfs::+blt-srccopy+) + (gfs::bit-blt memdc1 0 0 gfs::width gfs::height memdc2 0 0 gfs::+blt-srcinvert+)) + (gfs::delete-dc memdc1) + (gfs::delete-dc memdc2))))) + (make-instance 'image :handle hmask))) Modified: trunk/src/uitoolkit/graphics/magick-core-types.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/magick-core-types.lisp (original) +++ trunk/src/uitoolkit/graphics/magick-core-types.lisp Sun Mar 19 16:35:26 2006 @@ -41,8 +41,9 @@ ;;; of these types from ImageMagick Core. ;;; -(defconstant +magick-max-text-extent+ 4096) -(defconstant +magick-signature+ #xABACADAB) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defconstant +magick-max-text-extent+ 4096) + (defconstant +magick-signature+ #xABACADAB)) (defconstant +undefined-channel+ #x00000000) (defconstant +red-channel+ #x00000001) Modified: trunk/src/uitoolkit/system/gdi32.lisp ============================================================================== --- trunk/src/uitoolkit/system/gdi32.lisp (original) +++ trunk/src/uitoolkit/system/gdi32.lisp Sun Mar 19 16:35:26 2006 @@ -53,11 +53,27 @@ (rop DWORD)) (defcfun + ("CreateBitmap" create-bitmap) + HANDLE + (width INT) + (height INT) + (planes UINT) + (bpp UINT) + (pixels LPTR)) + +(defcfun ("CreateBitmapIndirect" create-bitmap-indirect) HANDLE (lpbm LPTR)) (defcfun + ("CreateCompatibleBitmap" create-compatible-bitmap) + HANDLE + (hdc HANDLE) + (width INT) + (height INT)) + +(defcfun ("CreateCompatibleDC" create-compatible-dc) HANDLE (hdc HANDLE))