[graphic-forms-cvs] r86 - in trunk: . src/demos/unblocked src/uitoolkit/graphics
junrue at common-lisp.net
junrue at common-lisp.net
Mon Apr 3 05:13:51 UTC 2006
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
More information about the Graphic-forms-cvs
mailing list