Author: junrue Date: Mon Apr 3 01:13:51 2006 New Revision: 86

Added: trunk/src/demos/unblocked/tiles-panel.lisp - copied, changed from r85, trunk/src/demos/unblocked/unblocked-panel.lisp Removed: trunk/src/demos/unblocked/unblocked-panel.lisp Modified: trunk/graphic-forms-tests.asd trunk/src/demos/unblocked/scoreboard-panel.lisp trunk/src/demos/unblocked/unblocked-window.lisp trunk/src/uitoolkit/graphics/graphics-context.lisp Log: initial tile painting implemented; fixed a bitmap leak in draw-image

Modified: trunk/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Mon Apr 3 01:13:51 2006 @@ -64,7 +64,7 @@ ((:file "tiles") (:file "unblocked-model") (:file "scoreboard-panel") - (:file "unblocked-panel") + (:file "tiles-panel") (:file "unblocked-window"))))) (:module "tests" :components

Modified: trunk/src/demos/unblocked/scoreboard-panel.lisp ============================================================================== --- trunk/src/demos/unblocked/scoreboard-panel.lisp (original) +++ trunk/src/demos/unblocked/scoreboard-panel.lisp Mon Apr 3 01:13:51 2006 @@ -33,6 +33,10 @@

(in-package :graphic-forms.uitoolkit.tests)

+(defconstant +level-label+ "Level:") +(defconstant +points-needed-label+ "Points Needed:") +(defconstant +score-label+ "Score:") + (defclass scoreboard-panel-events (gfw:event-dispatcher) ((label-font :accessor label-font-of @@ -54,6 +58,13 @@ (gfs:dispose tmp-font) (setf (label-font-of self) nil))))

+(defmethod gfw:event-paint ((self scoreboard-panel-events) window time gc rect) + (declare (ignore time rect)) + (setf (gfg:background-color gc) gfg:*color-black*) + (gfg:draw-filled-rectangle gc (make-instance 'gfs:rectangle :location (gfs:make-point) + :size (gfw:client-size window)))) + + (defmethod initialize-instance :after ((self scoreboard-panel-events) &key) (let ((gc (make-instance 'gfg:graphics-context)) (label-font-data (gfg:make-font-data :face-name "Tahoma" @@ -69,7 +80,7 @@ (setf font (make-instance 'gfg:font :gc gc :data label-font-data) (label-font-of self) font (gfg:font gc) font - extent-size (gfg:text-extent gc "Next Level Score:") + extent-size (gfg:text-extent gc +points-needed-label+) (gfs:size-width pref-size) (gfs:size-width extent-size) (gfs:size-height pref-size) (* (gfs:size-height extent-size) 4)) (setf font (make-instance 'gfg:font :gc gc :data value-font-data)

Copied: trunk/src/demos/unblocked/tiles-panel.lisp (from r85, trunk/src/demos/unblocked/unblocked-panel.lisp) ============================================================================== --- trunk/src/demos/unblocked/unblocked-panel.lisp (original) +++ trunk/src/demos/unblocked/tiles-panel.lisp Mon Apr 3 01:13:51 2006 @@ -1,5 +1,5 @@ ;;;; -;;;; unblocked-panel.lisp +;;;; tiles-panel.lisp ;;;; ;;;; Copyright (C) 2006, Jack D. Unrue ;;;; All rights reserved. @@ -44,7 +44,7 @@ (gfs:make-point :x (floor (/ (gfs:point-x pnt) +tile-bmp-width+)) :y (floor (/ (gfs:point-y pnt) +tile-bmp-height+))))

-(defclass unblocked-panel-events (gfw:event-dispatcher) +(defclass tiles-panel-events (gfw:event-dispatcher) ((image-buffer :accessor image-buffer-of :initform (make-instance 'gfg:image :size (gfs:make-size :width (* +horz-tile-count+ @@ -55,7 +55,7 @@ :accessor tile-image-table-of :initform (make-hash-table :test #'equal))))

-(defmethod dispose ((self unblocked-panel-events)) +(defmethod dispose ((self tiles-panel-events)) (let ((image (image-buffer-of self)) (table (tile-image-table-of self))) (gfs:dispose image) @@ -66,11 +66,11 @@ (setf (image-buffer-of self) nil) (setf (tile-image-table-of self) nil))

-(defmethod gfw:event-paint ((self unblocked-panel-events) window time gc rect) +(defmethod gfw:event-paint ((self tiles-panel-events) window time gc rect) (declare (ignore window time rect)) (gfg:draw-image gc (image-buffer-of self) (gfs:make-point)))

-(defmethod initialize-instance :after ((self unblocked-panel-events) &key) +(defmethod initialize-instance :after ((self tiles-panel-events) &key) (let ((table (tile-image-table-of self)) (kind 1)) (loop for filename in '("blue-tile.bmp" "brown-tile.bmp" "gold-tile.bmp" @@ -80,24 +80,28 @@ (setf (gethash kind table) image) (incf kind)))))

-(defmethod update-buffer ((self unblocked-panel-events) tiles) +(defmethod update-buffer ((self tiles-panel-events) tiles) (let ((gc (make-instance 'gfg:graphics-context :image (image-buffer-of self))) - (image-table (tile-image-table-of self))) + (image-table (tile-image-table-of self)) + (pixel-pnt (gfs:make-point))) (setf (gfg:background-color gc) gfg:*color-black*) (setf (gfg:foreground-color gc) gfg:*color-black*) (gfg:draw-filled-rectangle gc (make-instance 'gfs:rectangle :location (gfs:make-point) :size (gfg:size (image-buffer-of self)))) (map-tiles #'(lambda (pnt kind) - (let ((image (gethash kind image-table))) - (gfg:draw-image gc image (tiles->window pnt)))) - tiles))) + (unless (= kind 0) + (let ((image (gethash kind image-table))) + (gfg:with-transparency (image pixel-pnt) + (gfg:draw-image gc image (tiles->window pnt)))))) + tiles) + (gfs:dispose gc)))

-(defclass unblocked-panel (gfw:panel) ()) +(defclass tiles-panel (gfw:panel) ())

-(defmethod gfs:dispose ((self unblocked-panel)) +(defmethod gfs:dispose ((self tiles-panel)) (dispose (gfw:dispatcher self)) (call-next-method))

-(defmethod gfw:preferred-size ((self unblocked-panel) width-hint height-hint) +(defmethod gfw:preferred-size ((self tiles-panel) width-hint height-hint) (declare (ignore width-hint height-hint)) (gfg:size (image-buffer-of (gfw:dispatcher self))))

Modified: trunk/src/demos/unblocked/unblocked-window.lisp ============================================================================== --- trunk/src/demos/unblocked/unblocked-window.lisp (original) +++ trunk/src/demos/unblocked/unblocked-window.lisp Mon Apr 3 01:13:51 2006 @@ -36,10 +36,17 @@ (defconstant +spacing+ 4) (defconstant +margin+ 4)

+(defvar *scoreboard-panel* nil) +(defvar *tiles-panel* nil) (defvar *unblocked-win* nil)

(defun new-unblocked (disp item time rect) - (declare (ignore disp item time rect))) + (declare (ignore disp item time rect)) + (let ((tiles-disp (gfw:dispatcher *tiles-panel*)) + (tiles (init-tiles +horz-tile-count+ +vert-tile-count+ 5))) + (collapse-tiles tiles) + (update-buffer tiles-disp tiles) + (gfw:redraw *tiles-panel*)))

(defun restart-unblocked (disp item time rect) (declare (ignore disp item time rect))) @@ -49,6 +56,8 @@

(defun quit-unblocked (disp item time rect) (declare (ignore disp item time rect)) + (setf *scoreboard-panel* nil) + (setf *tiles-panel* nil) (gfs:dispose *unblocked-win*) (setf *unblocked-win* nil) (gfw:shutdown 0)) @@ -68,14 +77,17 @@ (:item "E&xit" :callback #'quit-unblocked))))))) (setf *unblocked-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'unblocked-win-events) :layout (make-instance 'gfw:flow-layout + :style :vertical :spacing +spacing+ - :margin +margin+) + :margins +margin+) :style '(:workspace))) (setf (gfw:menu-bar *unblocked-win*) menubar) - (make-instance 'scoreboard-panel :parent *unblocked-win* - :dispatcher (make-instance 'scoreboard-panel-events)) - (make-instance 'unblocked-panel :parent *unblocked-win* - :dispatcher (make-instance 'unblocked-panel-events)) + (setf *scoreboard-panel* (make-instance 'scoreboard-panel + :parent *unblocked-win* + :dispatcher (make-instance 'scoreboard-panel-events))) + (setf *tiles-panel* (make-instance 'tiles-panel + :parent *unblocked-win* + :dispatcher (make-instance 'tiles-panel-events))) (setf (gfw:text *unblocked-win*) "Graphic-Forms UnBlocked") (gfw:pack *unblocked-win*) (gfw:show *unblocked-win* t)))

Modified: trunk/src/uitoolkit/graphics/graphics-context.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-context.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-context.lisp Mon Apr 3 01:13:51 2006 @@ -333,40 +333,44 @@ (error 'gfs:disposed-error)) (let ((gc-dc (gfs:handle self)) (himage (gfs:handle im)) + (tr-mask nil) (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 (transparency-pixel-of im))) - (let ((hmask (gfs:handle (transparency-mask im))) - (hcopy (clone-bitmap himage)) - (memdc2 (gfs::create-compatible-dc (cffi:null-pointer))) - (black (make-color :red 0 :green 0 :blue 0)) - (white (make-color :red #xFF :green #xFF :blue #xFF))) - (gfs::select-object memdc hmask) - (gfs::select-object memdc2 hcopy) - (gfs::set-bk-color memdc2 (color->rgb black)) - (gfs::set-text-color memdc2 (color->rgb white)) - (gfs::bit-blt memdc2 - 0 0 - gfs::width - gfs::height - memdc - 0 0 gfs::+blt-srcand+) - (gfs::bit-blt gc-dc - (gfs:point-x pnt) - (gfs:point-y pnt) - gfs::width - gfs::height - memdc - 0 0 gfs::+blt-srcand+) - (gfs::bit-blt gc-dc - (gfs:point-x pnt) - (gfs:point-y pnt) - gfs::width - gfs::height - memdc2 - 0 0 gfs::+blt-srcpaint+)) + (progn + (setf tr-mask (transparency-mask im)) + (let ((hmask (gfs:handle tr-mask)) + (hcopy (clone-bitmap himage)) + (memdc2 (gfs::create-compatible-dc (cffi:null-pointer))) + (black (make-color :red 0 :green 0 :blue 0)) + (white (make-color :red #xFF :green #xFF :blue #xFF))) + (gfs::select-object memdc hmask) + (gfs::select-object memdc2 hcopy) + (gfs::set-bk-color memdc2 (color->rgb black)) + (gfs::set-text-color memdc2 (color->rgb white)) + (gfs::bit-blt memdc2 + 0 0 + gfs::width + gfs::height + memdc + 0 0 gfs::+blt-srcand+) + (gfs::bit-blt gc-dc + (gfs:point-x pnt) + (gfs:point-y pnt) + gfs::width + gfs::height + memdc + 0 0 gfs::+blt-srcand+) + (gfs::bit-blt gc-dc + (gfs:point-x pnt) + (gfs:point-y pnt) + gfs::width + gfs::height + memdc2 + 0 0 gfs::+blt-srcpaint+)) + (gfs:dispose tr-mask)) (progn (gfs::select-object memdc himage) (gfs::bit-blt gc-dc