[graphic-forms-cvs] r52 - in trunk/src: . tests/uitoolkit uitoolkit/graphics uitoolkit/system uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Mon Mar 20 05:18:26 UTC 2006
Author: junrue
Date: Mon Mar 20 00:18:25 2006
New Revision: 52
Modified:
trunk/src/packages.lisp
trunk/src/tests/uitoolkit/happy.bmp
trunk/src/tests/uitoolkit/image-tester.lisp
trunk/src/tests/uitoolkit/truecolor16x16.bmp
trunk/src/uitoolkit/graphics/graphics-context.lisp
trunk/src/uitoolkit/graphics/image-data.lisp
trunk/src/uitoolkit/graphics/image.lisp
trunk/src/uitoolkit/system/gdi32.lisp
trunk/src/uitoolkit/system/system-utils.lisp
trunk/src/uitoolkit/widgets/widget-utils.lisp
Log:
basic transparency working, need to allow caller to select the pixel that defines transparent color
Modified: trunk/src/packages.lisp
==============================================================================
--- trunk/src/packages.lisp (original)
+++ trunk/src/packages.lisp Mon Mar 20 00:18:25 2006
@@ -94,8 +94,9 @@
;; methods, functions, macros
#:detail
+ #:with-compatible-dcs
#:with-hfont-selected
- #:with-retrieved-hdc
+ #:with-retrieved-dc
;; conditions
#:toolkit-error
Modified: trunk/src/tests/uitoolkit/happy.bmp
==============================================================================
Binary files. No diff available.
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:18:25 2006
@@ -58,11 +58,11 @@
(defmethod gfw:event-paint ((d image-events) window time gc rect)
(declare (ignore window time rect))
(let ((pnt (gfi:make-point))
- (tr-color (gfg:make-color :red 192 :green 192 :blue 192)))
+ (color (gfg:make-color :red 0 :green 255 :blue 255)))
(gfg:draw-image gc *happy-image* pnt)
(incf (gfi:point-x pnt) 36)
- (gfg:with-transparency (*happy-image* tr-color)
+ (gfg:with-transparency (*happy-image* color)
(gfg:draw-image gc (gfg:transparency-mask *happy-image*) pnt)
(incf (gfi:point-x pnt) 36)
(gfg:draw-image gc *happy-image* pnt))
@@ -80,7 +80,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* tr-color)
+ (gfg:with-transparency (*true-image* color)
(gfg:draw-image gc (gfg:transparency-mask *true-image*) pnt)
(incf (gfi:point-x pnt) 20)
(gfg:draw-image gc *true-image* pnt))))
Modified: trunk/src/tests/uitoolkit/truecolor16x16.bmp
==============================================================================
Binary files. No diff available.
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:18:25 2006
@@ -90,25 +90,42 @@
(error 'gfi:disposed-error))
(if (gfi:disposed-p im)
(error 'gfi:disposed-error))
- (let* ((gc-dc (gfi:handle gc))
+ (let* ((color (transparency-of im))
+ (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+))
+ (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))
+ (let ((hmask (gfi:handle (transparency-mask im)))
+ (hcopy (clone-bitmap himage))
+ (memdc2 (gfs::create-compatible-dc (cffi:null-pointer))))
+ (gfs::select-object memdc hmask)
+ (gfs::select-object memdc2 hcopy)
+ (gfs::set-bk-color memdc2 (color-as-rgb +color-black+))
+ (gfs::set-text-color memdc2 (color-as-rgb +color-white+))
+ (gfs::bit-blt memdc2
+ 0 0
+ gfs::width
+ gfs::height
+ memdc
+ 0 0 gfs::+blt-srcand+)
+ (gfs::bit-blt gc-dc
+ (gfi:point-x pnt)
+ (gfi:point-y pnt)
+ gfs::width
+ gfs::height
+ memdc
+ 0 0 gfs::+blt-srcand+)
+ (gfs::bit-blt gc-dc
+ (gfi:point-x pnt)
+ (gfi:point-y pnt)
+ gfs::width
+ gfs::height
+ memdc2
+ 0 0 gfs::+blt-srcpaint+))
+ (progn
(gfs::select-object memdc himage)
(gfs::bit-blt gc-dc
(gfi:point-x pnt)
@@ -116,8 +133,8 @@
gfs::width
gfs::height
memdc
- 0 0 op)))
- (gfs::delete-dc memdc))))
+ 0 0 gfs::+blt-srccopy+)))))
+ (gfs::delete-dc memdc)))
(defmethod draw-text ((gc graphics-context) text (pnt gfi:point))
(if (gfi:disposed-p gc)
Modified: trunk/src/uitoolkit/graphics/image-data.lisp
==============================================================================
--- trunk/src/uitoolkit/graphics/image-data.lisp (original)
+++ trunk/src/uitoolkit/graphics/image-data.lisp Mon Mar 20 00:18:25 2006
@@ -46,8 +46,6 @@
(data nil)
(sz nil)
(byte-count 0))
- (when (gfi:null-handle-p mem-dc)
- (error 'gfs:win32-error :detail "create-compatible-dc failed"))
(unwind-protect
(progn
(cffi:with-foreign-object (bc-ptr 'gfs::bitmapcoreheader)
@@ -218,8 +216,9 @@
(with-image-path (path info ex)
(setf handle (read-image info ex))
(if (not (eql (cffi:foreign-slot-value ex 'exception-info 'severity) :undefined))
- (error 'gfs:toolkit-error :detail (format nil "exception reason: ~s"
- (cffi:foreign-string-to-lisp (cffi:foreign-slot-value ex 'exception-info 'reason)))))
+ (error 'gfs:toolkit-error :detail (format nil
+ "exception reason: ~s"
+ (cffi:foreign-slot-value ex 'exception-info 'reason))))
(if (cffi:null-pointer-p handle)
(error 'gfs:toolkit-error :detail (format nil "could not load image: ~a" path)))
(setf (slot-value data 'gfi:handle) handle))))
Modified: trunk/src/uitoolkit/graphics/image.lisp
==============================================================================
--- trunk/src/uitoolkit/graphics/image.lisp (original)
+++ trunk/src/uitoolkit/graphics/image.lisp Mon Mar 20 00:18:25 2006
@@ -34,7 +34,7 @@
(in-package :graphic-forms.uitoolkit.graphics)
;;;
-;;; helper macros
+;;; helper macros and functions
;;;
(defmacro with-transparency ((image color) &body body)
@@ -46,6 +46,21 @@
, at body)
(setf (transparency-of ,image) ,orig-color)))))
+(defun clone-bitmap (horig)
+ (let ((hclone (cffi:null-pointer))
+ (nptr (cffi:null-pointer)))
+ (gfs:with-compatible-dcs (nptr memdc-src memdc-dest)
+ (cffi:with-foreign-object (bmp-ptr 'gfs::bitmap)
+ (cffi:with-foreign-slots ((gfs::width gfs::height) bmp-ptr gfs::bitmap)
+ (gfs::get-object horig (cffi:foreign-type-size 'gfs::bitmap) bmp-ptr)
+ (setf hclone (gfs::create-compatible-bitmap (gfs::get-dc (cffi:null-pointer))
+ gfs::width
+ gfs::height))
+ (gfs::select-object memdc-dest hclone)
+ (gfs::select-object memdc-src horig)
+ (gfs::bit-blt memdc-dest 0 0 gfs::width gfs::height memdc-src 0 0 gfs::+blt-srccopy+))))
+ hclone))
+
;;;
;;; methods
;;;
@@ -76,25 +91,19 @@
(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
+ (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"))
- (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)))))
+ (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)))
Modified: trunk/src/uitoolkit/system/gdi32.lisp
==============================================================================
--- trunk/src/uitoolkit/system/gdi32.lisp (original)
+++ trunk/src/uitoolkit/system/gdi32.lisp Mon Mar 20 00:18:25 2006
@@ -164,6 +164,13 @@
(buffer LPTR))
(defcfun
+ ("GetPixel" get-pixel)
+ COLORREF
+ (hdc HANDLE)
+ (x INT)
+ (y INT))
+
+(defcfun
("GetStockObject" get-stock-object)
HANDLE
(type INT))
@@ -180,6 +187,22 @@
(lpm LPTR))
(defcfun
+ ("MaskBlt" mask-blt)
+ BOOL
+ (hdest HANDLE)
+ (xdest INT)
+ (ydest INT)
+ (width INT)
+ (height INT)
+ (hsrc HANDLE)
+ (xsrc INT)
+ (ysrc INT)
+ (hmask HANDLE)
+ (xmask INT)
+ (ymask INT)
+ (rop DWORD))
+
+(defcfun
("SelectObject" select-object)
HANDLE
(hdc HANDLE)
@@ -219,3 +242,6 @@
COLORREF
(hdc HANDLE)
(color COLORREF))
+
+(defun makerop4 (fore back)
+ (logior (logand (ash back 8) #xFF000000) fore))
Modified: trunk/src/uitoolkit/system/system-utils.lisp
==============================================================================
--- trunk/src/uitoolkit/system/system-utils.lisp (original)
+++ trunk/src/uitoolkit/system/system-utils.lisp Mon Mar 20 00:18:25 2006
@@ -47,7 +47,7 @@
(unless (gfi:null-handle-p ,hfont-old)
(gfs::select-object ,hdc ,hfont-old))))))
-(defmacro with-retrieved-hdc ((hwnd hdc-var) &body body)
+(defmacro with-retrieved-dc ((hwnd hdc-var) &body body)
`(let ((,hdc-var nil))
(unwind-protect
(progn
@@ -56,3 +56,12 @@
(error 'gfs:win32-error :detail "get-dc failed"))
, at body)
(gfs::release-dc ,hwnd ,hdc-var))))
+
+(defmacro with-compatible-dcs ((orig-dc &rest hdc-vars) &body body)
+ `(let ,(loop for var in hdc-vars
+ collect `(,var (gfs::create-compatible-dc ,orig-dc)))
+ (unwind-protect
+ (progn
+ , at body)
+ ,@(loop for var2 in hdc-vars
+ collect `(gfs::delete-dc ,var2)))))
Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-utils.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget-utils.lisp Mon Mar 20 00:18:25 2006
@@ -136,7 +136,7 @@
(sz (gfi:make-size))
(hfont nil))
(setf dt-flags (logior dt-flags gfs::+dt-calcrect+))
- (gfs:with-retrieved-hdc (hwnd hdc)
+ (gfs:with-retrieved-dc (hwnd hdc)
(setf hfont (cffi:make-pointer (gfs::send-message hwnd gfs::+wm-getfont+ 0 0)))
(gfs:with-hfont-selected (hdc hfont)
(when (> len 0)
More information about the Graphic-forms-cvs
mailing list