[graphic-forms-cvs] r91 - in trunk: . src/demos/unblocked src/uitoolkit/system
junrue at common-lisp.net
junrue at common-lisp.net
Fri Apr 7 05:00:42 UTC 2006
Author: junrue
Date: Fri Apr 7 01:00:41 2006
New Revision: 91
Added:
trunk/src/demos/unblocked/double-buffered-event-dispatcher.lisp
Modified:
trunk/graphic-forms-tests.asd
trunk/src/demos/unblocked/scoreboard-panel.lisp
trunk/src/demos/unblocked/tiles-panel.lisp
trunk/src/demos/unblocked/unblocked-model.lisp
trunk/src/demos/unblocked/unblocked-window.lisp
trunk/src/uitoolkit/system/gdi32.lisp
trunk/src/uitoolkit/system/system-types.lisp
Log:
implemented scoreboard panel display; implemented double-buffering base event dispatcher and refactored tiles-panel-events accordingly
Modified: trunk/graphic-forms-tests.asd
==============================================================================
--- trunk/graphic-forms-tests.asd (original)
+++ trunk/graphic-forms-tests.asd Fri Apr 7 01:00:41 2006
@@ -63,6 +63,7 @@
:components
((:file "tiles")
(:file "unblocked-model")
+ (:file "double-buffered-event-dispatcher")
(:file "scoreboard-panel")
(:file "tiles-panel")
(:file "unblocked-window")))))
Added: trunk/src/demos/unblocked/double-buffered-event-dispatcher.lisp
==============================================================================
--- (empty file)
+++ trunk/src/demos/unblocked/double-buffered-event-dispatcher.lisp Fri Apr 7 01:00:41 2006
@@ -0,0 +1,66 @@
+;;;;
+;;;; double-buffered-event-dispatcher.lisp
+;;;;
+;;;; Copyright (C) 2006, Jack D. Unrue
+;;;; All rights reserved.
+;;;;
+;;;; Redistribution and use in source and binary forms, with or without
+;;;; modification, are permitted provided that the following conditions
+;;;; are met:
+;;;;
+;;;; 1. Redistributions of source code must retain the above copyright
+;;;; notice, this list of conditions and the following disclaimer.
+;;;;
+;;;; 2. Redistributions in binary form must reproduce the above copyright
+;;;; notice, this list of conditions and the following disclaimer in the
+;;;; documentation and/or other materials provided with the distribution.
+;;;;
+;;;; 3. Neither the names of the authors nor the names of its contributors
+;;;; may be used to endorse or promote products derived from this software
+;;;; without specific prior written permission.
+;;;;
+;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY
+;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS-
+;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY
+;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
+;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
+;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+;;;;
+
+(in-package :graphic-forms.uitoolkit.tests)
+
+(defvar *background-color* (gfg:make-color :red 0 :green #x80 :blue #x80))
+
+(defgeneric update-buffer (disp tiles)
+ (:documentation "Revises the image buffer so that the associated window can be repainted.")
+ (:method (disp tiles)
+ (declare (ignorable disp tiles))))
+
+(defclass double-buffered-event-dispatcher (gfw:event-dispatcher)
+ ((image-buffer
+ :accessor image-buffer-of
+ :initform nil)))
+
+(defmethod clear-buffer ((self double-buffered-event-dispatcher) gc)
+ (let ((image (image-buffer-of self)))
+ (setf (gfg:background-color gc) *background-color*)
+ (setf (gfg:foreground-color gc) *background-color*)
+ (gfg:draw-filled-rectangle gc (make-instance 'gfs:rectangle :location (gfs:make-point)
+ :size (gfg:size image)))))
+
+(defmethod dispose ((self double-buffered-event-dispatcher))
+ (let ((image (image-buffer-of self)))
+ (unless (or (null image) (gfs:disposed-p image))
+ (gfs:dispose image))
+ (setf (image-buffer-of self) nil)))
+
+(defmethod initialize-instance :after ((self double-buffered-event-dispatcher) &key buffer-size)
+ (setf (image-buffer-of self) (make-instance 'gfg:image :size buffer-size)))
+
+(defmethod gfw:event-paint ((self double-buffered-event-dispatcher) window time gc rect)
+ (declare (ignore window time rect))
+ (gfg:draw-image gc (image-buffer-of self) (gfs:make-point)))
Modified: trunk/src/demos/unblocked/scoreboard-panel.lisp
==============================================================================
--- trunk/src/demos/unblocked/scoreboard-panel.lisp (original)
+++ trunk/src/demos/unblocked/scoreboard-panel.lisp Fri Apr 7 01:00:41 2006
@@ -33,20 +33,27 @@
(in-package :graphic-forms.uitoolkit.tests)
-(defconstant +level-label+ "Level:")
-(defconstant +points-needed-label+ "Points Needed:")
-(defconstant +score-label+ "Score:")
+(defconstant +level-label+ "Level:")
+(defconstant +points-needed-label+ "Points Needed:")
+(defconstant +score-label+ "Score:")
-(defclass scoreboard-panel-events (gfw:event-dispatcher)
+(defconstant +scoreboard-text-margin+ 2)
+
+(defvar *text-color* (gfg:make-color :red 237 :green 232 :blue 14))
+
+(defvar *scoreboard-label-font-data* (gfg:make-font-data :face-name "Tahoma"
+ :point-size 14
+ :style '(:bold)))
+(defvar *scoreboard-value-font-data* (gfg:make-font-data :face-name "Tahoma"
+ :point-size 14))
+
+(defclass scoreboard-panel-events (double-buffered-event-dispatcher)
((label-font
:accessor label-font-of
:initform nil)
(value-font
:accessor value-font-of
- :initform nil)
- (size
- :accessor size-of
- :initform (gfs:make-size))))
+ :initform nil)))
(defmethod dispose ((self scoreboard-panel-events))
(let ((tmp-font (label-font-of self)))
@@ -56,43 +63,62 @@
(setf tmp-font (value-font-of self))
(unless (null tmp-font)
(gfs:dispose tmp-font)
- (setf (label-font-of self) nil))))
+ (setf (label-font-of self) nil)))
+ (call-next-method))
+
+(defun compute-scoreboard-size ()
+ (let* ((gc (make-instance 'gfg:graphics-context))
+ (font (make-instance 'gfg:font :gc gc :data *scoreboard-label-font-data*))
+ (metrics (gfg:metrics gc font))
+ (buffer-size (gfs:make-size)))
+ (unwind-protect
+ (progn
+ (setf (gfs:size-width buffer-size) (* (+ (length +points-needed-label+)
+ 2 ; space between label and value
+ 9) ; number of value characters
+ (gfg:average-char-width metrics)))
+ (setf (gfs:size-height buffer-size) (* (gfg:height metrics) 4)))
+
+ (gfs:dispose font)
+ (gfs:dispose gc))
+ buffer-size))
+
+(defmethod initialize-instance :after ((self scoreboard-panel-events) &key buffer-size)
+ (declare (ignorable buffer-size))
+ (let ((gc (make-instance 'gfg:graphics-context)))
+ (unwind-protect
+ (progn
+ (setf (label-font-of self) (make-instance 'gfg:font :gc gc :data *scoreboard-label-font-data*))
+ (setf (value-font-of self) (make-instance 'gfg:font :gc gc :data *scoreboard-value-font-data*)))
+ (gfs:dispose gc))))
-(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"
- :point-size 14
- :style '(:bold)))
- (value-font-data (gfg:make-font-data :face-name "Tahoma"
- :point-size 14))
- (extent-size nil)
- (pref-size (gfs:make-size))
- (font nil))
+(defmethod draw-scoreboard-row (gc row image-size label-font label-text value-font value-text)
+ (let* ((metrics (gfg:metrics gc label-font))
+ (text-pnt (gfs:make-point :x +scoreboard-text-margin+ :y (* row (gfg:height metrics)))))
+ (setf (gfg:font gc) label-font)
+ (setf (gfg:foreground-color gc) *text-color*)
+ (gfg:draw-text gc label-text text-pnt)
+ (setf (gfg:font gc) value-font)
+ (setf (gfs:point-x text-pnt) (- (- (gfs:size-width image-size) +scoreboard-text-margin+)
+ (gfs:size-width (gfg:text-extent gc value-text))))
+ (gfg:draw-text gc value-text text-pnt)))
+
+(defmethod update-buffer ((self scoreboard-panel-events) tiles)
+ (let ((gc (make-instance 'gfg:graphics-context :image (image-buffer-of self)))
+ (label-font (label-font-of self))
+ (value-font (value-font-of self))
+ (image-size (gfg:size (image-buffer-of self))))
(unwind-protect
(progn
- (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 +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)
- (value-font-of self) font
- (gfg:font gc) font
- extent-size (gfg:text-extent gc (format nil "~c9,999,999" #\Tab)))
- (incf (gfs:size-width pref-size) (gfs:size-width extent-size))
- (setf (size-of self) pref-size))
+ (clear-buffer self gc)
+ (draw-scoreboard-row gc 0 image-size label-font +level-label+ value-font (model-level))
+ (draw-scoreboard-row gc 1 image-size label-font +score-label+ value-font (model-score))
+ (draw-scoreboard-row gc 2 image-size label-font +points-needed-label+ value-font (model-points-needed)))
(gfs:dispose gc))))
(defclass scoreboard-panel (gfw:panel) ())
(defmethod gfw:preferred-size ((self scoreboard-panel) width-hint height-hint)
(declare (ignore width-hint height-hint))
- (size-of (gfw:dispatcher self)))
+ (let ((size (gfg:size (image-buffer-of (gfw:dispatcher self)))))
+ (gfs:make-size :width (+ (gfs:size-width size) 2) :height (+ (gfs:size-height size) 2))))
Modified: trunk/src/demos/unblocked/tiles-panel.lisp
==============================================================================
--- trunk/src/demos/unblocked/tiles-panel.lisp (original)
+++ trunk/src/demos/unblocked/tiles-panel.lisp Fri Apr 7 01:00:41 2006
@@ -33,23 +33,9 @@
(in-package :graphic-forms.uitoolkit.tests)
-(defconstant +tile-bmp-width+ 24)
-(defconstant +tile-bmp-height+ 24)
-
-(defvar *background-color* (gfg:make-color :red 0 :green #x80 :blue #x80))
-
-(defclass tiles-timer-events (gfw:event-dispatcher)
- ((panel-dispatcher
- :accessor panel-dispatcher
- :initarg :panel-dispatcher
- :initform nil)))
-
-(defmethod gfw:event-timer ((self tiles-timer-events) timer time)
- (declare (ignore timer time))
- (let ((tiles (model-tiles)))
- (collapse-tiles tiles)
- (update-buffer (panel-dispatcher self) tiles)
- (gfw:redraw (get-tiles-panel))))
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defconstant +tile-bmp-width+ 24)
+ (defconstant +tile-bmp-height+ 24))
(defun tiles->window (pnt)
(let ((xpos (1+ (* (gfs:point-x pnt) +tile-bmp-width+)))
@@ -66,16 +52,21 @@
nil
(gfs:make-point :x xpos :y ypos))))
-(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+
- +tile-bmp-width+)
- 2)
- :height (+ (* +vert-tile-count+
- +tile-bmp-height+)
- 2))))
- (tile-image-table
+(defclass tiles-timer-events (gfw:event-dispatcher)
+ ((panel-dispatcher
+ :accessor panel-dispatcher
+ :initarg :panel-dispatcher
+ :initform nil)))
+
+(defmethod gfw:event-timer ((self tiles-timer-events) timer time)
+ (declare (ignore timer time))
+ (let ((tiles (model-tiles)))
+ (collapse-tiles tiles)
+ (update-buffer (panel-dispatcher self) tiles)
+ (gfw:redraw (get-tiles-panel))))
+
+(defclass tiles-panel-events (double-buffered-event-dispatcher)
+ ((tile-image-table
:accessor tile-image-table-of
:initform (make-hash-table :test #'equal))
(mouse-tile
@@ -83,21 +74,16 @@
:initform nil)))
(defmethod dispose ((self tiles-panel-events))
- (let ((image (image-buffer-of self))
- (table (tile-image-table-of self)))
- (gfs:dispose image)
+ (let ((table (tile-image-table-of self)))
(maphash #'(lambda (kind image)
(declare (ignore kind))
(gfs:dispose image))
table))
- (setf (image-buffer-of self) nil)
- (setf (tile-image-table-of self) nil))
-
-(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)))
+ (setf (tile-image-table-of self) nil)
+ (call-next-method))
-(defmethod initialize-instance :after ((self tiles-panel-events) &key)
+(defmethod initialize-instance :after ((self tiles-panel-events) &key buffer-size)
+ (declare (ignorable buffer-size))
(let ((table (tile-image-table-of self))
(kind 1))
(loop for filename in '("blue-tile.bmp" "brown-tile.bmp" "red-tile.bmp"
@@ -141,19 +127,15 @@
(setf (mouse-tile-of self) nil)))
(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 (image-buffer-of self))
- (size (gfg:size image)))
- (setf (gfg:background-color gc) *background-color*)
- (setf (gfg:foreground-color gc) *background-color*)
- (gfg:draw-filled-rectangle gc (make-instance 'gfs:rectangle :location (gfs:make-point)
- :size size))
- (map-tiles #'(lambda (pnt kind)
- (unless (= kind 0)
- (gfg:draw-image gc (gethash kind image-table) (tiles->window pnt))))
- tiles)
- (gfs:dispose gc)))
+ (let ((gc (make-instance 'gfg:graphics-context :image (image-buffer-of self)))
+ (image-table (tile-image-table-of self)))
+ (clear-buffer self gc)
+ (unwind-protect
+ (map-tiles #'(lambda (pnt kind)
+ (unless (= kind 0)
+ (gfg:draw-image gc (gethash kind image-table) (tiles->window pnt))))
+ tiles)
+ (gfs:dispose gc))))
(defclass tiles-panel (gfw:panel) ())
Modified: trunk/src/demos/unblocked/unblocked-model.lisp
==============================================================================
--- trunk/src/demos/unblocked/unblocked-model.lisp (original)
+++ trunk/src/demos/unblocked/unblocked-model.lisp Fri Apr 7 01:00:41 2006
@@ -33,13 +33,13 @@
(in-package :graphic-forms.uitoolkit.tests)
-(defconstant +max-tile-kinds+ 6)
(defvar *tiles* nil)
(eval-when (:compile-toplevel :load-toplevel :execute)
- (defconstant +horz-tile-count+ 14)
- (defconstant +vert-tile-count+ 9))
+ (defconstant +max-tile-kinds+ 6)
+ (defconstant +horz-tile-count+ 16)
+ (defconstant +vert-tile-count+ 12))
(defun init-model-tiles ()
(setf *tiles* (init-tiles +horz-tile-count+ +vert-tile-count+ (1- +max-tile-kinds+)))
@@ -47,3 +47,12 @@
(defun model-tiles ()
*tiles*)
+
+(defun model-level ()
+ (format nil "~:d" 134))
+
+(defun model-points-needed ()
+ (format nil "~:d" 30964))
+
+(defun model-score ()
+ (format nil "~:d" 1548238))
Modified: trunk/src/demos/unblocked/unblocked-window.lisp
==============================================================================
--- trunk/src/demos/unblocked/unblocked-window.lisp (original)
+++ trunk/src/demos/unblocked/unblocked-window.lisp Fri Apr 7 01:00:41 2006
@@ -49,9 +49,12 @@
(defun new-unblocked (disp item time rect)
(declare (ignore disp item time rect))
(let ((tiles-disp (gfw:dispatcher *tiles-panel*))
+ (scoreboard-disp (gfw:dispatcher *scoreboard-panel*))
(tiles (init-model-tiles)))
+ (update-buffer scoreboard-disp tiles)
(collapse-tiles tiles)
(update-buffer tiles-disp tiles)
+ (gfw:redraw *scoreboard-panel*)
(gfw:redraw *tiles-panel*)))
(defun restart-unblocked (disp item time rect)
@@ -80,7 +83,12 @@
(:item "&Restart" :callback #'restart-unblocked)
(:item "Reveal &Move" :callback #'reveal-unblocked)
(:item "" :separator)
- (:item "E&xit" :callback #'quit-unblocked)))))))
+ (:item "E&xit" :callback #'quit-unblocked))))))
+ (scoreboard-buffer-size (compute-scoreboard-size))
+ (tile-buffer-size (gfs:make-size :width (+ (* +horz-tile-count+ +tile-bmp-width+)
+ 2)
+ :height (+ (* +vert-tile-count+ +tile-bmp-height+)
+ 2))))
(setf *unblocked-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'unblocked-win-events)
:layout (make-instance 'gfw:flow-layout
:style :vertical
@@ -90,11 +98,14 @@
(setf (gfw:menu-bar *unblocked-win*) menubar)
(setf *scoreboard-panel* (make-instance 'scoreboard-panel
:parent *unblocked-win*
- :dispatcher (make-instance 'scoreboard-panel-events)))
+ :style '(:border)
+ :dispatcher (make-instance 'scoreboard-panel-events
+ :buffer-size scoreboard-buffer-size)))
(setf *tiles-panel* (make-instance 'tiles-panel
:parent *unblocked-win*
:style '(:border)
- :dispatcher (make-instance 'tiles-panel-events)))
+ :dispatcher (make-instance 'tiles-panel-events
+ :buffer-size tile-buffer-size)))
(setf (gfw:text *unblocked-win*) "Graphic-Forms UnBlocked")
(gfw:pack *unblocked-win*)
(gfw:show *unblocked-win* t)))
Modified: trunk/src/uitoolkit/system/gdi32.lisp
==============================================================================
--- trunk/src/uitoolkit/system/gdi32.lisp (original)
+++ trunk/src/uitoolkit/system/gdi32.lisp Fri Apr 7 01:00:41 2006
@@ -243,6 +243,14 @@
(hdc HANDLE))
(defcfun
+ ("GetTextExtentPoint32A" get-text-extent-point)
+ BOOL
+ (hdc HANDLE)
+ (str :string)
+ (count INT)
+ (size LPTR))
+
+(defcfun
("GetTextMetricsA" get-text-metrics)
BOOL
(hdc HANDLE)
Modified: trunk/src/uitoolkit/system/system-types.lisp
==============================================================================
--- trunk/src/uitoolkit/system/system-types.lisp (original)
+++ trunk/src/uitoolkit/system/system-types.lisp Fri Apr 7 01:00:41 2006
@@ -207,6 +207,10 @@
(rgbred BYTE)
(rgbreserved BYTE))
+(defcstruct size
+ (cx LONG)
+ (cy LONG))
+
(defcstruct textmetrics
(tmheight LONG)
(tmascent LONG)
More information about the Graphic-forms-cvs
mailing list