April 2006 - graphic-forms-cvs@common-lisp.net

[graphic-forms-cvs] r94 - in trunk: . src/demos/unblocked
by junrue＠common-lisp.net 09 Apr '06

09 Apr '06

Author: junrue Date: Sun Apr 9 14:02:36 2006 New Revision: 94 Modified: trunk/build.lisp trunk/config.lisp trunk/graphic-forms-tests.asd trunk/src/demos/unblocked/double-buffered-event-dispatcher.lisp trunk/src/demos/unblocked/scoreboard-panel.lisp trunk/src/demos/unblocked/tiles-panel.lisp trunk/src/demos/unblocked/tiles.lisp trunk/src/demos/unblocked/unblocked-model.lisp trunk/src/demos/unblocked/unblocked-window.lisp Log: now using Cells experimentally as the data model for the unblocked demo Modified: trunk/build.lisp ============================================================================== --- trunk/build.lisp (original) +++ trunk/build.lisp Sun Apr 9 14:02:36 2006 @@ -44,6 +44,7 @@ (defvar *asdf-repo-root* (concatenate 'string *library-root* "asdf-repo/")) (defvar *project-root* "c:/projects/public/") +(setf *cells-dir* (concatenate 'string *asdf-repo-root* "cells/")) (setf *cffi-dir* (concatenate 'string *asdf-repo-root* "cffi-0.9.0/")) (setf *closer-mop-dir* (concatenate 'string *asdf-repo-root* "closer-mop/")) (setf *imagemagick-dir* "c:/Program Files/ImageMagick-6.2.6-Q16/") Modified: trunk/config.lisp ============================================================================== --- trunk/config.lisp (original) +++ trunk/config.lisp Sun Apr 9 14:02:36 2006 @@ -37,6 +37,7 @@ (in-package #:graphic-forms-system) +(defvar *cells-dir* "cells/") (defvar *cffi-dir* "cffi-0.9.0/") (defvar *closer-mop-dir* "closer-mop/") (defvar *imagemagick-dir* "c:/Program Files/ImageMagick-6.2.6-Q16/") @@ -51,6 +52,7 @@ `(ext:cd ,path)) (defun configure-asdf () + (pushnew *cells-dir* asdf:*central-registry* :test #'equal) (pushnew *cffi-dir* asdf:*central-registry* :test #'equal) (pushnew *closer-mop-dir* asdf:*central-registry* :test #'equal) (pushnew *lw-compat-dir* asdf:*central-registry* :test #'equal)) Modified: trunk/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Sun Apr 9 14:02:36 2006 @@ -54,6 +54,7 @@ :version "0.2.0" :author "Jack D. Unrue" :licence "BSD" + :depends-on ("cells") :components ((:module "src" :components Modified: trunk/src/demos/unblocked/double-buffered-event-dispatcher.lisp ============================================================================== --- trunk/src/demos/unblocked/double-buffered-event-dispatcher.lisp (original) +++ trunk/src/demos/unblocked/double-buffered-event-dispatcher.lisp Sun Apr 9 14:02:36 2006 @@ -35,10 +35,10 @@ (defvar *background-color* (gfg:make-color :red 0 :green #x80 :blue #x80)) -(defgeneric update-buffer (disp tiles) +(defgeneric update-buffer (disp) (:documentation "Revises the image buffer so that the associated window can be repainted.") - (:method (disp tiles) - (declare (ignorable disp tiles)))) + (:method (disp) + (declare (ignorable disp)))) (defclass double-buffered-event-dispatcher (gfw:event-dispatcher) ((image-buffer Modified: trunk/src/demos/unblocked/scoreboard-panel.lisp ============================================================================== --- trunk/src/demos/unblocked/scoreboard-panel.lisp (original) +++ trunk/src/demos/unblocked/scoreboard-panel.lisp Sun Apr 9 14:02:36 2006 @@ -92,9 +92,10 @@ (setf (value-font-of self) (make-instance 'gfg:font :gc gc :data *scoreboard-value-font-data*))) (gfs:dispose gc)))) -(defmethod draw-scoreboard-row (gc row image-size label-font label-text value-font value-text) +(defmethod draw-scoreboard-row (gc row image-size label-font label-text value-font value) (let* ((metrics (gfg:metrics gc label-font)) - (text-pnt (gfs:make-point :x +scoreboard-text-margin+ :y (* row (gfg:height metrics))))) + (text-pnt (gfs:make-point :x +scoreboard-text-margin+ :y (* row (gfg:height metrics)))) + (value-text (format nil "~:d" value))) (setf (gfg:font gc) label-font) (setf (gfg:foreground-color gc) *text-color*) (gfg:draw-text gc label-text text-pnt) @@ -103,8 +104,7 @@ (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) - (declare (ignore tiles)) +(defmethod update-buffer ((self scoreboard-panel-events)) (let ((gc (make-instance 'gfg:graphics-context :image (image-buffer-of self))) (label-font (label-font-of self)) (value-font (value-font-of self)) @@ -112,9 +112,9 @@ (unwind-protect (progn (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))) + (draw-scoreboard-row gc 1 image-size label-font +score-label+ value-font (game-score)) + (draw-scoreboard-row gc 0 image-size label-font +level-label+ value-font (game-level)) + (draw-scoreboard-row gc 2 image-size label-font +points-needed-label+ value-font (game-points-needed))) (gfs:dispose gc)))) (defclass scoreboard-panel (gfw:panel) ()) Modified: trunk/src/demos/unblocked/tiles-panel.lisp ============================================================================== --- trunk/src/demos/unblocked/tiles-panel.lisp (original) +++ trunk/src/demos/unblocked/tiles-panel.lisp Sun Apr 9 14:02:36 2006 @@ -95,7 +95,7 @@ (defmethod gfw:event-mouse-down ((self tiles-panel-events) panel time point button) (declare (ignore time)) - (let* ((tiles (model-tiles)) + (let* ((tiles (game-tiles)) (tile-pnt (window->tiles point)) (tile-kind (obtain-tile tiles tile-pnt)) (shape-pnts (shape-pnts-of self)) @@ -118,23 +118,18 @@ (defmethod gfw:event-mouse-up ((self tiles-panel-events) panel time point button) (declare (ignore time)) - (let* ((tiles (model-tiles)) - (tile-pnt (window->tiles point)) - (shape-pnts (shape-pnts-of self))) + (let ((tile-pnt (window->tiles point)) + (shape-pnts (shape-pnts-of self))) (if (and (eql button :left-button) shape-pnts (find tile-pnt shape-pnts :test #'eql-point)) - (progn - (loop for pnt in shape-pnts do (set-tile tiles pnt 0)) - (collapse-tiles tiles) - (update-buffer (gfw:dispatcher panel) tiles) - (gfw:redraw panel)) + (game-shape-data shape-pnts) (if shape-pnts (draw-tiles-directly panel shape-pnts (shape-kind-of self))))) (setf (shape-kind-of self) 0) (setf (shape-pnts-of self) nil)) -(defmethod update-buffer ((self tiles-panel-events) tiles) +(defmethod update-buffer ((self tiles-panel-events)) (let ((gc (make-instance 'gfg:graphics-context :image (image-buffer-of self))) (image-table (tile-image-table-of self))) (clear-buffer self gc) @@ -142,7 +137,7 @@ (map-tiles #'(lambda (pnt kind) (unless (= kind 0) (gfg:draw-image gc (gethash kind image-table) (tiles->window pnt)))) - tiles) + (game-tiles)) (gfs:dispose gc)))) (defclass tiles-panel (gfw:panel) ()) Modified: trunk/src/demos/unblocked/tiles.lisp ============================================================================== --- trunk/src/demos/unblocked/tiles.lisp (original) +++ trunk/src/demos/unblocked/tiles.lisp Sun Apr 9 14:02:36 2006 @@ -120,3 +120,10 @@ (let ((size (size-tiles tiles))) (dotimes (i (gfs:size-width size)) (setf (aref tiles i) (collapse-column (aref tiles i)))))) + +(defun clone-tiles (orig-tiles) + (let* ((width (gfs:size-width (size-tiles orig-tiles))) + (new-tiles (make-array width :initial-element nil))) + (dotimes (i width) + (setf (aref new-tiles i) (copy-seq (aref orig-tiles i)))) + new-tiles)) Modified: trunk/src/demos/unblocked/unblocked-model.lisp ============================================================================== --- trunk/src/demos/unblocked/unblocked-model.lisp (original) +++ trunk/src/demos/unblocked/unblocked-model.lisp Sun Apr 9 14:02:36 2006 @@ -33,26 +33,79 @@ (in-package :graphic-forms.uitoolkit.tests) - -(defvar *tiles* nil) - (eval-when (:compile-toplevel :load-toplevel :execute) (defconstant +max-tile-kinds+ 6) - (defconstant +horz-tile-count+ 16) + (defconstant +horz-tile-count+ 17) (defconstant +vert-tile-count+ 12)) -(defun init-model-tiles () - (setf *tiles* (init-tiles +horz-tile-count+ +vert-tile-count+ (1- +max-tile-kinds+))) - *tiles*) - -(defun model-tiles () - *tiles*) - -(defun model-level () - (format nil "~:d" 134)) +(defun factorial (n) + (if (zerop n) + 1 + (* n (factorial (1- n))))) + +(cells:defmodel unblocked-game-model () + ((level + :accessor level + :initform (cells:c? (let* ((lvl (if cells:.cache cells:.cache 1)) + (pnts-needed (* 20 (factorial lvl)))) + (if (>= (^score) pnts-needed) + (1+ lvl) + lvl)))) + (score + :accessor score + :initform (cells:c? (+ (if cells:.cache cells:.cache 0) + (* 5 (length (^shape-data)))))) + (points-needed + :accessor points-needed + :initform (cells:c? (* 20 (factorial (^level))))) + (shape-data + :accessor shape-data + :initform (cells:c-in nil)) + (tiles + :accessor tiles + :initform (cells:c? (let ((tmp nil) + (data (^shape-data))) + (if (null cells:.cache) + (progn + (setf tmp (init-tiles +horz-tile-count+ + +vert-tile-count+ + (1- +max-tile-kinds+))) + (collapse-tiles tmp)) + (if data + (progn + (setf tmp (clone-tiles cells:.cache)) + (loop for pnt in data do (set-tile tmp pnt 0)) + (collapse-tiles tmp)) + (setf tmp cells:.cache))) + tmp))))) + +(defvar *game* (make-instance 'unblocked-game-model)) + +(defun reset-game () + (cells:cells-reset) + (setf *game* (make-instance 'unblocked-game-model))) + +(defun game-tiles () + (tiles *game*)) + +(defun game-shape-data (pnts) + (setf (shape-data *game*) pnts)) + +(defun game-level () + (level *game*)) + +(defun game-points-needed () + (- (points-needed *game*) (score *game*))) + +(defun game-score () + (score *game*)) + +(defun update-panel (panel) + (update-buffer (gfw:dispatcher panel)) + (gfw:redraw panel)) -(defun model-points-needed () - (format nil "~:d" 30964)) +(cells:defobserver score ((self unblocked-game-model)) + (update-panel (get-scoreboard-panel))) -(defun model-score () - (format nil "~:d" 1548238)) +(cells:defobserver tiles ((self unblocked-game-model)) + (update-panel (get-tiles-panel))) Modified: trunk/src/demos/unblocked/unblocked-window.lisp ============================================================================== --- trunk/src/demos/unblocked/unblocked-window.lisp (original) +++ trunk/src/demos/unblocked/unblocked-window.lisp Sun Apr 9 14:02:36 2006 @@ -48,12 +48,11 @@ (defun new-unblocked (disp item time rect) (declare (ignore disp item time rect)) + (reset-game) (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) + (scoreboard-disp (gfw:dispatcher *scoreboard-panel*))) + (update-buffer scoreboard-disp) + (update-buffer tiles-disp) (gfw:redraw *scoreboard-panel*) (gfw:redraw *tiles-panel*))) @@ -83,7 +82,9 @@ (: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))) + (:item "&Help" + :submenu ((:item "&About")))))) (scoreboard-buffer-size (compute-scoreboard-size)) (tile-buffer-size (gfs:make-size :width (+ (* +horz-tile-count+ +tile-bmp-width+) 2)

1 0

[graphic-forms-cvs] r93 - in trunk/src: demos/unblocked uitoolkit/graphics uitoolkit/widgets
by junrue＠common-lisp.net 08 Apr '06

08 Apr '06

Author: junrue Date: Sat Apr 8 01:34:22 2006 New Revision: 93 Modified: trunk/src/demos/unblocked/scoreboard-panel.lisp trunk/src/demos/unblocked/tiles-panel.lisp trunk/src/demos/unblocked/tiles.lisp trunk/src/uitoolkit/graphics/graphics-context.lisp trunk/src/uitoolkit/graphics/image-data.lisp trunk/src/uitoolkit/widgets/menu-language.lisp trunk/src/uitoolkit/widgets/top-level.lisp Log: even better selection behavior in the unblocked demo Modified: trunk/src/demos/unblocked/scoreboard-panel.lisp ============================================================================== --- trunk/src/demos/unblocked/scoreboard-panel.lisp (original) +++ trunk/src/demos/unblocked/scoreboard-panel.lisp Sat Apr 8 01:34:22 2006 @@ -104,6 +104,7 @@ (gfg:draw-text gc value-text text-pnt))) (defmethod update-buffer ((self scoreboard-panel-events) tiles) + (declare (ignore 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)) Modified: trunk/src/demos/unblocked/tiles-panel.lisp ============================================================================== --- trunk/src/demos/unblocked/tiles-panel.lisp (original) +++ trunk/src/demos/unblocked/tiles-panel.lisp Sat Apr 8 01:34:22 2006 @@ -52,27 +52,26 @@ nil (gfs:make-point :x xpos :y ypos)))) -(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 - :accessor mouse-tile-of + (shape-kind + :accessor shape-kind-of + :initform 0) + (shape-pnts + :accessor shape-pnts-of :initform nil))) +(defun draw-tiles-directly (panel shape-pnts kind) + (let ((gc (make-instance 'gfg:graphics-context :widget panel)) + (image-table (tile-image-table-of (gfw:dispatcher panel)))) + (unwind-protect + (loop for pnt in shape-pnts + do (let ((image (gethash kind image-table))) + (gfg:draw-image gc image (tiles->window pnt)))) + (gfs:dispose gc)))) + (defmethod dispose ((self tiles-panel-events)) (let ((table (tile-image-table-of self))) (maphash #'(lambda (kind image) @@ -80,6 +79,7 @@ (gfs:dispose image)) table)) (setf (tile-image-table-of self) nil) + (setf (shape-pnts-of self) nil) (call-next-method)) (defmethod initialize-instance :after ((self tiles-panel-events) &key buffer-size) @@ -94,38 +94,45 @@ (incf kind))))) (defmethod gfw:event-mouse-down ((self tiles-panel-events) panel time point button) - (declare (ignore panel time)) - (let ((tile-pnt (window->tiles point))) - (if (and (eql button :left-button) (not (null tile-pnt))) - (setf (mouse-tile-of self) tile-pnt) - (setf (mouse-tile-of self) nil)))) + (declare (ignore time)) + (let* ((tiles (model-tiles)) + (tile-pnt (window->tiles point)) + (tile-kind (obtain-tile tiles tile-pnt)) + (shape-pnts (shape-pnts-of self)) + (tmp-table (make-hash-table :test #'equalp))) + (unless (or (null shape-pnts) (find tile-pnt shape-pnts :test #'eql-point)) + (draw-tiles-directly panel shape-pnts (shape-kind-of self)) + (setf (shape-pnts-of self) nil) + (setf (shape-kind-of self) 0)) + (setf shape-pnts nil) + (if (and (eql button :left-button) (> tile-kind 0)) + (shape-tiles tiles tile-pnt tmp-table)) + (when (> (hash-table-count tmp-table) 1) + (maphash #'(lambda (pnt kind) + (declare (ignore kind)) + (push pnt shape-pnts)) + tmp-table) + (setf (shape-kind-of self) tile-kind) + (setf (shape-pnts-of self) shape-pnts) + (draw-tiles-directly panel shape-pnts +max-tile-kinds+)))) (defmethod gfw:event-mouse-up ((self tiles-panel-events) panel time point button) (declare (ignore time)) - (let ((tile-pnt (window->tiles point)) - (tiles (model-tiles))) - (if (and (eql button :left-button) (not (null tile-pnt)) (eql-point tile-pnt (mouse-tile-of self))) - (let ((results (make-hash-table :test #'equalp))) - (unless (= (obtain-tile tiles tile-pnt) 0) - (shape-tiles tiles tile-pnt results) - (when (> (hash-table-count results) 1) - (let ((gc (make-instance 'gfg:graphics-context :widget panel)) - (image-table (tile-image-table-of self))) - (unwind-protect - (maphash #'(lambda (pnt kind) - (declare (ignore kind)) - (set-tile tiles pnt 0) - (gfg:draw-image gc - (gethash +max-tile-kinds+ image-table) - (tiles->window pnt))) - results) - (gfs:dispose gc))) - (gfw:start (make-instance 'gfw:timer - :initial-delay 100 - :delay 0 - :dispatcher (make-instance 'tiles-timer-events - :panel-dispatcher self))))))) - (setf (mouse-tile-of self) nil))) + (let* ((tiles (model-tiles)) + (tile-pnt (window->tiles point)) + (shape-pnts (shape-pnts-of self))) + (if (and (eql button :left-button) + shape-pnts + (find tile-pnt shape-pnts :test #'eql-point)) + (progn + (loop for pnt in shape-pnts do (set-tile tiles pnt 0)) + (collapse-tiles tiles) + (update-buffer (gfw:dispatcher panel) tiles) + (gfw:redraw panel)) + (if shape-pnts + (draw-tiles-directly panel shape-pnts (shape-kind-of self))))) + (setf (shape-kind-of self) 0) + (setf (shape-pnts-of self) nil)) (defmethod update-buffer ((self tiles-panel-events) tiles) (let ((gc (make-instance 'gfg:graphics-context :image (image-buffer-of self))) Modified: trunk/src/demos/unblocked/tiles.lisp ============================================================================== --- trunk/src/demos/unblocked/tiles.lisp (original) +++ trunk/src/demos/unblocked/tiles.lisp Sat Apr 8 01:34:22 2006 @@ -69,6 +69,8 @@ (= (gfs:point-y pnt1) (gfs:point-y pnt2)))) (defun obtain-tile (tiles pnt) + (if (null pnt) + (return-from obtain-tile 0)) (let ((column (aref tiles (gfs:point-x pnt)))) (aref column (gfs:point-y pnt)))) @@ -92,7 +94,7 @@ (neighbor-point tiles orig-pnt 0 1) (neighbor-point tiles orig-pnt -1 0) (neighbor-point tiles orig-pnt 1 0)) - when (not (null pnt)) + when pnt collect pnt)) (defun shape-tiles (tiles tile-pnt results) Modified: trunk/src/uitoolkit/graphics/graphics-context.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-context.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-context.lisp Sat Apr 8 01:34:22 2006 @@ -334,7 +334,7 @@ (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))) + (if (transparency-pixel-of im) (progn (setf tr-mask (transparency-mask im)) (let ((hmask (gfs:handle tr-mask)) Modified: trunk/src/uitoolkit/graphics/image-data.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/image-data.lisp (original) +++ trunk/src/uitoolkit/graphics/image-data.lisp Sat Apr 8 01:34:22 2006 @@ -211,7 +211,7 @@ (t (error 'gfs:toolkit-error :detail "pathname or string required")))) (let ((handle (gfs:handle data))) - (when (and (not (null handle)) (not (cffi:null-pointer-p handle))) + (when (and handle (not (cffi:null-pointer-p handle))) (destroy-image handle) (setf (slot-value data 'gfs:handle) nil) (setf handle nil)) Modified: trunk/src/uitoolkit/widgets/menu-language.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu-language.lisp (original) +++ trunk/src/uitoolkit/widgets/menu-language.lisp Sat Apr 8 01:34:22 2006 @@ -102,18 +102,18 @@ (sub-tmp nil)) (loop for opt in form do (cond - ((not (null cb-tmp)) + (cb-tmp (setf callback opt) (setf cb-tmp nil) (setf disp nil)) - ((not (null disp-tmp)) + (disp-tmp (setf disp opt) (setf disp-tmp nil) (setf callback nil)) - ((not (null image-tmp)) + (image-tmp (setf image opt) (setf image-tmp nil)) - ((not (null sub-tmp)) + (sub-tmp (setf sub opt) (setf sub-tmp nil)) ((and (not (eq opt :item)) (null label)) Modified: trunk/src/uitoolkit/widgets/top-level.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/top-level.lisp (original) +++ trunk/src/uitoolkit/widgets/top-level.lisp Sat Apr 8 01:34:22 2006 @@ -134,7 +134,7 @@ (setf style (list style))) (let ((classname +toplevel-noerasebkgnd-window-classname+) (register-func #'register-toplevel-noerasebkgnd-window-class)) - (when (not (null (find :workspace style))) + (when (find :workspace style) (setf classname +toplevel-erasebkgnd-window-classname+) (setf register-func #'register-toplevel-erasebkgnd-window-class)) (init-window win classname register-func style owner title)))

1 0

[graphic-forms-cvs] r92 - trunk/src/demos/unblocked
by junrue＠common-lisp.net 07 Apr '06

07 Apr '06

Author: junrue Date: Fri Apr 7 02:12:06 2006 New Revision: 92 Modified: trunk/src/demos/unblocked/tiles-panel.lisp trunk/src/demos/unblocked/tiles.lisp Log: slightly faster drawing of selected shapes 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 02:12:06 2006 @@ -39,7 +39,7 @@ (defun tiles->window (pnt) (let ((xpos (1+ (* (gfs:point-x pnt) +tile-bmp-width+))) - (ypos (1+ (* (gfs:point-y pnt) +tile-bmp-height+))) + (ypos (1+ (* (- (1- +vert-tile-count+) (gfs:point-y pnt)) +tile-bmp-height+))) (size (gfw:client-size (get-tiles-panel)))) (if (or (>= xpos (gfs:size-width size)) (>= ypos (gfs:size-height size))) nil @@ -109,18 +109,19 @@ (unless (= (obtain-tile tiles tile-pnt) 0) (shape-tiles tiles tile-pnt results) (when (> (hash-table-count results) 1) - (maphash #'(lambda (pnt kind) - (declare (ignore kind)) - (set-tile tiles pnt +max-tile-kinds+)) - results) - (update-buffer self tiles) - (gfw:redraw panel) - (maphash #'(lambda (pnt kind) - (declare (ignore kind)) - (set-tile tiles pnt 0)) - results) + (let ((gc (make-instance 'gfg:graphics-context :widget panel)) + (image-table (tile-image-table-of self))) + (unwind-protect + (maphash #'(lambda (pnt kind) + (declare (ignore kind)) + (set-tile tiles pnt 0) + (gfg:draw-image gc + (gethash +max-tile-kinds+ image-table) + (tiles->window pnt))) + results) + (gfs:dispose gc))) (gfw:start (make-instance 'gfw:timer - :initial-delay 333 + :initial-delay 100 :delay 0 :dispatcher (make-instance 'tiles-timer-events :panel-dispatcher self))))))) Modified: trunk/src/demos/unblocked/tiles.lisp ============================================================================== --- trunk/src/demos/unblocked/tiles.lisp (original) +++ trunk/src/demos/unblocked/tiles.lisp Fri Apr 7 02:12:06 2006 @@ -51,14 +51,14 @@ (let ((size (size-tiles tiles))) (dotimes (j (gfs:size-height size)) (dotimes (i (gfs:size-width size)) - (let ((kind (aref (aref tiles i) (- (1- (gfs:size-height size)) j)))) + (let ((kind (aref (aref tiles i) j))) (funcall func (gfs:make-point :x i :y j) kind)))))) (defun print-tiles (tiles) (let ((size (size-tiles tiles))) (dotimes (j (gfs:size-height size)) (dotimes (i (gfs:size-width size)) - (let ((kind (aref (aref tiles i) (- (1- (gfs:size-height size)) j)))) + (let ((kind (aref (aref tiles i) j))) (if (< kind 0) (print " ") (format t "~d " kind)))) @@ -105,8 +105,9 @@ (defun collapse-column (column-tiles) (let ((new-column (make-array (length column-tiles) :initial-element 0)) - (new-index 0)) - (dotimes (i (length column-tiles)) + (new-index 0) + (count (length column-tiles))) + (dotimes (i count) (let ((kind (aref column-tiles i))) (unless (zerop kind) (setf (aref new-column new-index) kind)

1 0

[graphic-forms-cvs] r91 - in trunk: . src/demos/unblocked src/uitoolkit/system
by junrue＠common-lisp.net 07 Apr '06

07 Apr '06

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)

1 0

[graphic-forms-cvs] r90 - in trunk/src: . demos/unblocked tests/uitoolkit uitoolkit/graphics uitoolkit/widgets
by junrue＠common-lisp.net 04 Apr '06

04 Apr '06

Author: junrue Date: Tue Apr 4 01:04:44 2006 New Revision: 90 Modified: trunk/src/demos/unblocked/tiles-panel.lisp trunk/src/demos/unblocked/unblocked-window.lisp trunk/src/packages.lisp trunk/src/tests/uitoolkit/blue-tile.bmp trunk/src/tests/uitoolkit/brown-tile.bmp trunk/src/tests/uitoolkit/gold-tile.bmp trunk/src/tests/uitoolkit/green-tile.bmp trunk/src/tests/uitoolkit/image-tester.lisp trunk/src/tests/uitoolkit/pink-tile.bmp trunk/src/tests/uitoolkit/red-tile.bmp trunk/src/uitoolkit/graphics/image.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/timer.lisp Log: fixed timer bugs; implemented collapse redraw when tile shape is selected Modified: trunk/src/demos/unblocked/tiles-panel.lisp ============================================================================== --- trunk/src/demos/unblocked/tiles-panel.lisp (original) +++ trunk/src/demos/unblocked/tiles-panel.lisp Tue Apr 4 01:04:44 2006 @@ -36,17 +36,32 @@ (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)))) + (defun tiles->window (pnt) - (let ((xpos (* (gfs:point-x pnt) +tile-bmp-width+)) - (ypos (* (gfs:point-y pnt) +tile-bmp-height+)) + (let ((xpos (1+ (* (gfs:point-x pnt) +tile-bmp-width+))) + (ypos (1+ (* (gfs:point-y pnt) +tile-bmp-height+))) (size (gfw:client-size (get-tiles-panel)))) (if (or (>= xpos (gfs:size-width size)) (>= ypos (gfs:size-height size))) nil (gfs:make-point :x xpos :y ypos)))) (defun window->tiles (pnt) - (let ((xpos (floor (/ (gfs:point-x pnt) +tile-bmp-width+))) - (ypos (- +vert-tile-count+ (1+ (floor (/ (gfs:point-y pnt) +tile-bmp-height+)))))) + (let ((xpos (floor (/ (1- (gfs:point-x pnt)) +tile-bmp-width+))) + (ypos (- +vert-tile-count+ (1+ (floor (/ (1- (gfs:point-y pnt)) +tile-bmp-height+)))))) (if (or (>= xpos +horz-tile-count+) (>= ypos +vert-tile-count+)) nil (gfs:make-point :x xpos :y ypos)))) @@ -54,10 +69,12 @@ (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+) - :height (* +vert-tile-count+ - +tile-bmp-height+)))) + :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 :accessor tile-image-table-of :initform (make-hash-table :test #'equal)) @@ -111,22 +128,30 @@ (set-tile tiles pnt +max-tile-kinds+)) results) (update-buffer self tiles) - (gfw:redraw panel))))) + (gfw:redraw panel) + (maphash #'(lambda (pnt kind) + (declare (ignore kind)) + (set-tile tiles pnt 0)) + results) + (gfw:start (make-instance 'gfw:timer + :initial-delay 333 + :delay 0 + :dispatcher (make-instance 'tiles-timer-events + :panel-dispatcher self))))))) (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)) - (pixel-pnt (gfs:make-point))) - (setf (gfg:background-color gc) gfg:*color-black*) - (setf (gfg:foreground-color gc) gfg:*color-black*) + (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 (gfg:size (image-buffer-of self)))) + :size size)) (map-tiles #'(lambda (pnt kind) (unless (= kind 0) - (let ((image (gethash kind image-table))) - (gfg:with-transparency (image pixel-pnt) - (gfg:draw-image gc image (tiles->window pnt)))))) + (gfg:draw-image gc (gethash kind image-table) (tiles->window pnt)))) tiles) (gfs:dispose gc))) @@ -138,4 +163,5 @@ (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)))) + (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/unblocked-window.lisp ============================================================================== --- trunk/src/demos/unblocked/unblocked-window.lisp (original) +++ trunk/src/demos/unblocked/unblocked-window.lisp Tue Apr 4 01:04:44 2006 @@ -93,6 +93,7 @@ :dispatcher (make-instance 'scoreboard-panel-events))) (setf *tiles-panel* (make-instance 'tiles-panel :parent *unblocked-win* + :style '(:border) :dispatcher (make-instance 'tiles-panel-events))) (setf (gfw:text *unblocked-win*) "Graphic-Forms UnBlocked") (gfw:pack *unblocked-win*) Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Tue Apr 4 01:04:44 2006 @@ -197,7 +197,7 @@ #:transparency #:transparency-pixel-of #:transparency-mask - #:with-transparency + #:with-image-transparency #:xor-mode-p ;; conditions Modified: trunk/src/tests/uitoolkit/blue-tile.bmp ============================================================================== Binary files. No diff available. Modified: trunk/src/tests/uitoolkit/brown-tile.bmp ============================================================================== Binary files. No diff available. Modified: trunk/src/tests/uitoolkit/gold-tile.bmp ============================================================================== Binary files. No diff available. Modified: trunk/src/tests/uitoolkit/green-tile.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 Tue Apr 4 01:04:44 2006 @@ -63,7 +63,7 @@ (gfg:draw-image gc *happy-image* pnt) (incf (gfs:point-x pnt) 36) - (gfg:with-transparency (*happy-image* pixel-pnt1) + (gfg:with-image-transparency (*happy-image* pixel-pnt1) (gfg:draw-image gc (gfg:transparency-mask *happy-image*) pnt) (incf (gfs:point-x pnt) 36) (gfg:draw-image gc *happy-image* pnt)) @@ -72,7 +72,7 @@ (incf (gfs:point-y pnt) 36) (gfg:draw-image gc *bw-image* pnt) (incf (gfs:point-x pnt) 24) - (gfg:with-transparency (*bw-image* pixel-pnt1) + (gfg:with-image-transparency (*bw-image* pixel-pnt1) (gfg:draw-image gc (gfg:transparency-mask *bw-image*) pnt) (incf (gfs:point-x pnt) 24) (gfg:draw-image gc *bw-image* pnt)) @@ -81,7 +81,7 @@ (incf (gfs:point-y pnt) 20) (gfg:draw-image gc *true-image* pnt) (incf (gfs:point-x pnt) 20) - (gfg:with-transparency (*true-image* pixel-pnt2) + (gfg:with-image-transparency (*true-image* pixel-pnt2) (gfg:draw-image gc (gfg:transparency-mask *true-image*) pnt) (incf (gfs:point-x pnt) 20) (gfg:draw-image gc *true-image* pnt)))) Modified: trunk/src/tests/uitoolkit/pink-tile.bmp ============================================================================== Binary files. No diff available. Modified: trunk/src/tests/uitoolkit/red-tile.bmp ============================================================================== Binary files. No diff available. Modified: trunk/src/uitoolkit/graphics/image.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/image.lisp (original) +++ trunk/src/uitoolkit/graphics/image.lisp Tue Apr 4 01:04:44 2006 @@ -37,7 +37,7 @@ ;;; helper macros and functions ;;; -(defmacro with-transparency ((image pnt) &body body) +(defmacro with-image-transparency ((image pnt) &body body) (let ((orig-pnt (gensym))) `(let ((,orig-pnt (transparency-pixel-of ,image))) (unwind-protect Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Tue Apr 4 01:04:44 2006 @@ -347,9 +347,10 @@ (if (null timer) (gfs::kill-timer (cffi:null-pointer) wparam) (progn - (event-timer (dispatcher timer) timer (event-time tc)) - (when (<= (delay-of timer) 0) - (stop timer))))) + (if (<= (delay-of timer) 0) + (stop timer) + (reset-timer-to-delay timer (delay-of timer))) + (event-timer (dispatcher timer) timer (event-time tc))))) 0) ;;; Modified: trunk/src/uitoolkit/widgets/timer.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/timer.lisp (original) +++ trunk/src/uitoolkit/widgets/timer.lisp Tue Apr 4 01:04:44 2006 @@ -58,6 +58,14 @@ (defun gf-set-timer (delay) (gfs::set-timer nil 0 delay #'timer_proc)) +(defun reset-timer-to-delay (timer delay) + (remove-timer (thread-context) timer) + (let ((id (gf-set-timer delay))) + (if (zerop id) + (error 'gfs:win32-error :detail "set-timer failed")) + (setf (slot-value timer 'id) id) + (put-timer (thread-context) timer))) + (defun clamp-delay-values (init-delay delay) "Adjust delay settings based on system-defined limits." ;; @@ -105,15 +113,10 @@ ;; tick; the interval will be adjusted (or the timer killed) ;; as part of processing the first event ;; - (let ((init-delay (initial-delay-of self)) - (delay (delay-of self))) + (let ((init-delay (initial-delay-of self))) (if (> init-delay 0) - (setf delay init-delay)) - (let ((id (gf-set-timer delay))) - (if (zerop id) - (error 'gfs:win32-error :detail "set-timer failed")) - (setf (slot-value self 'id) id) - (put-timer (thread-context) self)))) + (reset-timer-to-delay self init-delay) + (reset-timer-to-delay self (delay-of self))))) (defmethod stop ((self timer)) (remove-timer (thread-context) self)) ;; kill-timer will be called on the next tick

1 0

[graphic-forms-cvs] r89 - in trunk: docs/manual src/tests/uitoolkit src/uitoolkit/widgets
by junrue＠common-lisp.net 04 Apr '06

04 Apr '06

Author: junrue Date: Mon Apr 3 22:50:20 2006 New Revision: 89 Modified: trunk/docs/manual/api.texinfo trunk/src/tests/uitoolkit/drawing-tester.lisp trunk/src/tests/uitoolkit/hello-world.lisp trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/uitoolkit/widgets/panel.lisp trunk/src/uitoolkit/widgets/top-level.lisp trunk/src/uitoolkit/widgets/window.lisp Log: modified class registration to differentiate between window styles for which the system automatically paints the background vs. those that the app must paint Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Mon Apr 3 22:50:20 2006 @@ -310,17 +310,24 @@ @item :borderless a window with a one-pixel border (so not really @emph{borderless} in the strictest sense); no frame icon, system menu, minimize/maximize buttons, -or close buttons +or close buttons; the system does not paint the background +@item :frame +the standard top-level frame style with system menu, close box, and +minimize/maximize buttons; this window type is resizable; it differs +from the @code{:workspace} style in that the application is completely +responsible for painting the contents @item :miniframe a resizable window with a shorter than normal caption; has a close box -but no system menu or minimize/maximize buttons +but no system menu or minimize/maximize buttons; the system does not +paint the background @item :palette similar to the @code{:miniframe} style, but in this case the window -does not have resize frame +does not have a resize frame; the system does not paint the background @item :workspace the standard top-level frame style with system menu, close box, and -minimize/maximize buttons; this window is resizable and normally hosts -the primary user interface for an application +minimize/maximize buttons; this window type is resizable; it differs +from the @code{:frame} style in that the system paints the background +using the @sc{color_appworkspace} color scheme @end table @end deffn @end deftp Modified: trunk/src/tests/uitoolkit/drawing-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/drawing-tester.lisp (original) +++ trunk/src/tests/uitoolkit/drawing-tester.lisp Mon Apr 3 22:50:20 2006 @@ -362,7 +362,7 @@ (setf *drawing-dispatcher* (make-instance 'drawing-win-events)) (setf (draw-func-of *drawing-dispatcher*) #'draw-arcs) (setf *drawing-win* (make-instance 'gfw:top-level :dispatcher *drawing-dispatcher* - :style '(:workspace))) + :style '(:frame))) (setf (gfw:menu-bar *drawing-win*) menubar) (setf (gfw:size *drawing-win*) (gfs:make-size :width 390 :height 310)) (setf (gfw:text *drawing-win*) "Drawing Tester") Modified: trunk/src/tests/uitoolkit/hello-world.lisp ============================================================================== --- trunk/src/tests/uitoolkit/hello-world.lisp (original) +++ trunk/src/tests/uitoolkit/hello-world.lisp Mon Apr 3 22:50:20 2006 @@ -61,7 +61,7 @@ (defun run-hello-world-internal () (let ((menubar nil)) (setf *hello-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'hellowin-events) - :style '(:workspace))) + :style '(:frame))) (setf menubar (gfw:defmenu ((:item "&File" :submenu ((:item "E&xit" :callback #'exit-fn)))))) (setf (gfw:menu-bar *hello-win*) menubar) Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Mon Apr 3 22:50:20 2006 @@ -70,6 +70,14 @@ :initarg :id :initform 0))) +(defmethod gfw:event-paint ((self layout-tester-widget-events) window time gc rect) + (declare (ignore time rect)) + (setf (gfg:background-color gc) gfg:*color-white*) + (setf (gfg:foreground-color gc) gfg:*color-white*) + (gfg:draw-filled-rectangle gc + (make-instance 'gfs:rectangle :location (gfs:make-point) + :size (gfw:client-size window)))) + (defclass test-panel (gfw:panel) ()) (defmethod gfw:preferred-size ((win test-panel) width-hint height-hint) Modified: trunk/src/uitoolkit/widgets/panel.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/panel.lisp (original) +++ trunk/src/uitoolkit/widgets/panel.lisp Mon Apr 3 22:50:20 2006 @@ -43,7 +43,7 @@ (register-window-class +panel-window-classname+ (cffi:get-callback 'uit_widgets_wndproc) gfs::+cs-dblclks+ - gfs::+color-btnface+)) + -1)) ;;; ;;; methods Modified: trunk/src/uitoolkit/widgets/top-level.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/top-level.lisp (original) +++ trunk/src/uitoolkit/widgets/top-level.lisp Mon Apr 3 22:50:20 2006 @@ -33,7 +33,8 @@ (in-package :graphic-forms.uitoolkit.widgets) -(defconstant +toplevel-window-classname+ "GraphicFormsTopLevel") +(defconstant +toplevel-erasebkgnd-window-classname+ "GraphicFormsTopLevelEraseBkgnd") +(defconstant +toplevel-noerasebkgnd-window-classname+ "GraphicFormsTopLevelNoEraseBkgnd") (defconstant +default-window-title+ "New Window") @@ -41,12 +42,18 @@ ;;; helper functions ;;; -(defun register-toplevel-window-class () - (register-window-class +toplevel-window-classname+ +(defun register-toplevel-erasebkgnd-window-class () + (register-window-class +toplevel-erasebkgnd-window-classname+ (cffi:get-callback 'uit_widgets_wndproc) gfs::+cs-dblclks+ gfs::+color-appworkspace+)) +(defun register-toplevel-noerasebkgnd-window-class () + (register-window-class +toplevel-noerasebkgnd-window-classname+ + (cffi:get-callback 'uit_widgets_wndproc) + gfs::+cs-dblclks+ + -1)) + ;;; ;;; methods ;;; @@ -102,7 +109,7 @@ gfs::+ws-caption+)) (setf ex-flags (logior gfs::+ws-ex-appwindow+ gfs::+ws-ex-toolwindow+))) - ((eq sym :workspace) + ((or (eq sym :workspace) (eq sym :frame)) (setf std-flags (logior gfs::+ws-overlappedwindow+ gfs::+ws-clipsiblings+ gfs::+ws-clipchildren+)) @@ -125,7 +132,12 @@ (setf title +default-window-title+)) (if (not (listp style)) (setf style (list style))) - (init-window win +toplevel-window-classname+ #'register-toplevel-window-class style owner title)) + (let ((classname +toplevel-noerasebkgnd-window-classname+) + (register-func #'register-toplevel-noerasebkgnd-window-class)) + (when (not (null (find :workspace style))) + (setf classname +toplevel-erasebkgnd-window-classname+) + (setf register-func #'register-toplevel-erasebkgnd-window-class)) + (init-window win classname register-func style owner title))) (defmethod menu-bar :before ((win top-level)) (if (gfs:disposed-p win) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Mon Apr 3 22:50:20 2006 @@ -124,7 +124,9 @@ gfs::+image-cursor+ 0 0 (logior gfs::+lr-defaultcolor+ gfs::+lr-shared+))) - (setf gfs::hbrush (cffi:make-pointer (1+ bkgcolor))) + (setf gfs::hbrush (if (< bkgcolor 0) + (cffi:null-pointer) + (cffi:make-pointer (1+ bkgcolor)))) (setf gfs::menuname (cffi:null-pointer)) (setf gfs::classname str-ptr) (setf gfs::smallicon (cffi:null-pointer))

1 0

[graphic-forms-cvs] r88 - in trunk/src: . demos/unblocked tests/uitoolkit uitoolkit/widgets
by junrue＠common-lisp.net 04 Apr '06

04 Apr '06

Author: junrue Date: Mon Apr 3 21:56:18 2006 New Revision: 88 Modified: trunk/src/demos/unblocked/tiles-panel.lisp trunk/src/demos/unblocked/tiles.lisp trunk/src/demos/unblocked/unblocked-model.lisp trunk/src/demos/unblocked/unblocked-window.lisp trunk/src/packages.lisp trunk/src/tests/uitoolkit/brown-tile.bmp trunk/src/uitoolkit/widgets/event.lisp Log: additional image/graphics-context testing by virtue of implementing selected tile highlighting Modified: trunk/src/demos/unblocked/tiles-panel.lisp ============================================================================== --- trunk/src/demos/unblocked/tiles-panel.lisp (original) +++ trunk/src/demos/unblocked/tiles-panel.lisp Mon Apr 3 21:56:18 2006 @@ -37,12 +37,19 @@ (defconstant +tile-bmp-height+ 24) (defun tiles->window (pnt) - (gfs:make-point :x (* (gfs:point-x pnt) +tile-bmp-width+) - :y (* (gfs:point-y pnt) +tile-bmp-height+))) + (let ((xpos (* (gfs:point-x pnt) +tile-bmp-width+)) + (ypos (* (gfs:point-y pnt) +tile-bmp-height+)) + (size (gfw:client-size (get-tiles-panel)))) + (if (or (>= xpos (gfs:size-width size)) (>= ypos (gfs:size-height size))) + nil + (gfs:make-point :x xpos :y ypos)))) (defun window->tiles (pnt) - (gfs:make-point :x (floor (/ (gfs:point-x pnt) +tile-bmp-width+)) - :y (floor (/ (gfs:point-y pnt) +tile-bmp-height+)))) + (let ((xpos (floor (/ (gfs:point-x pnt) +tile-bmp-width+))) + (ypos (- +vert-tile-count+ (1+ (floor (/ (gfs:point-y pnt) +tile-bmp-height+)))))) + (if (or (>= xpos +horz-tile-count+) (>= ypos +vert-tile-count+)) + nil + (gfs:make-point :x xpos :y ypos)))) (defclass tiles-panel-events (gfw:event-dispatcher) ((image-buffer @@ -53,7 +60,10 @@ +tile-bmp-height+)))) (tile-image-table :accessor tile-image-table-of - :initform (make-hash-table :test #'equal)))) + :initform (make-hash-table :test #'equal)) + (mouse-tile + :accessor mouse-tile-of + :initform nil))) (defmethod dispose ((self tiles-panel-events)) (let ((image (image-buffer-of self)) @@ -73,13 +83,37 @@ (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" - "green-tile.bmp" "pink-tile.bmp" "red-tile.bmp") + (loop for filename in '("blue-tile.bmp" "brown-tile.bmp" "red-tile.bmp" + "green-tile.bmp" "pink-tile.bmp" "gold-tile.bmp") do (let ((image (make-instance 'gfg:image))) (gfg:load image filename) (setf (gethash kind table) image) (incf kind))))) +(defmethod gfw:event-mouse-down ((self tiles-panel-events) panel time point button) + (declare (ignore panel time)) + (let ((tile-pnt (window->tiles point))) + (if (and (eql button :left-button) (not (null tile-pnt))) + (setf (mouse-tile-of self) tile-pnt) + (setf (mouse-tile-of self) nil)))) + +(defmethod gfw:event-mouse-up ((self tiles-panel-events) panel time point button) + (declare (ignore time)) + (let ((tile-pnt (window->tiles point)) + (tiles (model-tiles))) + (if (and (eql button :left-button) (not (null tile-pnt)) (eql-point tile-pnt (mouse-tile-of self))) + (let ((results (make-hash-table :test #'equalp))) + (unless (= (obtain-tile tiles tile-pnt) 0) + (shape-tiles tiles tile-pnt results) + (when (> (hash-table-count results) 1) + (maphash #'(lambda (pnt kind) + (declare (ignore kind)) + (set-tile tiles pnt +max-tile-kinds+)) + results) + (update-buffer self tiles) + (gfw:redraw panel))))) + (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)) Modified: trunk/src/demos/unblocked/tiles.lisp ============================================================================== --- trunk/src/demos/unblocked/tiles.lisp (original) +++ trunk/src/demos/unblocked/tiles.lisp Mon Apr 3 21:56:18 2006 @@ -72,6 +72,10 @@ (let ((column (aref tiles (gfs:point-x pnt)))) (aref column (gfs:point-y pnt)))) +(defun set-tile (tiles pnt kind) + (let ((column (aref tiles (gfs:point-x pnt)))) + (setf (aref column (gfs:point-y pnt)) kind))) + (defun neighbor-point (tiles orig-pnt delta-x delta-y) (let ((size (size-tiles tiles)) (new-x (+ (gfs:point-x orig-pnt) delta-x)) Modified: trunk/src/demos/unblocked/unblocked-model.lisp ============================================================================== --- trunk/src/demos/unblocked/unblocked-model.lisp (original) +++ trunk/src/demos/unblocked/unblocked-model.lisp Mon Apr 3 21:56:18 2006 @@ -35,6 +35,15 @@ (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)) + +(defun init-model-tiles () + (setf *tiles* (init-tiles +horz-tile-count+ +vert-tile-count+ (1- +max-tile-kinds+))) + *tiles*) + +(defun model-tiles () + *tiles*) 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 21:56:18 2006 @@ -40,10 +40,16 @@ (defvar *tiles-panel* nil) (defvar *unblocked-win* nil) +(defun get-tiles-panel () + *tiles-panel*) + +(defun get-scoreboard-panel () + *scoreboard-panel*) + (defun new-unblocked (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))) + (tiles (init-model-tiles))) (collapse-tiles tiles) (update-buffer tiles-disp tiles) (gfw:redraw *tiles-panel*))) Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Mon Apr 3 21:56:18 2006 @@ -232,12 +232,9 @@ #:window ;; constants - #:left-button ;; FIXME: should be a keyword #:maximized ;; FIXME: should be a keyword - #:middle-button ;; FIXME: should be a keyword #:minimized ;; FIXME: should be a keyword #:restored ;; FIXME: should be a keyword - #:right-button ;; FIXME: should be a keyword #:+vk-break+ #:+vk-backspace+ #:+vk-tab+ Modified: trunk/src/tests/uitoolkit/brown-tile.bmp ============================================================================== Binary files. No diff available. Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Mon Apr 3 21:56:18 2006 @@ -232,37 +232,37 @@ (defmethod process-message (hwnd (msg (eql gfs::+wm-lbuttondblclk+)) wparam lparam) (declare (ignore wparam)) - (process-mouse-message #'event-mouse-double hwnd lparam 'left-button)) + (process-mouse-message #'event-mouse-double hwnd lparam :left-button)) (defmethod process-message (hwnd (msg (eql gfs::+wm-lbuttondown+)) wparam lparam) (declare (ignore wparam)) - (process-mouse-message #'event-mouse-down hwnd lparam 'left-button)) + (process-mouse-message #'event-mouse-down hwnd lparam :left-button)) (defmethod process-message (hwnd (msg (eql gfs::+wm-lbuttonup+)) wparam lparam) (declare (ignore wparam)) - (process-mouse-message #'event-mouse-up hwnd lparam 'left-button)) + (process-mouse-message #'event-mouse-up hwnd lparam :left-button)) (defmethod process-message (hwnd (msg (eql gfs::+wm-mbuttondblclk+)) wparam lparam) (declare (ignore wparam)) - (process-mouse-message #'event-mouse-double hwnd lparam 'middle-button)) + (process-mouse-message #'event-mouse-double hwnd lparam :middle-button)) (defmethod process-message (hwnd (msg (eql gfs::+wm-mbuttondown+)) wparam lparam) (declare (ignore wparam)) - (process-mouse-message #'event-mouse-down hwnd lparam 'middle-button)) + (process-mouse-message #'event-mouse-down hwnd lparam :middle-button)) (defmethod process-message (hwnd (msg (eql gfs::+wm-mbuttonup+)) wparam lparam) (declare (ignore wparam)) - (process-mouse-message #'event-mouse-up hwnd lparam 'middle-button)) + (process-mouse-message #'event-mouse-up hwnd lparam :middle-button)) (defmethod process-message (hwnd (msg (eql gfs::+wm-mousemove+)) wparam lparam) - (let ((btn-sym 'left-button)) + (let ((btn-sym :left-button)) (cond ((= (logand wparam gfs::+mk-mbutton+) gfs::+mk-mbutton+) - (setf btn-sym 'middle-button)) + (setf btn-sym :middle-button)) ((= (logand wparam gfs::+mk-rbutton+) gfs::+mk-rbutton+) - (setf btn-sym 'right-button)) + (setf btn-sym :right-button)) (t - (setf btn-sym 'left-button))) + (setf btn-sym :left-button))) (process-mouse-message #'event-mouse-move hwnd lparam btn-sym))) (defmethod process-message (hwnd (msg (eql gfs::+wm-move+)) wparam lparam) @@ -308,15 +308,15 @@ (defmethod process-message (hwnd (msg (eql gfs::+wm-rbuttondblclk+)) wparam lparam) (declare (ignore wparam)) - (process-mouse-message #'event-mouse-double hwnd lparam 'right-button)) + (process-mouse-message #'event-mouse-double hwnd lparam :right-button)) (defmethod process-message (hwnd (msg (eql gfs::+wm-rbuttondown+)) wparam lparam) (declare (ignore wparam)) - (process-mouse-message #'event-mouse-down hwnd lparam 'right-button)) + (process-mouse-message #'event-mouse-down hwnd lparam :right-button)) (defmethod process-message (hwnd (msg (eql gfs::+wm-rbuttonup+)) wparam lparam) (declare (ignore wparam)) - (process-mouse-message #'event-mouse-up hwnd lparam 'right-button)) + (process-mouse-message #'event-mouse-up hwnd lparam :right-button)) (defmethod process-message (hwnd (msg (eql gfs::+wm-size+)) wparam lparam) (declare (ignore lparam))

1 0

[graphic-forms-cvs] r87 - trunk/src/uitoolkit/graphics
by junrue＠common-lisp.net 03 Apr '06

03 Apr '06

Author: junrue Date: Mon Apr 3 02:42:38 2006 New Revision: 87 Modified: trunk/src/uitoolkit/graphics/graphics-classes.lisp trunk/src/uitoolkit/graphics/graphics-context.lisp trunk/src/uitoolkit/graphics/image-data.lisp trunk/src/uitoolkit/graphics/image.lisp Log: fixed more GDI handle leaks Modified: trunk/src/uitoolkit/graphics/graphics-classes.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-classes.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-classes.lisp Mon Apr 3 02:42:38 2006 @@ -114,9 +114,6 @@ :initform 1) (pen-handle :accessor pen-handle-of - :initform (cffi:null-pointer)) - (orig-pen-handle - :accessor orig-pen-handle-of :initform (cffi:null-pointer))) (:documentation "This class represents the context associated with drawing primitives.")) 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 02:42:38 2006 @@ -91,10 +91,8 @@ (setf (pen-handle-of gc) new-hpen) (setf old-hpen (gfs::select-object (gfs:handle gc) new-hpen)) (gfs::set-miter-limit (gfs:handle gc) (miter-limit gc) (cffi:null-pointer)) - (if (gfs:null-handle-p (orig-pen-handle-of gc)) - (setf (orig-pen-handle-of gc) old-hpen) - (unless (gfs:null-handle-p old-hpen) - (gfs::delete-object old-hpen))))))) + (unless (gfs:null-handle-p old-hpen) + (gfs::delete-object old-hpen)))))) (defun call-rect-function (fn name hdc rect) (let ((pnt (gfs:location rect)) @@ -227,9 +225,7 @@ (gfs::set-bk-color hdc rgb))) (defmethod gfs:dispose ((self graphics-context)) - (unless (gfs:null-handle-p (orig-pen-handle-of self)) - (gfs::select-object (gfs:handle self) (orig-pen-handle-of self))) - (setf (orig-pen-handle-of self) nil) + (gfs::select-object (gfs:handle self) (gfs::get-stock-object gfs::+null-pen+)) (gfs::delete-object (pen-handle-of self)) (setf (pen-handle-of self) nil) (let ((fn (dc-destructor-of self))) @@ -369,7 +365,9 @@ gfs::width gfs::height memdc2 - 0 0 gfs::+blt-srcpaint+)) + 0 0 gfs::+blt-srcpaint+) + (gfs::delete-dc memdc2) + (gfs::delete-object hcopy)) (gfs:dispose tr-mask)) (progn (gfs::select-object memdc himage) Modified: trunk/src/uitoolkit/graphics/image-data.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/image-data.lisp (original) +++ trunk/src/uitoolkit/graphics/image-data.lisp Mon Apr 3 02:42:38 2006 @@ -182,8 +182,10 @@ (setf gfs::rgbreserved 0) (setf gfs::rgbred (scale-quantum-to-byte red)) (setf gfs::rgbgreen (scale-quantum-to-byte green)) - (setf gfs::rgbblue (scale-quantum-to-byte blue)))))) - hbmp))))) + (setf gfs::rgbblue (scale-quantum-to-byte blue))))))) + (unless (gfs:null-handle-p screen-dc) + (gfs::release-dc (cffi:null-pointer) screen-dc)) + hbmp)))) ;;; ;;; methods Modified: trunk/src/uitoolkit/graphics/image.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/image.lisp (original) +++ trunk/src/uitoolkit/graphics/image.lisp Mon Apr 3 02:42:38 2006 @@ -48,17 +48,18 @@ (defun clone-bitmap (horig) (let ((hclone (cffi:null-pointer)) + (screen-dc (gfs::get-dc (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)) + (setf hclone (gfs::create-compatible-bitmap screen-dc 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+)))) + (unless (gfs:null-handle-p screen-dc) + (gfs::release-dc (cffi:null-pointer) screen-dc)) hclone)) ;;; @@ -88,12 +89,12 @@ (cffi:with-foreign-slots ((gfs::bisize gfs::biwidth gfs::biheight gfs::biplanes gfs::bibitcount gfs::bicompression) bih-ptr gfs::bitmapinfoheader) - (setf gfs::bisize (cffi:foreign-type-size 'gfs::bitmapinfoheader) - gfs::biwidth (gfs:size-width size) - gfs::biheight (- (gfs:size-height size)) - gfs::biplanes 1 - gfs::bibitcount 32 - gfs::bicompression gfs::+bi-rgb+) + (setf gfs::bisize (cffi:foreign-type-size 'gfs::bitmapinfoheader) + gfs::biwidth (gfs:size-width size) + gfs::biheight (- (gfs:size-height size)) + gfs::biplanes 1 + gfs::bibitcount 32 + gfs::bicompression gfs::+bi-rgb+) (let ((nptr (cffi:null-pointer)) (hbmp (cffi:null-pointer))) (cffi:with-foreign-object (buffer :pointer) @@ -125,8 +126,7 @@ (let ((pixel-pnt (transparency-pixel-of im)) (hbmp (gfs:handle im)) (hmask (cffi:null-pointer)) - (nptr (cffi:null-pointer)) - (old-bg 0)) + (nptr (cffi:null-pointer))) (unless (null pixel-pnt) (cffi:with-foreign-object (bmp-ptr 'gfs::bitmap) (gfs::get-object (gfs:handle im) (cffi:foreign-type-size 'gfs::bitmap) bmp-ptr) @@ -136,9 +136,9 @@ (error 'gfs:win32-error :detail "create-bitmap failed")) (gfs::with-compatible-dcs (nptr memdc1 memdc2) (gfs::select-object memdc1 hbmp) - (setf old-bg (gfs::set-bk-color memdc1 - (gfs::get-pixel memdc1 (gfs:point-x pixel-pnt) (gfs:point-y pixel-pnt)))) + (gfs::set-bk-color memdc1 (gfs::get-pixel memdc1 + (gfs:point-x pixel-pnt) + (gfs:point-y pixel-pnt))) (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)))) + (gfs::bit-blt memdc2 0 0 gfs::width gfs::height memdc1 0 0 gfs::+blt-srccopy+))) + (make-instance 'image :handle hmask)))))

1 0

[graphic-forms-cvs] r86 - in trunk: . src/demos/unblocked src/uitoolkit/graphics
by junrue＠common-lisp.net 03 Apr '06

03 Apr '06

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

1 0

[graphic-forms-cvs] r85 - in trunk: . docs/manual src/demos src/demos/unblocked src/tests/uitoolkit src/uitoolkit/graphics src/uitoolkit/widgets
by junrue＠common-lisp.net 03 Apr '06

03 Apr '06

Author: junrue Date: Sun Apr 2 23:24:46 2006 New Revision: 85 Added: trunk/src/demos/ trunk/src/demos/unblocked/ trunk/src/demos/unblocked/scoreboard-panel.lisp trunk/src/demos/unblocked/tiles.lisp trunk/src/demos/unblocked/unblocked-model.lisp trunk/src/demos/unblocked/unblocked-panel.lisp trunk/src/demos/unblocked/unblocked-window.lisp trunk/src/tests/uitoolkit/blue-tile.bmp (contents, props changed) trunk/src/tests/uitoolkit/brown-tile.bmp (contents, props changed) trunk/src/tests/uitoolkit/gold-tile.bmp (contents, props changed) trunk/src/tests/uitoolkit/green-tile.bmp (contents, props changed) trunk/src/tests/uitoolkit/pink-tile.bmp (contents, props changed) trunk/src/tests/uitoolkit/red-tile.bmp (contents, props changed) Modified: trunk/docs/manual/api.texinfo trunk/graphic-forms-tests.asd trunk/src/tests/uitoolkit/drawing-tester.lisp trunk/src/tests/uitoolkit/event-tester.lisp trunk/src/tests/uitoolkit/hello-world.lisp trunk/src/tests/uitoolkit/image-tester.lisp trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/tests/uitoolkit/windlg.lisp trunk/src/uitoolkit/graphics/graphics-classes.lisp trunk/src/uitoolkit/graphics/graphics-context.lisp trunk/src/uitoolkit/graphics/image.lisp trunk/src/uitoolkit/widgets/button.lisp trunk/src/uitoolkit/widgets/label.lisp trunk/src/uitoolkit/widgets/panel.lisp trunk/src/uitoolkit/widgets/top-level.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp Log: initial code for blocks game Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Sun Apr 2 23:24:46 2006 @@ -299,8 +299,30 @@ @anchor{top-level} @deftp Class top-level -Base class for @ref{window}s that can be moved and resized by the -user, and which normally have title bars. +Base class for @ref{window}s that are self-contained and parented to +the @ref{root-window}. Except for the @code{:palette} style, they are +normally resizable have title bars (also called 'captions'). +@deffn Initarg :style +The :style initarg is a list of keywords that define the overall +look-and-feel of the window being created. Applications may choose +from one of the following primary style keywords: +@table @code +@item :borderless +a window with a one-pixel border (so not really @emph{borderless} in the +strictest sense); no frame icon, system menu, minimize/maximize buttons, +or close buttons +@item :miniframe +a resizable window with a shorter than normal caption; has a close box +but no system menu or minimize/maximize buttons +@item :palette +similar to the @code{:miniframe} style, but in this case the window +does not have resize frame +@item :workspace +the standard top-level frame style with system menu, close box, and +minimize/maximize buttons; this window is resizable and normally hosts +the primary user interface for an application +@end table +@end deffn @end deftp @anchor{widget} Modified: trunk/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Sun Apr 2 23:24:46 2006 @@ -35,7 +35,15 @@ (defpackage #:graphic-forms.uitoolkit.tests (:nicknames #:gft) - (:use :common-lisp :lisp-unit)) + (:use :common-lisp :lisp-unit) + (:export + #:run-drawing-tester + #:run-event-tester + #:run-hello-world + #:run-image-tester + #:run-layout-tester + #:run-windlg + #:unblocked)) (print "Graphic-Forms UI Toolkit Tests") (print "Copyright (c) 2006 by Jack D. Unrue") @@ -49,7 +57,16 @@ :components ((:module "src" :components - ((:module "tests" + ((:module "demos" + :components + ((:module "unblocked" + :components + ((:file "tiles") + (:file "unblocked-model") + (:file "scoreboard-panel") + (:file "unblocked-panel") + (:file "unblocked-window"))))) + (:module "tests" :components ((:module "uitoolkit" :components Added: trunk/src/demos/unblocked/scoreboard-panel.lisp ============================================================================== --- (empty file) +++ trunk/src/demos/unblocked/scoreboard-panel.lisp Sun Apr 2 23:24:46 2006 @@ -0,0 +1,87 @@ +;;;; +;;;; scoreboard-panel.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) + +(defclass scoreboard-panel-events (gfw: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)))) + +(defmethod dispose ((self scoreboard-panel-events)) + (let ((tmp-font (label-font-of self))) + (unless (null tmp-font) + (gfs:dispose tmp-font) + (setf (label-font-of self) nil)) + (setf tmp-font (value-font-of self)) + (unless (null tmp-font) + (gfs:dispose tmp-font) + (setf (label-font-of self) nil)))) + +(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)) + (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 "Next Level Score:") + (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)) + (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))) Added: trunk/src/demos/unblocked/tiles.lisp ============================================================================== --- (empty file) +++ trunk/src/demos/unblocked/tiles.lisp Sun Apr 2 23:24:46 2006 @@ -0,0 +1,115 @@ +;;;; +;;;; tiles.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) + +(defstruct tile (kind 0) (location (gfs:make-point))) + +(defun init-tiles (width height kinds) + (let* ((tiles (make-array width :initial-element nil))) + (dotimes (i width) + (let ((column (make-array height :initial-element 0))) + (setf (aref tiles i) column) + (dotimes (j height) + (setf (aref column j) (random (1+ kinds)))))) + tiles)) + +(defun size-tiles (tiles) + (gfs:make-size :width (length tiles) :height (length (aref tiles 0)))) + +(defun map-tiles (func tiles) + (let ((size (size-tiles tiles))) + (dotimes (j (gfs:size-height size)) + (dotimes (i (gfs:size-width size)) + (let ((kind (aref (aref tiles i) (- (1- (gfs:size-height size)) j)))) + (funcall func (gfs:make-point :x i :y j) kind)))))) + +(defun print-tiles (tiles) + (let ((size (size-tiles tiles))) + (dotimes (j (gfs:size-height size)) + (dotimes (i (gfs:size-width size)) + (let ((kind (aref (aref tiles i) (- (1- (gfs:size-height size)) j)))) + (if (< kind 0) + (print " ") + (format t "~d " kind)))) + (format t "~%")))) + +(defun eql-point (pnt1 pnt2) + (and (= (gfs:point-x pnt1) (gfs:point-x pnt2)) + (= (gfs:point-y pnt1) (gfs:point-y pnt2)))) + +(defun obtain-tile (tiles pnt) + (let ((column (aref tiles (gfs:point-x pnt)))) + (aref column (gfs:point-y pnt)))) + +(defun neighbor-point (tiles orig-pnt delta-x delta-y) + (let ((size (size-tiles tiles)) + (new-x (+ (gfs:point-x orig-pnt) delta-x)) + (new-y (+ (gfs:point-y orig-pnt) delta-y))) + (unless (or (< new-x 0) + (< new-y 0) + (>= new-x (gfs:size-width size)) + (>= new-y (gfs:size-height size))) + (return-from neighbor-point (gfs:make-point :x new-x :y new-y))) + nil)) + +(defun neighbor-points (tiles orig-pnt) + (loop for pnt in (list (neighbor-point tiles orig-pnt 0 -1) + (neighbor-point tiles orig-pnt 0 1) + (neighbor-point tiles orig-pnt -1 0) + (neighbor-point tiles orig-pnt 1 0)) + when (not (null pnt)) + collect pnt)) + +(defun shape-tiles (tiles tile-pnt results) + (when (null (gethash tile-pnt results)) + (let ((kind (obtain-tile tiles tile-pnt))) + (setf (gethash tile-pnt results) kind) + (loop for pnt2 in (neighbor-points tiles tile-pnt) + when (= kind (obtain-tile tiles pnt2)) + do (shape-tiles tiles pnt2 results))))) + +(defun collapse-column (column-tiles) + (let ((new-column (make-array (length column-tiles) :initial-element 0)) + (new-index 0)) + (dotimes (i (length column-tiles)) + (let ((kind (aref column-tiles i))) + (unless (zerop kind) + (setf (aref new-column new-index) kind) + (incf new-index)))) + new-column)) + +(defun collapse-tiles (tiles) + (let ((size (size-tiles tiles))) + (dotimes (i (gfs:size-width size)) + (setf (aref tiles i) (collapse-column (aref tiles i)))))) Added: trunk/src/demos/unblocked/unblocked-model.lisp ============================================================================== --- (empty file) +++ trunk/src/demos/unblocked/unblocked-model.lisp Sun Apr 2 23:24:46 2006 @@ -0,0 +1,40 @@ +;;;; +;;;; unblocked-model.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) + +(defconstant +max-tile-kinds+ 6) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defconstant +horz-tile-count+ 14) + (defconstant +vert-tile-count+ 9)) Added: trunk/src/demos/unblocked/unblocked-panel.lisp ============================================================================== --- (empty file) +++ trunk/src/demos/unblocked/unblocked-panel.lisp Sun Apr 2 23:24:46 2006 @@ -0,0 +1,103 @@ +;;;; +;;;; unblocked-panel.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) + +(defconstant +tile-bmp-width+ 24) +(defconstant +tile-bmp-height+ 24) + +(defun tiles->window (pnt) + (gfs:make-point :x (* (gfs:point-x pnt) +tile-bmp-width+) + :y (* (gfs:point-y pnt) +tile-bmp-height+))) + +(defun window->tiles (pnt) + (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) + ((image-buffer + :accessor image-buffer-of + :initform (make-instance 'gfg:image :size (gfs:make-size :width (* +horz-tile-count+ + +tile-bmp-width+) + :height (* +vert-tile-count+ + +tile-bmp-height+)))) + (tile-image-table + :accessor tile-image-table-of + :initform (make-hash-table :test #'equal)))) + +(defmethod dispose ((self unblocked-panel-events)) + (let ((image (image-buffer-of self)) + (table (tile-image-table-of self))) + (gfs:dispose image) + (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 unblocked-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) + (let ((table (tile-image-table-of self)) + (kind 1)) + (loop for filename in '("blue-tile.bmp" "brown-tile.bmp" "gold-tile.bmp" + "green-tile.bmp" "pink-tile.bmp" "red-tile.bmp") + do (let ((image (make-instance 'gfg:image))) + (gfg:load image filename) + (setf (gethash kind table) image) + (incf kind))))) + +(defmethod update-buffer ((self unblocked-panel-events) tiles) + (let ((gc (make-instance 'gfg:graphics-context :image (image-buffer-of self))) + (image-table (tile-image-table-of self))) + (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))) + +(defclass unblocked-panel (gfw:panel) ()) + +(defmethod gfs:dispose ((self unblocked-panel)) + (dispose (gfw:dispatcher self)) + (call-next-method)) + +(defmethod gfw:preferred-size ((self unblocked-panel) width-hint height-hint) + (declare (ignore width-hint height-hint)) + (gfg:size (image-buffer-of (gfw:dispatcher self)))) Added: trunk/src/demos/unblocked/unblocked-window.lisp ============================================================================== --- (empty file) +++ trunk/src/demos/unblocked/unblocked-window.lisp Sun Apr 2 23:24:46 2006 @@ -0,0 +1,84 @@ +;;;; +;;;; unblocked-window.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) + +(defconstant +spacing+ 4) +(defconstant +margin+ 4) + +(defvar *unblocked-win* nil) + +(defun new-unblocked (disp item time rect) + (declare (ignore disp item time rect))) + +(defun restart-unblocked (disp item time rect) + (declare (ignore disp item time rect))) + +(defun reveal-unblocked (disp item time rect) + (declare (ignore disp item time rect))) + +(defun quit-unblocked (disp item time rect) + (declare (ignore disp item time rect)) + (gfs:dispose *unblocked-win*) + (setf *unblocked-win* nil) + (gfw:shutdown 0)) + +(defclass unblocked-win-events (gfw:event-dispatcher) ()) + +(defmethod gfw:event-close ((disp unblocked-win-events) window time) + (declare (ignore window time)) + (quit-unblocked disp nil nil nil)) + +(defun unblocked-startup () + (let ((menubar (gfw:defmenu ((:item "&File" + :submenu ((:item "&New" :callback #'new-unblocked) + (:item "&Restart" :callback #'restart-unblocked) + (:item "Reveal &Move" :callback #'reveal-unblocked) + (:item "" :separator) + (: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 + :spacing +spacing+ + :margin +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 (gfw:text *unblocked-win*) "Graphic-Forms UnBlocked") + (gfw:pack *unblocked-win*) + (gfw:show *unblocked-win* t))) + +(defun unblocked () + (gfw:startup "UnBlocked" #'unblocked-startup)) Added: trunk/src/tests/uitoolkit/blue-tile.bmp ============================================================================== Binary file. No diff available. Added: trunk/src/tests/uitoolkit/brown-tile.bmp ============================================================================== Binary file. No diff available. Modified: trunk/src/tests/uitoolkit/drawing-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/drawing-tester.lisp (original) +++ trunk/src/tests/uitoolkit/drawing-tester.lisp Sun Apr 2 23:24:46 2006 @@ -362,7 +362,7 @@ (setf *drawing-dispatcher* (make-instance 'drawing-win-events)) (setf (draw-func-of *drawing-dispatcher*) #'draw-arcs) (setf *drawing-win* (make-instance 'gfw:top-level :dispatcher *drawing-dispatcher* - :style '(:style-workspace))) + :style '(:workspace))) (setf (gfw:menu-bar *drawing-win*) menubar) (setf (gfw:size *drawing-win*) (gfs:make-size :width 390 :height 310)) (setf (gfw:text *drawing-win*) "Drawing Tester") Modified: trunk/src/tests/uitoolkit/event-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/event-tester.lisp (original) +++ trunk/src/tests/uitoolkit/event-tester.lisp Sun Apr 2 23:24:46 2006 @@ -227,7 +227,7 @@ (exit-md (make-instance 'event-tester-exit-dispatcher)) (menubar nil)) (setf *event-tester-window* (make-instance 'gfw:top-level :dispatcher (make-instance 'event-tester-window-events) - :style '(:style-workspace))) + :style '(:workspace))) (setf menubar (gfw:defmenu ((:item "&File" :callback #'manage-file-menu :submenu ((:item "Timer" :callback #'manage-timer) (:item "" :separator) Added: trunk/src/tests/uitoolkit/gold-tile.bmp ============================================================================== Binary file. No diff available. Added: trunk/src/tests/uitoolkit/green-tile.bmp ============================================================================== Binary file. No diff available. Modified: trunk/src/tests/uitoolkit/hello-world.lisp ============================================================================== --- trunk/src/tests/uitoolkit/hello-world.lisp (original) +++ trunk/src/tests/uitoolkit/hello-world.lisp Sun Apr 2 23:24:46 2006 @@ -61,7 +61,7 @@ (defun run-hello-world-internal () (let ((menubar nil)) (setf *hello-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'hellowin-events) - :style '(:style-workspace))) + :style '(:workspace))) (setf menubar (gfw:defmenu ((:item "&File" :submenu ((:item "E&xit" :callback #'exit-fn)))))) (setf (gfw:menu-bar *hello-win*) menubar) Modified: trunk/src/tests/uitoolkit/image-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/image-tester.lisp (original) +++ trunk/src/tests/uitoolkit/image-tester.lisp Sun Apr 2 23:24:46 2006 @@ -102,7 +102,7 @@ (gfg::load *bw-image* "blackwhite20x16.bmp") (gfg::load *true-image* "truecolor16x16.bmp") (setf *image-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'image-events) - :style '(:style-workspace))) + :style '(:workspace))) (setf (gfw:size *image-win*) (gfs:make-size :width 250 :height 200)) (setf (gfw:text *image-win*) "Image Tester") (setf menubar (gfw:defmenu ((:item "&File" Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Sun Apr 2 23:24:46 2006 @@ -348,7 +348,7 @@ (vis-menu-disp (make-instance 'child-menu-dispatcher :sub-disp-class 'visibility-child-dispatcher :check-test-fn #'gfw:visible-p))) (setf *layout-tester-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'layout-tester-events) - :style '(:style-workspace) + :style '(:workspace) :layout (make-instance 'gfw:flow-layout :spacing +spacing-delta+ :margins +margin-delta+))) Added: trunk/src/tests/uitoolkit/pink-tile.bmp ============================================================================== Binary file. No diff available. Added: trunk/src/tests/uitoolkit/red-tile.bmp ============================================================================== Binary file. No diff available. Modified: trunk/src/tests/uitoolkit/windlg.lisp ============================================================================== --- trunk/src/tests/uitoolkit/windlg.lisp (original) +++ trunk/src/tests/uitoolkit/windlg.lisp Sun Apr 2 23:24:46 2006 @@ -73,7 +73,7 @@ (declare (ignore disp item time rect)) (let ((window (make-instance 'gfw:top-level :dispatcher (make-instance 'test-borderless-events) :owner *main-win* - :style '(:style-borderless)))) + :style '(:borderless)))) (setf (gfw:size window) (gfs:make-size :width 300 :height 250)) (gfw:center-on-owner window) (gfw:show window t))) @@ -82,7 +82,7 @@ (declare (ignore disp item time rect)) (let ((window (make-instance 'gfw:top-level :dispatcher (make-instance 'test-mini-events) :owner *main-win* - :style '(:style-miniframe)))) + :style '(:miniframe)))) (setf (gfw:location window) (gfs:make-point :x 250 :y 150)) (setf (gfw:size window) (gfs:make-size :width 150 :height 225)) (setf (gfw:text window) "Mini Frame") @@ -92,7 +92,7 @@ (declare (ignore disp item time rect)) (let ((window (make-instance 'gfw:top-level :dispatcher (make-instance 'test-mini-events) :owner *main-win* - :style '(:style-palette)))) + :style '(:palette)))) (setf (gfw:location window) (gfs:make-point :x 250 :y 150)) (setf (gfw:size window) (gfs:make-size :width 150 :height 225)) (setf (gfw:text window) "Palette") @@ -101,7 +101,7 @@ (defun run-windlg-internal () (let ((menubar nil)) (setf *main-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'main-win-events) - :style '(:style-workspace))) + :style '(:workspace))) (setf menubar (gfw:defmenu ((:item "&File" :submenu ((:item "E&xit" :callback #'windlg-exit-fn))) (:item "&Windows" Modified: trunk/src/uitoolkit/graphics/graphics-classes.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-classes.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-classes.lisp Sun Apr 2 23:24:46 2006 @@ -88,8 +88,11 @@ (:documentation "This class encapsulates a realized native font.")) (defclass graphics-context (gfs:native-object) - ((owns-dc - :accessor owns-dc + ((dc-destructor + :accessor dc-destructor-of + :initform nil) + (widget-handle + :accessor widget-handle-of :initform nil) (logbrush-style :accessor logbrush-style-of Modified: trunk/src/uitoolkit/graphics/graphics-context.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-context.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-context.lisp Sun Apr 2 23:24:46 2006 @@ -179,6 +179,10 @@ (setf gfs::rightmargin 0) (cffi:with-foreign-object (rect-ptr 'gfs::rect) (cffi:with-foreign-slots ((gfs::left gfs::right gfs::top gfs::bottom) rect-ptr gfs::rect) + (setf gfs::left 0 + gfs::right 0 + gfs::top 0 + gfs::bottom 0) (gfs::draw-text-ex hdc str -1 rect-ptr (logior dt-flags gfs::+dt-calcrect+) dt-ptr) (setf (gfs:size-width sz) (- gfs::right gfs::left)) (setf (gfs:size-height sz) (- gfs::bottom gfs::top))))))) @@ -228,9 +232,13 @@ (setf (orig-pen-handle-of self) nil) (gfs::delete-object (pen-handle-of self)) (setf (pen-handle-of self) nil) - (if (owns-dc self) - (gfs::delete-dc (gfs:handle self))) - (setf (slot-value self 'gfs:handle) nil)) + (let ((fn (dc-destructor-of self))) + (unless (null fn) + (if (null (widget-handle-of self)) + (funcall fn (gfs:handle self)) + (funcall fn (widget-handle-of self) (gfs:handle self))))) + (setf (widget-handle-of self) nil) + (setf (slot-value self 'gfs:handle) (cffi:null-pointer))) (defmethod draw-arc ((self graphics-context) rect start-pnt end-pnt) (if (gfs:disposed-p self) @@ -471,10 +479,20 @@ (setf (logbrush-color-of self) rgb) (update-pen-for-gc self))) -(defmethod initialize-instance :after ((self graphics-context) &key) +(defmethod initialize-instance :after ((self graphics-context) &key image widget &allow-other-keys) (when (null (gfs:handle self)) - (setf (owns-dc self) t) - (setf (slot-value self 'gfs:handle) (gfs::create-compatible-dc (cffi:null-pointer)))) + (let ((hdc (cffi:null-pointer))) + (if (null widget) + (progn + (setf hdc (gfs::create-compatible-dc (cffi:null-pointer))) + (setf (dc-destructor-of self) #'gfs::delete-dc)) + (progn + (setf hdc (gfs::get-dc (gfs:handle widget))) + (setf (dc-destructor-of self) #'gfs::release-dc) + (setf (widget-handle-of self) (gfs:handle widget)))) + (setf (slot-value self 'gfs:handle) hdc) + (unless (null image) + (gfs::select-object hdc (gfs:handle image))))) ;; ensure world-to-device transformation conformance (gfs::set-graphics-mode (gfs:handle self) gfs::+gm-advanced+) (update-pen-for-gc self)) Modified: trunk/src/uitoolkit/graphics/image.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/image.lisp (original) +++ trunk/src/uitoolkit/graphics/image.lisp Sun Apr 2 23:24:46 2006 @@ -81,12 +81,44 @@ (gfs:dispose im)) (setf (slot-value im 'gfs:handle) (data->image id))) +(defmethod initialize-instance :after ((image image) &key size &allow-other-keys) + (unless (null size) + (cffi:with-foreign-object (bih-ptr 'gfs::bitmapinfoheader) + (gfs::zero-mem bih-ptr gfs::bitmapinfoheader) + (cffi:with-foreign-slots ((gfs::bisize gfs::biwidth gfs::biheight gfs::biplanes + gfs::bibitcount gfs::bicompression) + bih-ptr gfs::bitmapinfoheader) + (setf gfs::bisize (cffi:foreign-type-size 'gfs::bitmapinfoheader) + gfs::biwidth (gfs:size-width size) + gfs::biheight (- (gfs:size-height size)) + gfs::biplanes 1 + gfs::bibitcount 32 + gfs::bicompression gfs::+bi-rgb+) + (let ((nptr (cffi:null-pointer)) + (hbmp (cffi:null-pointer))) + (cffi:with-foreign-object (buffer :pointer) + (gfs::with-compatible-dcs (nptr memdc) + (setf hbmp (gfs::create-dib-section memdc bih-ptr gfs::+dib-rgb-colors+ buffer nptr 0)))) + (setf (slot-value image 'gfs:handle) hbmp)))))) + (defmethod load ((im image) path) (let ((data (make-instance 'image-data))) (load data path) (setf (data-obj im) data) data)) +(defmethod size ((image image)) + (if (gfs:disposed-p image) + (error 'gfs:disposed-error)) + (let ((size (gfs:make-size)) + (himage (gfs:handle image))) + (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) + (setf (gfs:size-width size) gfs::width + (gfs:size-height size) gfs::height))) + size)) + (defmethod transparency-mask ((im image)) (if (gfs:disposed-p im) (error 'gfs:disposed-error)) Modified: trunk/src/uitoolkit/widgets/button.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/button.lisp (original) +++ trunk/src/uitoolkit/widgets/button.lisp Sun Apr 2 23:24:46 2006 @@ -37,7 +37,7 @@ ;;; methods ;;; -(defmethod compute-style-flags ((btn button) &rest style) +(defmethod compute-style-flags ((btn button) style) (declare (ignore btn)) (let ((std-flags 0) (ex-flags 0)) Modified: trunk/src/uitoolkit/widgets/label.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/label.lisp (original) +++ trunk/src/uitoolkit/widgets/label.lisp Sun Apr 2 23:24:46 2006 @@ -37,7 +37,7 @@ ;;; methods ;;; -(defmethod compute-style-flags ((label label) &rest style) +(defmethod compute-style-flags ((label label) style) (declare (ignore label)) (let ((std-flags 0) (ex-flags 0)) Modified: trunk/src/uitoolkit/widgets/panel.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/panel.lisp (original) +++ trunk/src/uitoolkit/widgets/panel.lisp Sun Apr 2 23:24:46 2006 @@ -49,14 +49,14 @@ ;;; methods ;;; -(defmethod compute-style-flags ((self panel) &rest style) +(defmethod compute-style-flags ((self panel) style) (let ((std-flags (logior gfs::+ws-child+ gfs::+ws-visible+)) (ex-flags 0)) (mapc #'(lambda (sym) (cond ;; styles that can be combined ;; - ((eq sym :style-border) + ((eq sym :border) (setf std-flags (logior std-flags gfs::+ws-border+))))) (gfs:flatten style)) (values std-flags ex-flags))) Modified: trunk/src/uitoolkit/widgets/top-level.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/top-level.lisp (original) +++ trunk/src/uitoolkit/widgets/top-level.lisp Sun Apr 2 23:24:46 2006 @@ -51,7 +51,7 @@ ;;; methods ;;; -(defmethod compute-style-flags ((win top-level) &rest style) +(defmethod compute-style-flags ((win top-level) style) (declare (ignore win)) (let ((std-flags 0) (ex-flags 0)) @@ -60,40 +60,40 @@ ;; styles that can be combined ;; #| - ((eq sym :style-hscroll) + ((eq sym :hscroll) (setf std-flags (logior std-flags gfs::+ws-hscroll+))) - ((eq sym :style-max) + ((eq sym :max) (setf std-flags (logior std-flags gfs::+ws-maximizebox+))) - ((eq sym :style-min) + ((eq sym :min) (setf std-flags (logior std-flags gfs::+ws-minimizebox+))) - ((eq sym :style-resize) + ((eq sym :resize) (setf std-flags (logior std-flags gfs::+ws-thickframe+))) - ((eq sym :style-sysmenu) + ((eq sym :sysmenu) (setf std-flags (logior std-flags gfs::+ws-sysmenu+))) - ((eq sym :style-title) + ((eq sym :title) (setf std-flags (logior std-flags gfs::+ws-caption+))) - ((eq sym :style-top) + ((eq sym :top) (setf ex-flags (logior ex-flags gfs::+ws-ex-topmost+))) - ((eq sym :style-vscroll) + ((eq sym :vscroll) (setf std-flags (logior std-flags gfs::+ws-vscroll+))) |# ;; pre-packaged combinations of window styles ;; - ((eq sym :style-borderless) + ((eq sym :borderless) (setf std-flags (logior gfs::+ws-clipchildren+ gfs::+ws-clipsiblings+ gfs::+ws-border+ gfs::+ws-popup+)) (setf ex-flags gfs::+ws-ex-topmost+)) - ((eq sym :style-palette) + ((eq sym :palette) (setf std-flags (logior gfs::+ws-clipchildren+ gfs::+ws-clipsiblings+ gfs::+ws-popupwindow+ gfs::+ws-caption+)) (setf ex-flags (logior gfs::+ws-ex-toolwindow+ gfs::+ws-ex-windowedge+))) - ((eq sym :style-miniframe) + ((eq sym :miniframe) (setf std-flags (logior gfs::+ws-clipchildren+ gfs::+ws-clipsiblings+ gfs::+ws-popup+ @@ -102,7 +102,7 @@ gfs::+ws-caption+)) (setf ex-flags (logior gfs::+ws-ex-appwindow+ gfs::+ws-ex-toolwindow+))) - ((eq sym :style-workspace) + ((eq sym :workspace) (setf std-flags (logior gfs::+ws-overlappedwindow+ gfs::+ws-clipsiblings+ gfs::+ws-clipchildren+)) Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Sun Apr 2 23:24:46 2006 @@ -105,7 +105,7 @@ (defgeneric columns (self) (:documentation "Returns the column objects displayed by the object.")) -(defgeneric compute-style-flags (self &rest style) +(defgeneric compute-style-flags (self style) (:documentation "Convert a list of keyword symbols to a pair of native bitmasks; the first conveys normal/standard flags, whereas the second any extended flags that the system supports.")) (defgeneric compute-outer-size (self desired-client-size)

1 0