[graphic-forms-cvs] r51 - in trunk/src: . tests/uitoolkit uitoolkit/graphics uitoolkit/system
junrue at common-lisp.net
junrue at common-lisp.net
Sun Mar 19 21:35:28 UTC 2006
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)
+ , at 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))
More information about the Graphic-forms-cvs
mailing list