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 @@ ,@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")) ,@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 + ,@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)