Author: junrue Date: Mon Mar 20 00:34:03 2006 New Revision: 53 Modified: trunk/src/packages.lisp trunk/src/tests/uitoolkit/image-tester.lisp trunk/src/uitoolkit/graphics/graphics-classes.lisp trunk/src/uitoolkit/graphics/graphics-context.lisp trunk/src/uitoolkit/graphics/image.lisp Log: image transparency is now specified as a point in the image rather than a color Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Mon Mar 20 00:34:03 2006 @@ -197,7 +197,7 @@ #:transform-coordinates #:translate #:transparency - #:transparency-of + #:transparency-pixel-of #:transparency-mask #:with-transparency #:xor-mode-p Modified: trunk/src/tests/uitoolkit/image-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/image-tester.lisp (original) +++ trunk/src/tests/uitoolkit/image-tester.lisp Mon Mar 20 00:34:03 2006 @@ -58,11 +58,12 @@ (defmethod gfw:event-paint ((d image-events) window time gc rect) (declare (ignore window time rect)) (let ((pnt (gfi:make-point)) - (color (gfg:make-color :red 0 :green 255 :blue 255))) + (pixel-pnt1 (gfi:make-point)) + (pixel-pnt2 (gfi:make-point :x 0 :y 15))) (gfg:draw-image gc *happy-image* pnt) (incf (gfi:point-x pnt) 36) - (gfg:with-transparency (*happy-image* color) + (gfg:with-transparency (*happy-image* pixel-pnt1) (gfg:draw-image gc (gfg:transparency-mask *happy-image*) pnt) (incf (gfi:point-x pnt) 36) (gfg:draw-image gc *happy-image* pnt)) @@ -71,7 +72,7 @@ (incf (gfi:point-y pnt) 36) (gfg:draw-image gc *bw-image* pnt) (incf (gfi:point-x pnt) 24) - (gfg:with-transparency (*bw-image* gfg:+color-black+) + (gfg:with-transparency (*bw-image* pixel-pnt1) (gfg:draw-image gc (gfg:transparency-mask *bw-image*) pnt) (incf (gfi:point-x pnt) 24) (gfg:draw-image gc *bw-image* pnt)) @@ -80,7 +81,7 @@ (incf (gfi:point-y pnt) 20) (gfg:draw-image gc *true-image* pnt) (incf (gfi:point-x pnt) 20) - (gfg:with-transparency (*true-image* color) + (gfg:with-transparency (*true-image* pixel-pnt2) (gfg:draw-image gc (gfg:transparency-mask *true-image*) pnt) (incf (gfi:point-x pnt) 20) (gfg:draw-image gc *true-image* pnt)))) @@ -103,6 +104,7 @@ (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 (gfw:text *image-win*) "Image Tester") (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/graphics-classes.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-classes.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-classes.lisp Mon Mar 20 00:34:03 2006 @@ -86,9 +86,9 @@ (:documentation "This class represents the context associated with drawing primitives.")) (defclass image (gfi:native-object) - ((transparency - :accessor transparency-of - :initarg :transparency + ((transparency-pixel + :accessor transparency-pixel-of + :initarg :transparency-pixel :initform nil)) (:documentation "This class wraps a native image object.")) Modified: trunk/src/uitoolkit/graphics/graphics-context.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-context.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-context.lisp Mon Mar 20 00:34:03 2006 @@ -90,14 +90,13 @@ (error 'gfi:disposed-error)) (if (gfi:disposed-p im) (error 'gfi:disposed-error)) - (let* ((color (transparency-of im)) - (gc-dc (gfi:handle gc)) - (himage (gfi:handle im)) - (memdc (gfs::create-compatible-dc (cffi:null-pointer)))) + (let ((gc-dc (gfi:handle gc)) + (himage (gfi:handle im)) + (memdc (gfs::create-compatible-dc (cffi:null-pointer)))) (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) - (if (not (null color)) + (if (not (null (transparency-pixel-of im))) (let ((hmask (gfi:handle (transparency-mask im))) (hcopy (clone-bitmap himage)) (memdc2 (gfs::create-compatible-dc (cffi:null-pointer)))) Modified: trunk/src/uitoolkit/graphics/image.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/image.lisp (original) +++ trunk/src/uitoolkit/graphics/image.lisp Mon Mar 20 00:34:03 2006 @@ -37,14 +37,14 @@ ;;; helper macros and functions ;;; -(defmacro with-transparency ((image color) &body body) - (let ((orig-color (gensym))) - `(let ((,orig-color (transparency-of ,image))) +(defmacro with-transparency ((image pnt) &body body) + (let ((orig-pnt (gensym))) + `(let ((,orig-pnt (transparency-pixel-of ,image))) (unwind-protect (progn - (setf (transparency-of ,image) ,color) + (setf (transparency-pixel-of ,image) ,pnt) ,@body) - (setf (transparency-of ,image) ,orig-color))))) + (setf (transparency-pixel-of ,image) ,orig-pnt))))) (defun clone-bitmap (horig) (let ((hclone (cffi:null-pointer)) @@ -90,20 +90,23 @@ (defmethod transparency-mask ((im image)) (if (gfi:disposed-p im) (error 'gfi:disposed-error)) - (let ((hbmp (gfi:handle im)) + (let ((pixel-pnt (transparency-pixel-of im)) + (hbmp (gfi:handle im)) (hmask (cffi:null-pointer)) (nptr (cffi:null-pointer)) (old-bg 0)) - (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")) - (gfs::with-compatible-dcs (nptr memdc1 memdc2) - (gfs::select-object memdc1 hbmp) - (setf old-bg (gfs::set-bk-color memdc1 (gfs::get-pixel memdc1 0 0))) - (gfs::select-object memdc2 hmask) - (gfs::bit-blt memdc2 0 0 gfs::width gfs::height memdc1 0 0 gfs::+blt-srccopy+) - (gfs::set-bk-color memdc1 old-bg)))) - (make-instance 'image :handle hmask))) + (unless (null pixel-pnt) + (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")) + (gfs::with-compatible-dcs (nptr memdc1 memdc2) + (gfs::select-object memdc1 hbmp) + (setf old-bg (gfs::set-bk-color memdc1 + (gfs::get-pixel memdc1 (gfi:point-x pixel-pnt) (gfi:point-y pixel-pnt)))) + (gfs::select-object memdc2 hmask) + (gfs::bit-blt memdc2 0 0 gfs::width gfs::height memdc1 0 0 gfs::+blt-srccopy+) + (gfs::set-bk-color memdc1 old-bg)))) + (make-instance 'image :handle hmask))))