[graphic-forms-cvs] r53 - in trunk/src: . tests/uitoolkit uitoolkit/graphics
junrue at common-lisp.net
junrue at common-lisp.net
Mon Mar 20 05:34:03 UTC 2006
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)
, at 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))))
More information about the Graphic-forms-cvs
mailing list