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)