- graphic-forms-cvs@common-lisp.net - mailman3.common-lisp.net

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

14 Apr '06

Author: junrue Date: Fri Apr 14 19:04:26 2006 New Revision: 96 Modified: trunk/build.lisp trunk/config.lisp trunk/graphic-forms-tests.asd trunk/graphic-forms-uitoolkit.asd trunk/src/demos/unblocked/tiles-panel.lisp trunk/src/packages.lisp trunk/src/uitoolkit/graphics/image-data.lisp trunk/src/uitoolkit/graphics/magick-core-api.lisp Log: revised mechanism for specifying ImageMagick library directory; removed in-package forms referring to gfsys where they weren't needed since external apps shouldn't have to define that package to get the toolkit loaded Modified: trunk/build.lisp ============================================================================== --- trunk/build.lisp (original) +++ trunk/build.lisp Fri Apr 14 19:04:26 2006 @@ -47,39 +47,14 @@ (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/") (setf *lw-compat-dir* (concatenate 'string *asdf-repo-root* "lw-compat/")) (setf *gf-dir* (concatenate 'string *project-root* "graphic-forms/")) (setf *lisp-unit-file* (concatenate 'string *library-root* "lisp-unit")) -(defvar *asdf-system-connections-dir* (concatenate 'string *asdf-repo-root* "asdf-system-connections/")) -(defvar *cl-containers-dir* (concatenate 'string *asdf-repo-root* "cl-containers/")) -(defvar *cl-graph-dir* (concatenate 'string *asdf-repo-root* "cl-graph/")) -(defvar *cl-mathstats-dir* (concatenate 'string *asdf-repo-root* "cl-mathstats/")) -(defvar *metabang-bind-dir* (concatenate 'string *asdf-repo-root* "metabang-bind/")) -(defvar *metatilities-dir* (concatenate 'string *asdf-repo-root* "metatilities/")) -(defvar *moptilities-dir* (concatenate 'string *asdf-repo-root* "moptilities/")) -(defvar *tinaa-dir* (concatenate 'string *asdf-repo-root* "tinaa/")) - (defvar *gf-tests-dir* (concatenate 'string *gf-dir* "src/tests/uitoolkit/")) (defun build () (setf cl-user::*asdf-cache* "c:/projects/public/build/") (configure-asdf) (pushnew *gf-dir* asdf:*central-registry* :test #'equal) -#| - (pushnew *tinaa-dir* asdf:*central-registry* :test #'equal) - (pushnew *cl-graph-dir* asdf:*central-registry* :test #'equal) - (pushnew *asdf-system-connections-dir* asdf:*central-registry* :test #'equal) - (pushnew *cl-mathstats-dir* asdf:*central-registry* :test #'equal) - (pushnew *cl-containers-dir* asdf:*central-registry* :test #'equal) - (pushnew *metatilities-dir* asdf:*central-registry* :test #'equal) - (pushnew *moptilities-dir* asdf:*central-registry* :test #'equal) - (pushnew *metabang-bind-dir* asdf:*central-registry* :test #'equal) - (asdf:operate 'asdf:load-op :tinaa) -|# (asdf:operate 'asdf:load-op :graphic-forms-uitoolkit)) - -#| - (tinaa:document-system 'asdf :graphic-forms-uitoolkit "c:/projects/public/testing/") -|# Modified: trunk/config.lisp ============================================================================== --- trunk/config.lisp (original) +++ trunk/config.lisp Fri Apr 14 19:04:26 2006 @@ -31,6 +31,8 @@ ;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;;; +(defvar *magick-library-directory* "c:/Program Files/ImageMagick-6.2.6-Q16/") + (defpackage #:graphic-forms-system (:nicknames #:gfsys) (:use :common-lisp :asdf)) @@ -40,7 +42,6 @@ (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/") (defvar *lw-compat-dir* "lw-compat/") (defvar *gf-dir* "graphic-forms/") Modified: trunk/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Fri Apr 14 19:04:26 2006 @@ -31,7 +31,7 @@ ;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;;; -(in-package #:graphic-forms-system) +; (in-package #:graphic-forms-system) (defpackage #:graphic-forms.uitoolkit.tests (:nicknames #:gft) @@ -51,7 +51,7 @@ (defsystem graphic-forms-tests :description "Graphic-Forms UI Toolkit Tests" - :version "0.2.0" + :version "0.3.0" :author "Jack D. Unrue" :licence "BSD" :depends-on ("cells") Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Fri Apr 14 19:04:26 2006 @@ -31,7 +31,7 @@ ;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;;; -(in-package #:graphic-forms-system) +;(in-package #:graphic-forms-system) (print "Graphic-Forms UI Toolkit") (print "Copyright (c) 2006 by Jack D. Unrue") @@ -39,7 +39,7 @@ (defsystem graphic-forms-uitoolkit :description "Graphic-Forms UI Toolkit" - :version "0.2.0" + :version "0.3.0" :author "Jack D. Unrue" :licence "BSD" :depends-on ("cffi" "lw-compat" "closer-mop") 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 14 19:04:26 2006 @@ -132,12 +132,13 @@ (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) (unwind-protect - (map-tiles #'(lambda (pnt kind) - (unless (= kind 0) - (gfg:draw-image gc (gethash kind image-table) (tiles->window pnt)))) - (game-tiles)) + (progn + (clear-buffer self gc) + (map-tiles #'(lambda (pnt kind) + (unless (= kind 0) + (gfg:draw-image gc (gethash kind image-table) (tiles->window pnt)))) + (game-tiles))) (gfs:dispose gc)))) (defclass tiles-panel (gfw:panel) ()) Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Fri Apr 14 19:04:26 2006 @@ -31,7 +31,7 @@ ;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;;; -(in-package #:graphic-forms-system) +(in-package #:cl-user) ;;; ;;; destination for unique symbols generated by GENTEMP Modified: trunk/src/uitoolkit/graphics/image-data.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/image-data.lisp (original) +++ trunk/src/uitoolkit/graphics/image-data.lisp Fri Apr 14 19:04:26 2006 @@ -145,17 +145,17 @@ (pix-count (* (gfs:size-width sz) (gfs:size-height sz))) (hbmp (cffi:null-pointer)) (screen-dc (gfs::get-dc (cffi:null-pointer)))) - (setf gfs::bisize (cffi:foreign-type-size 'gfs::bitmapinfoheader)) - (setf gfs::biwidth (gfs:size-width sz)) - (setf gfs::biheight (- 0 (gfs:size-height sz))) - (setf gfs::biplanes 1) - (setf gfs::bibitcount 32) ;; 32bpp even if original image file is not - (setf gfs::bicompression gfs::+bi-rgb+) - (setf gfs::bisizeimage 0) - (setf gfs::bixpels 0) - (setf gfs::biypels 0) - (setf gfs::biclrused 0) - (setf gfs::biclrimp 0) + (setf gfs::bisize (cffi:foreign-type-size 'gfs::bitmapinfoheader) + gfs::biwidth (gfs:size-width sz) + gfs::biheight (- 0 (gfs:size-height sz)) + gfs::biplanes 1 + gfs::bibitcount 32 ;; 32bpp even if original image file is not + gfs::bicompression gfs::+bi-rgb+ + gfs::bisizeimage 0 + gfs::bixpels 0 + gfs::biypels 0 + gfs::biclrused 0 + gfs::biclrimp 0) ;; create the bitmap ;; Modified: trunk/src/uitoolkit/graphics/magick-core-api.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/magick-core-api.lisp (original) +++ trunk/src/uitoolkit/graphics/magick-core-api.lisp Fri Apr 14 19:04:26 2006 @@ -35,20 +35,20 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (use-package :cffi) - (pushnew gfsys::*imagemagick-dir* *foreign-library-directories*)) + (pushnew cl-user::*magick-library-directory* cffi:*foreign-library-directories* :test #'equal)) -(define-foreign-library wsock32 (t (:default "wsock32"))) -(define-foreign-library msvcr71 (t (:default "msvcr71"))) -(define-foreign-library x11 (t (:default "x11"))) -(define-foreign-library core_rl_bzlib (t (:default "CORE_RL_bzlib_"))) -(define-foreign-library core_rl_jbig (t (:default "CORE_RL_jbig_"))) -(define-foreign-library core_rl_jpeg (t (:default "CORE_RL_jpeg_"))) -(define-foreign-library core_rl_lcms (t (:default "CORE_RL_lcms_"))) -(define-foreign-library core_rl_zlib (t (:default "CORE_RL_zlib_"))) -(define-foreign-library core_rl_png (t (:default "CORE_RL_png_"))) -(define-foreign-library core_rl_tiff (t (:default "CORE_RL_tiff_"))) -(define-foreign-library core_rl_ttf (t (:default "CORE_RL_ttf_"))) -(define-foreign-library core_rl_xlib (t (:default "CORE_RL_xlib_"))) +(define-foreign-library wsock32 (t (:default "wsock32"))) +(define-foreign-library msvcr71 (t (:default "msvcr71"))) +(define-foreign-library x11 (t (:default "x11"))) +(define-foreign-library core_rl_bzlib (t (:default "CORE_RL_bzlib_"))) +(define-foreign-library core_rl_jbig (t (:default "CORE_RL_jbig_"))) +(define-foreign-library core_rl_jpeg (t (:default "CORE_RL_jpeg_"))) +(define-foreign-library core_rl_lcms (t (:default "CORE_RL_lcms_"))) +(define-foreign-library core_rl_zlib (t (:default "CORE_RL_zlib_"))) +(define-foreign-library core_rl_png (t (:default "CORE_RL_png_"))) +(define-foreign-library core_rl_tiff (t (:default "CORE_RL_tiff_"))) +(define-foreign-library core_rl_ttf (t (:default "CORE_RL_ttf_"))) +(define-foreign-library core_rl_xlib (t (:default "CORE_RL_xlib_"))) (define-foreign-library core_rl_magick (t (:default "CORE_RL_magick_"))) (use-foreign-library wsock32)

1 0

[graphic-forms-cvs] r95 - in trunk: docs/manual src src/demos/unblocked src/uitoolkit/system src/uitoolkit/widgets
by junrue＠common-lisp.net 13 Apr '06

13 Apr '06

Author: junrue Date: Thu Apr 13 15:14:13 2006 New Revision: 95 Modified: trunk/docs/manual/api.texinfo trunk/src/demos/unblocked/unblocked-window.lisp trunk/src/packages.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/system/system-types.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/top-level.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp Log: implemented maximum-size and minimum-size slots for top-level windows so apps can constrain resizing by the user Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Thu Apr 13 15:14:13 2006 @@ -301,7 +301,15 @@ @deftp Class top-level 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'). +normally resizable and have title bars (also called 'captions'). +@deffn Initarg :maximum-size +Sets the maximum @ref{size} to which the user may adjust the +boundaries of the window. +@end deffn +@deffn Initarg :minimum-size +Sets the minimum @ref{size} to which the user may adjust the +boundaries of the window. +@end deffn @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 @@ -553,14 +561,35 @@ @end deffn @deffn GenericFunction location self -Returns a point object describing the coordinates of the top-left -corner of the object in its parent's coordinate system. @xref{parent}. +Returns a @ref{point} object describing the coordinates of the +top-left corner of the object in its parent's coordinate +system. @xref{parent}. +@end deffn + +@anchor{maximum-size} +@deffn GenericFunction maximum-size self +Returns a @ref{size} object describing the largest dimensions to which +the user may resize this widget; by default returns @code{nil}, +indicating that there is effectively no constraint. The corresponding +@code{setf} function sets this value; if the new maximum size is +smaller than the current size, the widget is resized to the new +maximum. @xref{minimum-size}. @end deffn @deffn GenericFunction menu-bar self Returns the menu object serving as the menubar for this object. @end deffn +@anchor{minimum-size} +@deffn GenericFunction minimum-size self +Returns a @ref{size} object describing the smallest dimensions to +which the user may resize this widget; by default returns @code{nil}, +indicating that the minimum constraint is determined by the windowing +system's configuration. The corresponding @code{setf} function sets +this value; if the new minimum size is larger than the current size, +the widget is resized to the new minimum. @xref{maximum-size}. +@end deffn + @deffn GenericFunction object-to-display self pnt Return a point that is the result of transforming the specified point from this object's coordinate system to display-relative coordinates. @@ -625,6 +654,7 @@ @end quotation @end deffn +@anchor{preferred-size} @deffn GenericFunction preferred-size self width-hint height-hint Implement this function to return @code{self}'s preferred @ref{size}; that is, the dimensions that @code{self} computes as being the best Modified: trunk/src/demos/unblocked/unblocked-window.lisp ============================================================================== --- trunk/src/demos/unblocked/unblocked-window.lisp (original) +++ trunk/src/demos/unblocked/unblocked-window.lisp Thu Apr 13 15:14:13 2006 @@ -108,7 +108,9 @@ :dispatcher (make-instance 'tiles-panel-events :buffer-size tile-buffer-size))) (setf (gfw:text *unblocked-win*) "Graphic-Forms UnBlocked") - (gfw:pack *unblocked-win*) + (let ((size (gfw:preferred-size *unblocked-win* -1 -1))) + (setf (gfw:minimum-size *unblocked-win*) size) + (setf (gfw:maximum-size *unblocked-win*) size)) (gfw:show *unblocked-win* t))) (defun unblocked () Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Thu Apr 13 15:14:13 2006 @@ -232,9 +232,6 @@ #:window ;; constants - #:maximized ;; FIXME: should be a keyword - #:minimized ;; FIXME: should be a keyword - #:restored ;; FIXME: should be a keyword #:+vk-break+ #:+vk-backspace+ #:+vk-tab+ Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Thu Apr 13 15:14:13 2006 @@ -661,6 +661,7 @@ (defconstant +wm-activate+ #x0006) (defconstant +wm-paint+ #x000F) (defconstant +wm-close+ #x0010) +(defconstant +wm-getminmaxinfo+ #x0024) (defconstant +wm-setfont+ #x0030) (defconstant +wm-getfont+ #x0031) (defconstant +wm-ncmousemove+ #x00A0) Modified: trunk/src/uitoolkit/system/system-types.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-types.lisp (original) +++ trunk/src/uitoolkit/system/system-types.lisp Thu Apr 13 15:14:13 2006 @@ -169,6 +169,13 @@ (x LONG) (y LONG)) +(defcstruct minmaxinfo + (reserved point) + (maxsize point) + (maxposition point) + (mintracksize point) + (maxtracksize point)) + (defcstruct msg (hwnd HANDLE) (message UINT) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Thu Apr 13 15:14:13 2006 @@ -298,7 +298,7 @@ :y gfs::rcpaint-y)) (setf (gfs:size rct) (gfs:make-size :width gfs::rcpaint-width :height gfs::rcpaint-height)) - (let* ((gc (make-instance 'gfg:graphics-context :handle (gfs::begin-paint hwnd ps-ptr)))) + (let ((gc (make-instance 'gfg:graphics-context :handle (gfs::begin-paint hwnd ps-ptr)))) (unwind-protect (event-paint (dispatcher widget) widget (event-time tc) gc rct) (gfs:dispose gc) @@ -318,14 +318,42 @@ (declare (ignore wparam)) (process-mouse-message #'event-mouse-up hwnd lparam :right-button)) +(defmethod process-message (hwnd (msg (eql gfs::+wm-getminmaxinfo+)) wparam lparam) + (declare (ignore wparam)) + (let* ((tc (thread-context)) + (w (get-widget tc hwnd)) + (info-ptr (cffi:make-pointer lparam))) + (if (typep w 'top-level) + (cffi:with-foreign-slots ((gfs::mintracksize gfs::maxtracksize) + info-ptr gfs::minmaxinfo) + (let ((max-size (maximum-size w)) + (min-size (minimum-size w))) + (if max-size + (cffi:with-foreign-slots ((gfs::x gfs::y) + (cffi:foreign-slot-pointer info-ptr + 'gfs::minmaxinfo + 'gfs::maxtracksize) + gfs::point) + (setf gfs::x (gfs:size-width max-size) + gfs::y (gfs:size-height max-size)))) + (if min-size + (cffi:with-foreign-slots ((gfs::x gfs::y) + (cffi:foreign-slot-pointer info-ptr + 'gfs::minmaxinfo + 'gfs::mintracksize) + gfs::point) + (setf gfs::x (gfs:size-width min-size) + gfs::y (gfs:size-height min-size)))))))) + 0) + (defmethod process-message (hwnd (msg (eql gfs::+wm-size+)) wparam lparam) (declare (ignore lparam)) (let* ((tc (thread-context)) (w (get-widget tc hwnd)) (type (cond - ((= wparam gfs::+size-maximized+) 'maximized) - ((= wparam gfs::+size-minimized+) 'minimized) - ((= wparam gfs::+size-restored+) 'restored) + ((= wparam gfs::+size-maximized+) :maximized) + ((= wparam gfs::+size-minimized+) :minimized) + ((= wparam gfs::+size-restored+) :restored) (t nil)))) (when w (outer-size w (size-event-size tc)) Modified: trunk/src/uitoolkit/widgets/top-level.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/top-level.lisp (original) +++ trunk/src/uitoolkit/widgets/top-level.lisp Thu Apr 13 15:14:13 2006 @@ -54,6 +54,11 @@ gfs::+cs-dblclks+ -1)) +(defun constrain-new-size (new-size current-size compare-fn) + (let ((new-width (funcall compare-fn (gfs:size-width new-size) (gfs:size-width current-size))) + (new-height (funcall compare-fn (gfs:size-height new-size) (gfs:size-height current-size)))) + (gfs:make-size :width new-width :height new-height))) + ;;; ;;; methods ;;; @@ -73,8 +78,6 @@ (setf std-flags (logior std-flags gfs::+ws-maximizebox+))) ((eq sym :min) (setf std-flags (logior std-flags gfs::+ws-minimizebox+))) - ((eq sym :resize) - (setf std-flags (logior std-flags gfs::+ws-thickframe+))) ((eq sym :sysmenu) (setf std-flags (logior std-flags gfs::+ws-sysmenu+))) ((eq sym :title) @@ -152,6 +155,12 @@ (error 'gfs:toolkit-error :detail "no object for menu handle")) m))) +(defmethod (setf maximum-size) :after (max-size (win top-level)) + (unless (gfs:disposed-p win) + (let ((size (constrain-new-size max-size (size win) #'min))) + (setf (size win) size) + (perform-layout win (gfs:size-width size) (gfs:size-height size))))) + (defmethod (setf menu-bar) :before ((m menu) (win top-level)) (declare (ignore m)) (if (gfs:disposed-p win) @@ -168,6 +177,12 @@ (gfs::set-menu hwnd (gfs:handle m)) (gfs::draw-menu-bar hwnd))) +(defmethod (setf minimum-size) :after (min-size (win top-level)) + (unless (gfs:disposed-p win) + (let ((size (constrain-new-size min-size (size win) #'max))) + (setf (size win) size) + (perform-layout win (gfs:size-width size) (gfs:size-height size))))) + (defmethod text :before ((win top-level)) (if (gfs:disposed-p win) (error 'gfs:disposed-error))) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Thu Apr 13 15:14:13 2006 @@ -100,7 +100,15 @@ (defclass root-window (window) () (:documentation "This class encapsulates the root of the desktop window hierarchy.")) -(defclass top-level (window) () +(defclass top-level (window) + ((maximum-size + :accessor maximum-size + :initarg :maximum-size + :initform nil) + (minimum-size + :accessor minimum-size + :initarg :minimum-size + :initform nil)) (:documentation "Base class for windows that can be moved and resized by the user, and which normally have title bars.")) (defclass timer (event-source) Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Thu Apr 13 15:14:13 2006 @@ -217,7 +217,7 @@ (:documentation "Returns T if the object is in its maximized state (not necessarily the same as the maximum size); nil otherwise.")) (defgeneric maximum-size (self) - (:documentation "Returns a size object describing the largest size this object can exist.")) + (:documentation "Returns a size object describing the largest dimensions to which the user may resize the widget.")) (defgeneric menu-bar (self) (:documentation "Returns the menu object serving as the menubar for this object."))

1 0

[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