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

[graphic-forms-cvs] r227 - in trunk: . docs/manual docs/website
by junrue＠common-lisp.net 21 Aug '06

21 Aug '06

Author: junrue Date: Mon Aug 21 02:49:15 2006 New Revision: 227 Modified: trunk/NEWS.txt trunk/README.txt trunk/docs/manual/overview.texinfo trunk/docs/website/index.html Log: doc updates in preparation for the 0.5.0 release Modified: trunk/NEWS.txt ============================================================================== --- trunk/NEWS.txt (original) +++ trunk/NEWS.txt Mon Aug 21 02:49:15 2006 @@ -1,15 +1,90 @@ +Release 0.5.0 of Graphic-Forms, a Common Lisp library for Windows GUI +programming, is now available. This is an alpha release, meaning that +the feature set and API have not yet stabilized. + +Here is what's new in this release: + +. SBCL is now supported (version 0.9.15 tested). Graphic-Forms includes + a small patch provided to the SBCL community by Alastair Bridgewater + to enable the stdcall calling convention for alien callbacks. Please + see src/external-libraries/sbcl-callback-patch + +. Implemented a plugin mechanism for integrating graphics libraries. This + means that ImageMagick is now optional -- if your application can get + by with just BMP and ICO formats, then the default plugin (which has no + external dependencies) may be used. This feature also allows applications + to integrate other graphics libraries of their choice. + +. In addition to ImageMagick now being optional, external library + dependencies have been further simplified. Several small libraries + are now directly bundled with the Graphic-Forms. Cells is no longer + used in the library proper nor in the demos (but may return at a + later point). + +. Implemented a class called icon-bundle which may be populated with + multiple images and then used to set icon data for window frames. + This includes the concept of there being 'large' and 'small' icon + sizes. + +. Simplified the argument lists for the event-*** generic functions. + Provided gfw:obtain-event-time as a substitute for passing a time + argument to every function (for which the vast majority of methods + had no use). + +. Provided a new generic function called event-session so applications + can participate in the WM_QUERYENDSESSION / WM_ENDSESSION protocol. + +. Provided event-activate and event-deactivate generic functions so + applications can respond to window activation state changes. + +. Defined generic functions for querying undo and redo state. Implemented + corresponding methods for edit controls. + +. Defined generic functions for configuring auto-scrolling and scrollbar + visibility. Implemented corresponding methods for edit controls. + +. Defined generic functions representing text clipboard data convenience + functionality. Implemented corresponding methods for edit controls. -. SBCL 0.9.15 is now supported. Graphic-Forms includes a small patch - to enable the stdcall calling convention for alien callbacks, located - in src/external-libraries/sbcl-callback-patch. +. Made other miscellaneous improvements to flesh out edit control + support. -. Implemented a plugin mechanism for integrating graphics libraries. +. Implemented the standard color chooser dialog and associated + convenience macro 'with-color-dialog'. -. Implemented the standard color chooser dialog. +. Added the macro 'with-graphics-context' as a convenience for code that + needs to instantiate a context outside of event-paint. -. Simplified external library dependencies, getting rid of some and - bundling small libraries into the Graphic-Forms distribution. +. Heavily revised internal layout manager code in preparation for + supporting more sophisticated layouts. A new class called layout-managed + has been created to serve as a mix-in when defining objects (not + necessarily only windows) that have children to be sized and positioned. + +. Implemented a new demo program called textedit which is essentially + a Notepad clone. Its purpose is to show off the multi-line edit + control and the standard Find/Replace dialog. + +. Upgraded to the latest lisp-unit and changed test loading code so that + unit-tests are no longer compiled. + +. Wrote more documentation and reorganized existing content a bit. + Added discussion of certain naming convention choices. + +. Made a variety of bug fixes. + +The README.txt file in the release zip file also has additional important +information about this release. + +Download the release zip file here: +http://prdownloads.sourceforge.net/graphic-forms/graphic-forms-0.5.0.zip?download + +The project website is: +http://common-lisp.net/project/graphic-forms/ + +Jack Unrue +jdunrue (at) gmail (dot) com +25 August 2006 ============================================================================== Modified: trunk/README.txt ============================================================================== --- trunk/README.txt (original) +++ trunk/README.txt Mon Aug 21 02:49:15 2006 @@ -1,5 +1,5 @@ -Graphic-Forms README for version 0.5.0 +Graphic-Forms README for version 0.5.0 (25 August 2006) Copyright (c) 2006, Jack D. Unrue Graphic-Forms is a user interface library implemented in Common Lisp focusing @@ -10,7 +10,8 @@ Dependencies ------------ -Graphic-Forms depends on the following packages: +Graphic-Forms requires the following libraries which must be downloaded +separately: - ASDF http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/cclan/asdf/ @@ -19,14 +20,13 @@ - CFFI (cffi-060606 or later) http://common-lisp.net/project/cffi/ - - lw-compat + - Closer to MOP http://common-lisp.net/project/closer/downloads.html - - Closer to MOP + - lw-compat http://common-lisp.net/project/closer/downloads.html -The following libraries are bundled with Graphic-Forms, thus do not need -to be downloaded separately: +The following libraries are bundled with Graphic-Forms: - Practical Common Lisp Chapter08 and Chapter24 http://www.gigamonkeys.com/book/practicals-1.0.3.tar.gz @@ -43,8 +43,8 @@ Supported Common Lisp Implementations ------------------------------------- -Graphic-Forms currently supports CLISP 2.38, LispWorks 4.4.6, and SBCL 0.9.15 -(the latter with a small patch). +Graphic-Forms currently supports CLISP 2.38 or higher, LispWorks 4.4.6, +and SBCL 0.9.15 (the latter with a small patch). Known Problems @@ -58,103 +58,102 @@ http://sourceforge.net/tracker/index.php?func=detail&aid=1463994&group_id=1… - may result in intermittent GPFs when windows with layout managers are - resized. - -2. Image loading currently requires installation of the ImageMagick - library as described in the next section. I have tested with Windows - BMP files (and this is what the image-tester application displays). - ImageMagick itself supports many image formats, but Graphic-Forms - has not been tested with all of them. Therefore, images may not - display properly, expecially when a transparency is selected. - -3. The src/demos/unblocked directory contains a start at a demo - program in the form of a simple game where one clicks on block - shapes to score points, and the rest of the blocks fall down to - fill in the gaps. This demo program is not yet finished, but the - source code can still serve as sample code. - -4. The text-extent generic function currently does not return - the correct text height. As a workaround, get the text metrics - for the desired font and base height calculations on that - value. The text-extent function does return the correct width. - + may result in a GPF if a window's layout manager is changed. Compared + to prior releases of Graphic-Forms, there is much less chance of this + problem affecting layout management. + +2. Please be advised that SBCL is itself still in the early stages of + supporting Windows, and as a consequence, you may experience problems + such as 'GC invariant lost' errors that result in a crash to LDB. + +3. The gfg:text-extent method currently does not return the correct text + height value. As a workaround, get the text metrics for the font and + compute height from that. The gfg:text-extent function does return + the correct width. How To Configure and Build -------------------------- -NOTE: in a future release, this project will be packaged for use -with asdf-install. +NOTE: in a future release, this project will be packaged for delivery +via asdf-install. -1. Install ImageMagick 6.2.6.5-Q16 (note in particular that it is the Q16 - version that is needed, not the Q8 version). The default installation - directory is "c:/Program Files/ImageMagick-6.2.6-Q16/". +1. [OPTIONAL] Install ImageMagick 6.2.6.5-Q16 (note in particular that it + is the Q16 version that is needed, not the Q8 version). The default + installation directory is "c:/Program Files/ImageMagick-6.2.6-Q16/". 2. Extract the Graphic-Forms distribution archive somewhere on your machine (or check out the source from Subversion). 3. Change to the Graphic-Forms top-level directory. -4. Load ASDF into your Lisp image if it is not already present. +4. Load ASDF into your Lisp image if it is not already present. Note that + SBCL bundles ASDF, so in this case you just need to (require 'asdf) -5. Execute the following forms from your REPL - - (load "config.lisp") +5. Execute the following forms at your REPL ;; - ;; If ImageMagick is not installed in the default location, execute: + ;; If you need the ImageMagick plugin, execute: + + (push :load-imagemagick-plugin *features*) + (setf cl-user::*magick-library-directory* "c:/path/to/ImageMagick/") + + ;; ... the latter being necessary only if ImageMagick is not installed + ;; in the default location. + ;; - (setf cl-user::*magick-library-directory* "c:/path/to/your/ImageMagick/install/") + ;; Next, execute: - ;; setf these variables as needed for your specific environment to + (load "config.lisp") + + ;; + ;; Set these variables as needed for your specific environment to ;; load the other dependencies besides ImageMagick. Or if your Lisp ;; image already has these systems loaded, set the variables to nil. ;; ;; gfsys::*cffi-dir* ;; gfsys::*closer-mop-dir* ;; gfsys::*lw-compat-dir* - ;; - ;; Set the following var only if you want to run the unit-tests. - ;; Its value is the path to the lisp-unit.lisp source file minus - ;; the file extension. - ;; - ;; gfsys::*lisp-unit-file* + ;; ;; Execute the following form to populate asdf:*central-registry* ;; Note that it will skip any systems whose location variables were ;; set to nil in the previous step. - ;; + (gfsys::configure-asdf) - ;; Now load the graphic-forms system and its dependencies. ;; + ;; Now load the graphic-forms system and its dependencies. + (asdf:operate 'asdf:load-op :graphic-forms-uitoolkit) 6. You may optionally compile the reference manual. GNU Make and - makeinfo are prerequisites. Assuming you already have those - components installed, the reference manual can be built by - opening a command prompt and cd'ing to the `docs\manual' + makeinfo (version 4.8) are prerequisites. Assuming you already + have those components installed, the reference manual can be + built by opening a command prompt and cd'ing to the `docs\manual' subdirectory, then typing `make'. The output will be - produced within a subdirectory called `reference'. + deposited in a subdirectory called `reference'. 7. Proceed to the next section to run the tests, or start coding! -How To Run Tests And Samples ----------------------------- +How To Run Tests And Demos +-------------------------- 1. Load the graphic-forms-uitoolkit system as described in the previous section. 2. Execute the following forms from your REPL: - (load (compile-file gfsys::*lisp-unit-file*)) + ;; + ;; configure ASDF for the test programs and then load it - (asdf:operate 'asdf:load-op :graphic-forms-tests) + (load "tests.lisp") + (gfsys::load-tests) - ;; execute demos and test programs ;; + ;; execute demos and test programs + (gft:unblocked) (gft:textedit) @@ -169,14 +168,15 @@ (gft:windlg) - ;; execute the unit-tests ;; + ;; execute the unit-tests + (in-package :gft) (run-tests) -Support and Feedback --------------------- +Feedback and Bug Reports +------------------------ Please provide feedback via the following channels: Modified: trunk/docs/manual/overview.texinfo ============================================================================== --- trunk/docs/manual/overview.texinfo (original) +++ trunk/docs/manual/overview.texinfo Mon Aug 21 02:49:15 2006 @@ -14,19 +14,18 @@ focusing on the Windows platform. Graphic-Forms is licensed under the terms of the BSD License. -The goal is to provide a Lisp-based toolkit for developing GUI -applications on Windows. Platform-specific features are encapsulated -by a thin abstraction layer that presents a more Lisp-friendly -interface for programmers. The library can be extended by using the -Lisp bindings for system APIs, rather than requiring knowledge of -some other programming language. +The goal is to provide a Common Lisp-based toolkit for developing GUI +applications on Windows. GUI features are encapsulated by a thin +abstraction layer offering a Lisp-friendly interface. The library can +be extended via Common Lisp bindings for system APIs, avoiding a +prerequisite for coding ability in a non-Lisp programming language. Why implement another UI toolkit? Applications that need portability -across windowing systems are already served by projects such as McCLIM -or LTK or wxCL in the open-source world, or the toolkits provided by -commercial vendors. The audience served by Graphic-Forms consists of +across windowing systems are served today by projects such as +LTK or wxCL in the open-source world, or the toolkits provided by +commercial vendors. The target audience of Graphic-Forms consists of GUI developers focused on the Windows platform who want to leverage -platform features without compromises due to portability. +platform-specific features. Long-term goals for this project may include implementing an application framework on top of the toolkit, or a rapid UI development language, or Modified: trunk/docs/website/index.html ============================================================================== --- trunk/docs/website/index.html (original) +++ trunk/docs/website/index.html Mon Aug 21 02:49:15 2006 @@ -30,46 +30,47 @@ terms of the <a href="http://home.earthlink.net/~jdunrue/license.html">BSD License</a>. - The goal is to provide a Lisp-based toolkit for developing GUI - applications on Windows. Platform-specific features are encapsulated - by a thin abstraction layer that presents a more Lisp-friendly interface - for programmers. The library can be extended by using the Lisp - bindings for system APIs, rather than requiring knowledge of some other - programming language. - Why implement another UI toolkit? Applications that need portability - across windowing systems are already served by projects such as - <a href="http://common-lisp.net/project/mcclim/">McCLIM</a> - or + The goal is to provide a <a href="http://www.lisp.org">Common Lisp</a>-based + toolkit for developing GUI applications on Windows. GUI features + are encapsulated by a thin abstraction layer offering a Lisp-friendly + interface. The library can be extended via + <a href="http://www.lisp.org">Common Lisp</a> bindings for system APIs, + avoiding a prerequisite for coding ability in a non-Lisp programming + language. + Why implement another UI toolkit? Applications requiring portability + across windowing systems are served today by projects such as <a href="http://www.peter-herth.de/ltk/">LTK</a> or <a href="http://www.wxcl-project.org">wxCL</a> in the open-source world, or the toolkits provided by commercial - vendors. The audience served by Graphic-Forms consists of GUI + vendors. The target audience of Graphic-Forms consists of GUI developers focused on the Windows platform who want to leverage - platform features without compromises due to portability. + platform-specific features. Long-term goals for this project may include implementing an application framework on top of the toolkit, or a rapid UI development language, or a UI design tool, or some combination thereof. <h3>Status</h3> - The current release is - <a href="http://sourceforge.net/project/showfiles.php?group_id=163034">version 0.4.0</a>. - This library is in the alpha stage of development, which means that new - features are still being added and existing features require considerable - testing. Brave souls who experiment with the code should expect significant - API and behavior changes for at least several more releases. + The current version is + <a href="http://prdownloads.sourceforge.net/graphic-forms/graphic-forms-0.5.0.zip?do…"> + 0.5.0</a>, released on 25 August 2006. + Graphic-Forms is in the alpha stage of development, + meaning new features are still being added and existing features require + considerable testing. Brave souls who experiment with the code should expect + significant API and behavior changes for at least several more releases. The supported Lisp implementations are: <ul> - <li><a href="http://clisp.cons.org/">CLISP 2.38</a></li> + <li><a href="http://clisp.cons.org/">CLISP 2.38 or later</a></li> <li><a href="http://www.lispworks.com/">LispWorks 4.4.6</a></li> + <li><a href="http://sbcl.sourceforge.net/">SBCL 0.9.15 or later</a></li> </ul> The supported Windows versions are: <ul> <li>XP SP2</li> - <li>Vista (in progress, testing on Beta 2 currently underway)</li> + <li>Vista (testing on Beta 2 currently underway)</li> </ul> <h3 id="mailinglists">Mailing Lists</h3>

1 0

[graphic-forms-cvs] r226 - in trunk: . docs/manual src/demos/unblocked src/uitoolkit/widgets
by junrue＠common-lisp.net 21 Aug '06

21 Aug '06

Author: junrue Date: Mon Aug 21 00:36:51 2006 New Revision: 226 Modified: trunk/NEWS.txt trunk/README.txt trunk/build.lisp trunk/config.lisp trunk/docs/manual/overview.texinfo trunk/graphic-forms-tests.asd trunk/src/demos/unblocked/tiles-panel.lisp trunk/src/demos/unblocked/unblocked-model.lisp trunk/src/demos/unblocked/unblocked-window.lisp trunk/src/uitoolkit/widgets/file-dialog.lisp Log: completed removal of Cells usage, updated dependency documentation Modified: trunk/NEWS.txt ============================================================================== --- trunk/NEWS.txt (original) +++ trunk/NEWS.txt Mon Aug 21 00:36:51 2006 @@ -1,11 +1,16 @@ . SBCL 0.9.15 is now supported. Graphic-Forms includes a small patch -to enable the stdcall calling convention for alien callbacks, located -in src/external-libraries/sbcl-callback-patch + to enable the stdcall calling convention for alien callbacks, located + in src/external-libraries/sbcl-callback-patch. + +. Implemented a plugin mechanism for integrating graphics libraries. . Implemented the standard color chooser dialog. +. Simplified external library dependencies, getting rid of some and + bundling small libraries into the Graphic-Forms distribution. + ============================================================================== Modified: trunk/README.txt ============================================================================== --- trunk/README.txt (original) +++ trunk/README.txt Mon Aug 21 00:36:51 2006 @@ -16,9 +16,6 @@ http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/cclan/asdf/ *note: ASDF is bundled with SBCL* - - Cells (latest from CVS) - http://www.common-lisp.net/project/cells/ - - CFFI (cffi-060606 or later) http://common-lisp.net/project/cffi/ @@ -114,7 +111,6 @@ ;; load the other dependencies besides ImageMagick. Or if your Lisp ;; image already has these systems loaded, set the variables to nil. ;; - ;; gfsys::*cells-dir* ;; gfsys::*cffi-dir* ;; gfsys::*closer-mop-dir* ;; gfsys::*lw-compat-dir* Modified: trunk/build.lisp ============================================================================== --- trunk/build.lisp (original) +++ trunk/build.lisp Mon Aug 21 00:36:51 2006 @@ -44,7 +44,6 @@ (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-060606/")) (setf *closer-mop-dir* (concatenate 'string *asdf-repo-root* "closer-mop/")) (setf *lw-compat-dir* (concatenate 'string *asdf-repo-root* "lw-compat/")) Modified: trunk/config.lisp ============================================================================== --- trunk/config.lisp (original) +++ trunk/config.lisp Mon Aug 21 00:36:51 2006 @@ -39,7 +39,6 @@ (in-package #:graphic-forms-system) -(defvar *cells-dir* "cells/") (defvar *cffi-dir* "cffi-060606/") (defvar *closer-mop-dir* "closer-mop/") (defvar *lw-compat-dir* "lw-compat/") @@ -54,7 +53,6 @@ (defun configure-asdf () (pushnew *binary-data-dir* asdf:*central-registry* :test #'equal) - (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/docs/manual/overview.texinfo ============================================================================== --- trunk/docs/manual/overview.texinfo (original) +++ trunk/docs/manual/overview.texinfo Mon Aug 21 00:36:51 2006 @@ -70,14 +70,13 @@ @section Dependencies -The libraries that Graphic-Forms relies upon are: +@strong{Libraries required by Graphic-Forms to be downloaded +separately:} @table @code @item ASDF -@url{http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/cclan/asdf} - -@item Cells (latest from CVS) -@url{http://www.common-lisp.net/project/cells/} +@url{http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/cclan/asdf}@* +@emph{Note that ASDF is bundled with SBCL.} @item CFFI @url{http://common-lisp.net/project/cffi} @@ -85,21 +84,39 @@ @item Closer to MOP @url{http://common-lisp.net/project/closer/downloads.html} -@item ImageMagick -@url{http://www.imagemagick.org/download/binaries/ImageMagick-6.2.6-5-Q16-windows-dll.exe} +@item lw-compat +@url{http://common-lisp.net/project/closer/downloads.html} +@end table + +@strong{Required libraries bundled with Graphic-Forms:} + +@table @code + +@item Practical Common Lisp Chapter08 and Chapter24 +@url{http://www.gigamonkeys.com/book/practicals-1.0.3.tar.gz} @item lisp-unit @url{http://www.cs.northwestern.edu/academics/courses/325/readings/lisp-unit.html} -@item lw-compat -@url{http://common-lisp.net/project/closer/downloads.html} +@end table + +@strong{Optional libraries that can be used with Graphic-Forms:} + +@table @code + +@item ImageMagick +@url{http://imagemagick.org/script/binary-releases.php#windows}@* +@emph{Install the Q16 version and push the symbol +:load-imagemagick-plugin onto *features* before executing ASDF.} + @end table @section Building the Library and Running Tests Please see the @code{README.txt} file included in the -distribution for instructions on how to load the ASDF system and run tests. +distribution for instructions on how to load the test program +ASDF system and run unit-tests, test programs, and demo programs. @section Support Modified: trunk/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Mon Aug 21 00:36:51 2006 @@ -55,7 +55,6 @@ :version "0.5.0" :author "Jack D. Unrue" :licence "BSD" - :depends-on ("cells") :components ((:module "src" :components Modified: trunk/src/demos/unblocked/tiles-panel.lisp ============================================================================== --- trunk/src/demos/unblocked/tiles-panel.lisp (original) +++ trunk/src/demos/unblocked/tiles-panel.lisp Mon Aug 21 00:36:51 2006 @@ -117,7 +117,10 @@ (shape-pnts (shape-pnts-of self))) (when (and (eql button :left-button) shape-pnts) (if (and tile-pnt (find tile-pnt shape-pnts :test #'eql-point)) - (game-shape-data shape-pnts) + (progn + (update-game-tiles shape-pnts) + (update-panel (get-scoreboard-panel)) + (update-panel (get-tiles-panel))) (draw-tiles-directly panel shape-pnts (shape-kind-of self))))) (setf (shape-kind-of self) 0) (setf (shape-pnts-of self) nil)) Modified: trunk/src/demos/unblocked/unblocked-model.lisp ============================================================================== --- trunk/src/demos/unblocked/unblocked-model.lisp (original) +++ trunk/src/demos/unblocked/unblocked-model.lisp Mon Aug 21 00:36:51 2006 @@ -48,66 +48,53 @@ until (> entry score) finally (return level))) -(defun revise-tiles (active-tiles orig-tiles shape-data) - (if shape-data - (loop with tmp = (clone-tiles active-tiles) - for pnt in shape-data do (set-tile tmp pnt 0) - finally (return (collapse-tiles tmp))) - orig-tiles)) - -(cells:defmodel unblocked-game-model () - ((level - :accessor level - :initform (cells:c? (lookup-level-reached (^score)))) - (score - :accessor score - :initform (cells:c? (+ (or cells:.cache 0) - (* 5 (length (^shape-data)))))) +(defun compute-new-game-tiles () + (collapse-tiles (init-tiles +horz-tile-count+ +vert-tile-count+ (1- +max-tile-kinds+)))) + +(defclass unblocked-game-model () + ((score + :accessor score-of + :initform 0) (shape-data - :accessor shape-data - :initform (cells:c-in nil)) + :accessor shape-data-of + :initform nil) (original-tiles - :accessor original-tiles - :initarg :original-tiles - :initform (cells:c-in (collapse-tiles (init-tiles +horz-tile-count+ - +vert-tile-count+ - (1- +max-tile-kinds+))))) + :accessor original-tiles-of + :initform nil) (active-tiles - :accessor active-tiles - :initform (cells:c? (revise-tiles cells:.cache (^original-tiles) (^shape-data)))))) + :accessor active-tiles-of + :initform nil))) (defvar *game* (make-instance 'unblocked-game-model)) (defun new-game () - (cells:cells-reset) - (setf *game* (make-instance 'unblocked-game-model))) + (let ((tiles (compute-new-game-tiles))) + (setf (score-of *game*) 0 + (original-tiles-of *game*) tiles + (active-tiles-of *game*) tiles))) (defun restart-game () - (let ((saved-tiles (original-tiles *game*))) - (cells:cells-reset) - (setf *game* (make-instance 'unblocked-game-model :original-tiles saved-tiles)))) + (setf (score-of *game*) 0 + (active-tiles-of *game*) (original-tiles-of *game*))) (defun game-tiles () - (active-tiles *game*)) + (active-tiles-of *game*)) -(defun game-shape-data (pnts) - (setf (shape-data *game*) pnts)) +(defun update-game-tiles (shape-data) + (setf (active-tiles-of *game*) + (if shape-data + (progn + (incf (score-of *game*) (* 5 (length shape-data))) + (loop with tmp = (clone-tiles (active-tiles-of *game*)) + for pnt in shape-data do (set-tile tmp pnt 0) + finally (return (collapse-tiles tmp)))) + (original-tiles-of *game*)))) (defun game-level () - (level *game*)) + (lookup-level-reached (score-of *game*))) (defun game-points-needed () - (- (nth (1- (level *game*)) *points-needed-table*) (score *game*))) + (- (nth (1- (game-level)) *points-needed-table*) (score-of *game*))) (defun game-score () - (score *game*)) - -(defun update-panel (panel) - (update-buffer (gfw:dispatcher panel)) - (gfw:redraw panel)) - -(cells:defobserver score ((self unblocked-game-model)) - (update-panel (get-scoreboard-panel))) - -(cells:defobserver active-tiles ((self unblocked-game-model)) - (update-panel (get-tiles-panel))) + (score-of *game*)) Modified: trunk/src/demos/unblocked/unblocked-window.lisp ============================================================================== --- trunk/src/demos/unblocked/unblocked-window.lisp (original) +++ trunk/src/demos/unblocked/unblocked-window.lisp Mon Aug 21 00:36:51 2006 @@ -65,6 +65,10 @@ (kind (shape-kind shape))) (and (> size 1) (/= kind 0) (/= kind +max-tile-kinds+)))) +(defun update-panel (panel) + (update-buffer (gfw:dispatcher panel)) + (gfw:redraw panel)) + (defun reveal-unblocked (disp item) (declare (ignore disp item)) (let ((shape (find-shape (game-tiles) #'accept-shape-p))) Modified: trunk/src/uitoolkit/widgets/file-dialog.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/file-dialog.lisp (original) +++ trunk/src/uitoolkit/widgets/file-dialog.lisp Mon Aug 21 00:36:51 2006 @@ -124,7 +124,7 @@ (title-buffer (cffi:null-pointer)) (dir-buffer (cffi:null-pointer)) (ext-buffer (cffi:null-pointer)) - (file-buffer (cffi:foreign-alloc :char :count 1024 :initial-element #\Null))) ; see FIXME above + (file-buffer (cffi:foreign-alloc :char :count 1024 :initial-element 0))) ; see FIXME above (if text (setf title-buffer (collect-foreign-strings (list text)))) (if initial-directory

1 0

[graphic-forms-cvs] r225 - in trunk: . src/demos src/demos/textedit src/demos/unblocked src/uitoolkit/widgets
by junrue＠common-lisp.net 21 Aug '06

21 Aug '06

Author: junrue Date: Sun Aug 20 23:03:53 2006 New Revision: 225 Added: trunk/src/demos/demo-utils.lisp trunk/src/demos/textedit/textedit.ico (contents, props changed) trunk/src/demos/unblocked/unblocked.ico (contents, props changed) Modified: trunk/graphic-forms-tests.asd trunk/src/demos/textedit/textedit-document.lisp trunk/src/demos/textedit/textedit-window.lisp trunk/src/demos/unblocked/unblocked-window.lisp trunk/src/uitoolkit/widgets/file-dialog.lisp Log: fixed bug in extract-foreign-strings function; removal of Cells usage from textedit demo; implemented shared about dialog for demo programs Modified: trunk/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Sun Aug 20 23:03:53 2006 @@ -61,13 +61,16 @@ :components ((:module "demos" :components - ((:module "textedit" + ((:file "demo-utils") + (:module "textedit" :serial t + :depends-on ("demo-utils") :components ((:file "textedit-document") (:file "textedit-window"))) (:module "unblocked" :serial t + :depends-on ("demo-utils") :components ((:file "tiles") (:file "unblocked-model") Added: trunk/src/demos/demo-utils.lisp ============================================================================== --- (empty file) +++ trunk/src/demos/demo-utils.lisp Sun Aug 20 23:03:53 2006 @@ -0,0 +1,96 @@ +;;;; +;;;; demo-utils.lisp +;;;; +;;;; Copyright (C) 2006, Jack D. Unrue +;;;; All rights reserved. +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; +;;;; 3. Neither the names of the authors nor the names of its contributors +;;;; may be used to endorse or promote products derived from this software +;;;; without specific prior written permission. +;;;; +;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY +;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS- +;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY +;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;;;; + +(in-package :graphic-forms.uitoolkit.tests) + +(defclass demo-about-dialog-events (gfw:event-dispatcher) ()) + +(defmethod gfw:event-close ((disp demo-about-dialog-events) (dlg gfw:dialog)) + (call-next-method) + (gfs:dispose dlg)) + +(defun about-demo (owner image-path title desc) + (let* ((image (make-instance 'gfg:image :file image-path)) + (dlg (make-instance 'gfw:dialog :owner owner + :dispatcher (make-instance 'demo-about-dialog-events) + :layout (make-instance 'gfw:flow-layout + :margins 8 + :spacing 8) + :style '(:owner-modal) + :text title)) + (label (make-instance 'gfw:label :parent dlg)) + (text-panel (make-instance 'gfw:panel + :layout (make-instance 'gfw:flow-layout + :margins 0 + :spacing 2 + :style '(:vertical)) + :parent dlg)) + (line1 (make-instance 'gfw:label + :parent text-panel + :text desc)) + (line2 (make-instance 'gfw:label + :parent text-panel + :text " ")) + (line3 (make-instance 'gfw:label + :parent text-panel + :text (format nil "Copyright ~c 2006 by Jack D. Unrue" (code-char 169)))) + (line4 (make-instance 'gfw:label + :parent text-panel + :text "All Rights Reserved.")) + (line5 (make-instance 'gfw:label + :parent text-panel + :text " ")) + (line6 (make-instance 'gfw:label + :parent text-panel + :text " ")) + (btn-panel (make-instance 'gfw:panel + :parent dlg + :layout (make-instance 'gfw:flow-layout + :margins 0 + :spacing 0 + :style '(:vertical :normalize)))) + (close-btn (make-instance 'gfw:button + :callback (lambda (disp btn) + (declare (ignore disp btn)) + (gfs:dispose dlg)) + :style '(:cancel-button) + :text "Close" + :parent btn-panel))) + (declare (ignore line1 line2 line3 line4 line5 line6 close-btn)) + (unwind-protect + (gfg:with-image-transparency (image (gfs:make-point)) + (setf (gfw:image label) image)) + (gfs:dispose image)) + (gfw:pack dlg) + (gfw:center-on-owner dlg) + (gfw:show dlg t))) Modified: trunk/src/demos/textedit/textedit-document.lisp ============================================================================== --- trunk/src/demos/textedit/textedit-document.lisp (original) +++ trunk/src/demos/textedit/textedit-document.lisp Sun Aug 20 23:03:53 2006 @@ -33,18 +33,13 @@ (in-package :graphic-forms.uitoolkit.tests) -(cells:defmodel textedit-document () - ((content-replaced - :cell :ephemeral - :accessor content-replaced - :initform (cells:c-in nil)) - (content-modified - :cell :ephemeral - :accessor content-modified - :initform (cells:c-in nil)) +(defclass textedit-document () + ((content-modified + :accessor content-modified-of + :initform nil) (file-path - :accessor file-path - :initform (cells:c-in nil)))) + :accessor file-path-of + :initform nil))) (defvar *textedit-model* (make-instance 'textedit-document)) @@ -57,7 +52,7 @@ (if (zerop (length line)) (setf buffer (concatenate 'string buffer (format nil "~c~c" #\Return #\Newline))) (setf buffer (concatenate 'string buffer (format nil "~a~c~c" line #\Return #\Newline)))))) - (setf (content-replaced *textedit-model*) buffer))) + buffer)) (defun save-textedit-doc (path buffer) (with-open-file (output path :direction :output :if-exists :supersede) Modified: trunk/src/demos/textedit/textedit-window.lisp ============================================================================== --- trunk/src/demos/textedit/textedit-window.lisp (original) +++ trunk/src/demos/textedit/textedit-window.lisp Sun Aug 20 23:03:53 2006 @@ -39,16 +39,21 @@ (defvar *textedit-file-filters* '(("Text Files (*.txt)" . "*.txt") ("All Files (*.*)" . "*.*"))) +(defvar *textedit-new-title* "new file - TextEdit") + + (defun manage-textedit-file-menu (disp menu) (declare (ignore disp)) - (gfw:enable (elt (gfw:items menu) 2) (gfw:text-modified-p *textedit-control*))) + (gfw:enable (elt (gfw:items menu) 2) (gfw:text-modified-p *textedit-control*)) + (gfw:enable (elt (gfw:items menu) 3) (> (length (gfw:text *textedit-control*)) 0))) (defun textedit-file-new (disp item) (declare (ignore disp item)) (when *textedit-control* (setf (gfw:text *textedit-control*) "") (setf (gfw:text-modified-p *textedit-control*) nil) - (setf (file-path *textedit-model*) nil))) + (setf (file-path-of *textedit-model*) nil) + (setf (gfw:text *textedit-win*) *textedit-new-title*))) (defun textedit-file-open (disp item) (declare (ignore disp item)) @@ -57,14 +62,16 @@ paths :filters *textedit-file-filters*) (when paths - (load-textedit-doc (first paths)) - (setf (file-path *textedit-model*) (namestring (first paths)))))) + (setf (gfw:text *textedit-control*) (load-textedit-doc (first paths))) + (setf (file-path-of *textedit-model*) (namestring (first paths))) + (setf (gfw:text *textedit-win*) (format nil "~a - TextEdit" (first paths)))))) (defun textedit-file-save (disp item) - (if (file-path *textedit-model*) - (save-textedit-doc (file-path *textedit-model*) (gfw:text *textedit-control*)) + (if (file-path-of *textedit-model*) + (save-textedit-doc (file-path-of *textedit-model*) (gfw:text *textedit-control*)) (textedit-file-save-as disp item)) - (setf (gfw:text-modified-p *textedit-control*) nil)) + (if (file-path-of *textedit-model*) + (setf (gfw:text-modified-p *textedit-control*) nil))) (defun textedit-file-save-as (disp item) (declare (ignore disp item)) @@ -75,8 +82,9 @@ :text "Save As") (when paths (save-textedit-doc (first paths) (gfw:text *textedit-control*)) - (setf (file-path *textedit-model*) (namestring (first paths))) - (setf (gfw:text-modified-p *textedit-control*) nil)))) + (setf (file-path-of *textedit-model*) (namestring (first paths)) + (gfw:text *textedit-win*) (format nil "~a - TextEdit" (first paths)) + (gfw:text-modified-p *textedit-control*) nil)))) (defun textedit-file-quit (disp item) (declare (ignore disp item)) @@ -143,80 +151,11 @@ (declare (ignore window)) (textedit-file-quit disp nil)) -(defclass textedit-about-dialog-events (gfw:event-dispatcher) ()) - -(defmethod gfw:event-close ((disp textedit-about-dialog-events) (dlg gfw:dialog)) - (call-next-method) - (gfs:dispose dlg)) - (defun about-textedit (disp item) (declare (ignore disp item)) (let* ((*default-pathname-defaults* (parse-namestring gfsys::*textedit-dir*)) - (image (make-instance 'gfg:image :file (merge-pathnames "about.bmp"))) - (dlg (make-instance 'gfw:dialog :owner *textedit-win* - :dispatcher (make-instance 'textedit-about-dialog-events) - :layout (make-instance 'gfw:flow-layout - :margins 8 - :spacing 8) - :style '(:owner-modal) - :text (concatenate 'string "About TextEdit"))) - (label (make-instance 'gfw:label :parent dlg)) - (text-panel (make-instance 'gfw:panel - :layout (make-instance 'gfw:flow-layout - :margins 0 - :spacing 2 - :style '(:vertical)) - :parent dlg)) - (line1 (make-instance 'gfw:label - :parent text-panel - :text "TextEdit version 0.5")) - (line2 (make-instance 'gfw:label - :parent text-panel - :text " ")) - (line3 (make-instance 'gfw:label - :parent text-panel - :text (format nil "Copyright ~c 2006 by Jack D. Unrue" (code-char 169)))) - (line4 (make-instance 'gfw:label - :parent text-panel - :text "All Rights Reserved.")) - (line5 (make-instance 'gfw:label - :parent text-panel - :text " ")) - (line6 (make-instance 'gfw:label - :parent text-panel - :text " ")) - (btn-panel (make-instance 'gfw:panel - :parent dlg - :layout (make-instance 'gfw:flow-layout - :margins 0 - :spacing 0 - :style '(:vertical :normalize)))) - (close-btn (make-instance 'gfw:button - :callback (lambda (disp btn) - (declare (ignore disp btn)) - (gfs:dispose dlg)) - :style '(:cancel-button) - :text "Close" - :parent btn-panel))) - (declare (ignore line1 line2 line3 line4 line5 line6 close-btn)) - (unwind-protect - (gfg:with-image-transparency (image (gfs:make-point)) - (setf (gfw:image label) image)) - (gfs:dispose image)) - (gfw:pack dlg) - (gfw:center-on-owner dlg) - (gfw:show dlg t))) - -(cells:defobserver content-replaced ((self textedit-document)) - (if *textedit-control* - (setf (gfw:text *textedit-control*) (content-replaced self)))) - -(cells:defobserver content-modified ((self textedit-document))) - -(cells:defobserver file-path ((self textedit-document)) - (if *textedit-win* - (setf (gfw:text *textedit-win*) (format nil "~a - GraphicForms TextEdit" (file-path self))) - (setf (gfw:text *textedit-win*) "new file - GraphicForms TextEdit"))) + (image-path (merge-pathnames "about.bmp"))) + (about-demo *textedit-win* image-path "About TextEdit" "TextEdit version 0.5"))) (defun textedit-startup () (let ((menubar (gfw:defmenu ((:item "&File" :callback #'manage-textedit-file-menu @@ -252,9 +191,11 @@ :auto-vscroll :vertical-scrollbar :want-return))) - (setf (gfw:menu-bar *textedit-win*) menubar) - (setf (gfw:size *textedit-win*) (gfs:make-size :width 500 :height 500)) - (setf (gfw:text *textedit-win*) "new file - GraphicForms TextEdit") + (setf (gfw:menu-bar *textedit-win*) menubar + (gfw:size *textedit-win*) (gfs:make-size :width 500 :height 500) + (gfw:text *textedit-win*) *textedit-new-title*) + (let ((*default-pathname-defaults* (parse-namestring gfsys::*textedit-dir*))) + (setf (gfw:image *textedit-win*) (make-instance 'gfg:icon-bundle :file (merge-pathnames "textedit.ico")))) (gfw:show *textedit-win* t))) (defun textedit () Added: trunk/src/demos/textedit/textedit.ico ============================================================================== Binary file. No diff available. Modified: trunk/src/demos/unblocked/unblocked-window.lisp ============================================================================== --- trunk/src/demos/unblocked/unblocked-window.lisp (original) +++ trunk/src/demos/unblocked/unblocked-window.lisp Sun Aug 20 23:03:53 2006 @@ -94,79 +94,21 @@ (declare (ignore timer)) (update-panel *tiles-panel*)) -(defclass unblocked-about-dialog-events (gfw:event-dispatcher) ()) - -(defmethod gfw:event-close ((disp unblocked-about-dialog-events) (dlg gfw:dialog)) - (call-next-method) - (gfs:dispose dlg)) - (defun about-unblocked (disp item) (declare (ignore disp item)) (let* ((*default-pathname-defaults* (parse-namestring gfsys::*unblocked-dir*)) - (image (make-instance 'gfg:image :file (merge-pathnames "about.bmp"))) - (dlg (make-instance 'gfw:dialog :owner *unblocked-win* - :dispatcher (make-instance 'unblocked-about-dialog-events) - :layout (make-instance 'gfw:flow-layout - :margins 8 - :spacing 8) - :style '(:owner-modal) - :text (concatenate 'string "About UnBlocked"))) - (label (make-instance 'gfw:label :parent dlg)) - (text-panel (make-instance 'gfw:panel - :layout (make-instance 'gfw:flow-layout - :margins 0 - :spacing 2 - :style '(:vertical)) - :parent dlg)) - (line1 (make-instance 'gfw:label - :parent text-panel - :text "UnBlocked version 0.5")) - (line2 (make-instance 'gfw:label - :parent text-panel - :text " ")) - (line3 (make-instance 'gfw:label - :parent text-panel - :text (format nil "Copyright ~c 2006 by Jack D. Unrue" (code-char 169)))) - (line4 (make-instance 'gfw:label - :parent text-panel - :text "All Rights Reserved.")) - (line5 (make-instance 'gfw:label - :parent text-panel - :text " ")) - (line6 (make-instance 'gfw:label - :parent text-panel - :text " ")) - (btn-panel (make-instance 'gfw:panel - :parent dlg - :layout (make-instance 'gfw:flow-layout - :margins 0 - :spacing 0 - :style '(:vertical :normalize)))) - (close-btn (make-instance 'gfw:button - :callback (lambda (disp btn) - (declare (ignore disp btn)) - (gfs:dispose dlg)) - :style '(:cancel-button) - :text "Close" - :parent btn-panel))) - (declare (ignore line1 line2 line3 line4 line5 line6 close-btn)) - (unwind-protect - (gfg:with-image-transparency (image (gfs:make-point)) - (setf (gfw:image label) image)) - (gfs:dispose image)) - (gfw:pack dlg) - (gfw:center-on-owner dlg) - (gfw:show dlg t))) + (image-path (merge-pathnames "about.bmp"))) + (about-demo *unblocked-win* image-path "About UnBlocked" "UnBlocked version 0.5"))) (defun unblocked-startup () (let ((menubar (gfw:defmenu ((:item "&File" - :submenu ((:item "&New" :callback #'new-unblocked) - (:item "&Restart" :callback #'restart-unblocked) - (:item "Reveal &Move" :callback #'reveal-unblocked) - (:item "" :separator) - (:item "E&xit" :callback #'quit-unblocked))) + :submenu ((:item "&New" :callback #'new-unblocked) + (:item "&Restart" :callback #'restart-unblocked) + (:item "Reveal &Move" :callback #'reveal-unblocked) + (:item "" :separator) + (:item "E&xit" :callback #'quit-unblocked))) (:item "&Help" - :submenu ((:item "&About" :callback #'about-unblocked)))))) + :submenu ((:item "&About UnBlocked" :callback #'about-unblocked)))))) (scoreboard-buffer-size (compute-scoreboard-size)) (tile-buffer-size (gfs:make-size :width (+ (* +horz-tile-count+ +tile-bmp-width+) 2) @@ -189,14 +131,16 @@ :style '(:border) :dispatcher (make-instance 'tiles-panel-events :buffer-size tile-buffer-size))) - (setf (gfw:text *unblocked-win*) "Graphic-Forms UnBlocked") + (setf (gfw:text *unblocked-win*) "UnBlocked") (setf (gfw:resizable-p *unblocked-win*) nil) (let ((size (gfw:preferred-size *unblocked-win* -1 -1))) - (setf (gfw:minimum-size *unblocked-win*) size) - (setf (gfw:maximum-size *unblocked-win*) size)) + (setf (gfw:minimum-size *unblocked-win*) size + (gfw:maximum-size *unblocked-win*) size)) (new-unblocked nil nil) + (let ((*default-pathname-defaults* (parse-namestring gfsys::*unblocked-dir*))) + (setf (gfw:image *unblocked-win*) (make-instance 'gfg:icon-bundle :file (merge-pathnames "unblocked.ico")))) (gfw:show *unblocked-win* t))) (defun unblocked () Added: trunk/src/demos/unblocked/unblocked.ico ============================================================================== Binary file. No diff available. Modified: trunk/src/uitoolkit/widgets/file-dialog.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/file-dialog.lisp (original) +++ trunk/src/uitoolkit/widgets/file-dialog.lisp Sun Aug 20 23:03:53 2006 @@ -124,7 +124,7 @@ (title-buffer (cffi:null-pointer)) (dir-buffer (cffi:null-pointer)) (ext-buffer (cffi:null-pointer)) - (file-buffer (cffi:foreign-alloc :char :count 1024))) ; see FIXME above + (file-buffer (cffi:foreign-alloc :char :count 1024 :initial-element #\Null))) ; see FIXME above (if text (setf title-buffer (collect-foreign-strings (list text)))) (if initial-directory

1 0

[graphic-forms-cvs] r224 - in trunk: . docs/manual src/uitoolkit/graphics src/uitoolkit/widgets
by junrue＠common-lisp.net 20 Aug '06

20 Aug '06

Author: junrue Date: Sat Aug 19 22:13:35 2006 New Revision: 224 Modified: trunk/docs/manual/graphics-api.texinfo trunk/docs/manual/widgets-api.texinfo trunk/graphic-forms-uitoolkit.asd trunk/src/uitoolkit/graphics/graphics-generics.lisp trunk/src/uitoolkit/widgets/control.lisp trunk/src/uitoolkit/widgets/item.lisp trunk/src/uitoolkit/widgets/thread-context.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp trunk/src/uitoolkit/widgets/window.lisp Log: cleaned up some SBCL style warnings Modified: trunk/docs/manual/graphics-api.texinfo ============================================================================== --- trunk/docs/manual/graphics-api.texinfo (original) +++ trunk/docs/manual/graphics-api.texinfo Sat Aug 19 22:13:35 2006 @@ -317,19 +317,23 @@ this time. @anchor{background-color} -@deffn GenericFunction background-color self +@deffn GenericFunction background-color self => @ref{color} +(setf (@strong{background-color} @var{self}) @var{color})@*@* Returns a color object corresponding to the current background color. +The corresponding @sc{setf} function allows the background color to +be set. @end deffn @anchor{data-object} @deffn GenericFunction data-object self &optional gc => object +(setf (@strong{data-object} @var{self}) @var{object})@*@* Returns the data structure representing the raw data form of the object. The @code{gc} argument must be supplied when calling this -function on a @ref{font}, and the value must be a -@ref{graphics-context}. +function on a @ref{font}, and the value must be a @ref{graphics-context}. +The corresponding @sc{setf} function updates this representation. @end deffn -@deffn GenericFunction depth self +@deffn GenericFunction depth self => integer Returns the bits-per-pixel depth of the object. @end deffn @@ -521,13 +525,18 @@ @end table @end deffn -@deffn GenericFunction font self -Returns the current font. +@deffn GenericFunction font self => @ref{font} +(setf (@strong{font} @var{self}) @var{font})@*@* +Returns the current font. The corresponding @sc{setf} function +allows the font to be set. @end deffn @anchor{foreground-color} -@deffn GenericFunction foreground-color self +@deffn GenericFunction foreground-color self => @ref{color} +(setf (@strong{foreground-color} @var{self}) @var{color})@*@* Returns a color object corresponding to the current foreground color. +The corresponding @sc{setf} function allows the foreground color +to be set. @end deffn @anchor{icon-bundle-length} @@ -603,7 +612,10 @@ @end defun @deffn GenericFunction size self => @ref{size} +(setf (@strong{size} @var{self}) @var{size})@*@* Returns a size object describing the dimensions of @var{self}. +The corresponding @sc{setf} function allows the size to be +set. @end deffn @deffn GenericFunction text-extent self text &optional style tab-width @@ -632,5 +644,6 @@ @defmac with-image-transparency (image point) &body body This macro wraps @var{body} in an @sc{unwind-protect} form with @var{point} set as the @ref{transparency-pixel} for @var{image}. -Any existing point set in @var{image} is restored. +The original point set in @var{image}, if any, is restored after +@var{body} completes. @end defmac Modified: trunk/docs/manual/widgets-api.texinfo ============================================================================== --- trunk/docs/manual/widgets-api.texinfo (original) +++ trunk/docs/manual/widgets-api.texinfo Sat Aug 19 22:13:35 2006 @@ -1395,9 +1395,7 @@ @end deffn @deffn GenericFunction image self => @ref{image} - -(setf (@strong{image} @var{self}) @var{image})@* - +(setf (@strong{image} @var{self}) @var{image})@*@* Returns the image currently associated with @var{self}. The @sc{setf} function changes the image. If @var{self} is a @ref{window}, then this function returns an @ref{icon-bundle}. And in that case, the @sc{setf} function accepts either @@ -1419,6 +1417,7 @@ @end deffn @deffn GenericFunction location self => @ref{point} +(setf (@strong{location} @var{self}) @var{point})@*@* Returns a point object describing the coordinates of the top-left corner of the object in its parent's coordinate system. @xref{parent}. @@ -1433,6 +1432,7 @@ @anchor{maximum-size} @deffn GenericFunction maximum-size self => size +(setf (@strong{maximum-size} @var{self}) @var{size})@*@* Returns a @ref{size} object describing the largest dimensions to which the user may resize this widget. By default, @ref{window}s and @ref{control}s return @sc{nil} indicating that there is effectively no @@ -1442,12 +1442,14 @@ is resized to the new maximum. @xref{minimum-size}. @end deffn -@deffn GenericFunction menu-bar self +@deffn GenericFunction menu-bar self => @ref{menu} +(setf (@strong{menu-bar} @var{self}) @var{menu})@*@* Returns the menu object serving as the menubar for this object. @end deffn @anchor{minimum-size} @deffn GenericFunction minimum-size self => size +(setf (@strong{minimum-size} @var{self}) @var{size})@*@* Returns a @ref{size} object describing the smallest dimensions to which the user may resize this widget. By default, @ref{window} objects return @sc{nil} indicating that the minimum constraint is @@ -1625,7 +1627,8 @@ necessarily top-most in the display z-order. @end deffn -@deffn GenericFunction size self +@deffn GenericFunction size self => @ref{size} +(setf (@strong{size} @var{self}) @var{size})@*@* Returns a size object describing the size of the object in its parent's coordinate system. @end deffn @@ -1659,7 +1662,8 @@ @end deffn @anchor{text-modified-p} -@deffn GenericFunction text-modified-p self +@deffn GenericFunction text-modified-p self => boolean +(setf (@strong{text-modified-p} @var{self}) @var{boolean})@*@* Returns T if the text component of @code{self} has been modified by the user; @sc{nil} otherwise. The corresponding @sc{setf} function updates the dirty state flag. This function is not implemented for all Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Sat Aug 19 22:13:35 2006 @@ -78,12 +78,14 @@ ((:file "graphics-constants") (:file "graphics-classes") (:file "graphics-generics") - (:file "color") - (:file "palette") + (:file "color" + :depends-on ("graphics-classes")) + (:file "palette" + :depends-on ("graphics-classes")) (:file "image-data" :depends-on ("graphics-classes")) (:file "image" - :depends-on ("graphics-classes")) + :depends-on ("graphics-classes" "graphics-generics")) (:file "icon-bundle" :depends-on ("graphics-constants" "image")) (:file "font-data") Modified: trunk/src/uitoolkit/graphics/graphics-generics.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-generics.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-generics.lisp Sat Aug 19 22:13:35 2006 @@ -36,11 +36,17 @@ (defgeneric background-color (self) (:documentation "Returns a color object corresponding to the current background color.")) +(defgeneric (setf background-color) (color self) + (:documentation "Sets the current background color.")) + (defgeneric data->image (self) (:documentation "Plugins implement this to translate from a data structure to an HGDIOBJ.")) (defgeneric data-object (self &optional gc) - (:documentation "Returns the data structure representing the raw form of the object.")) + (:documentation "Returns the data structure representing the raw form of self.")) + +(defgeneric (setf data-object) (data self) + (:documentation "Sets a data structure representing the raw form of self.")) (defgeneric depth (self) (:documentation "Returns the bits-per-pixel depth of the object.")) @@ -111,9 +117,15 @@ (defgeneric font (self) (:documentation "Returns the current font.")) +(defgeneric (setf font) (font self) + (:documentation "Sets the current font.")) + (defgeneric foreground-color (self) (:documentation "Returns a color object corresponding to the current foreground color.")) +(defgeneric (setf foreground-color) (color self) + (:documentation "Sets the current foreground color.")) + (defgeneric load (self path) (:documentation "Loads the object from filesystem data identified by the specified pathname or string.")) @@ -121,7 +133,10 @@ (:documentation "Returns a font-metrics object describing key attributes of the specified font.")) (defgeneric size (self) - (:documentation "Returns a size object describing the size of the object.")) + (:documentation "Returns a size object describing the dimensions of self.")) + +(defgeneric (setf size) (size self) + (:documentation "Sets the dimensions of self.")) (defgeneric text-extent (self str &optional style tab-width) (:documentation "Returns the size of the rectangular area that would be covered by the string if drawn in the current font.")) Modified: trunk/src/uitoolkit/widgets/control.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/control.lisp (original) +++ trunk/src/uitoolkit/widgets/control.lisp Sat Aug 19 22:13:35 2006 @@ -117,7 +117,6 @@ font)) (defmethod (setf gfg:font) :before (font (self control)) - (declare (ignore color)) (if (or (gfs:disposed-p self) (gfs:disposed-p font)) (error 'gfs:disposed-error))) @@ -161,19 +160,24 @@ (let ((class (define-dispatcher (class-name (class-of self)) callback))) (setf (dispatcher self) (make-instance (class-name class)))))) -(defmethod (setf maximum-size) :after (max-size (self control)) +(defmethod maximum-size ((self control)) + (max-size-of self)) + +(defmethod (setf maximum-size) (max-size (self control)) (unless (gfs:disposed-p self) + (setf (max-size-of self) max-size) (let ((size (constrain-new-size max-size (size self) #'min))) (setf (size self) size)))) -(defmethod minimum-size :after ((self control)) - (let ((size (slot-value self 'minimum-size))) +(defmethod minimum-size ((self control)) + (let ((size (min-size-of self))) (if (null size) (preferred-size self -1 -1) size))) -(defmethod (setf minimum-size) :after (min-size (self control)) +(defmethod (setf minimum-size) (min-size (self control)) (unless (gfs:disposed-p self) + (setf (min-size-of self) min-size) (let ((size (constrain-new-size min-size (size self) #'max))) (setf (size self) size)))) Modified: trunk/src/uitoolkit/widgets/item.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/item.lisp (original) +++ trunk/src/uitoolkit/widgets/item.lisp Sat Aug 19 22:13:35 2006 @@ -42,6 +42,5 @@ (error 'gfs:toolkit-error :detail "null owner handle"))) (defmethod checked-p :before ((self item)) - (declare (ignore flag)) (if (gfs:null-handle-p (gfs:handle self)) (error 'gfs:toolkit-error :detail "null owner handle"))) Modified: trunk/src/uitoolkit/widgets/thread-context.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/thread-context.lisp (original) +++ trunk/src/uitoolkit/widgets/thread-context.lisp Sat Aug 19 22:13:35 2006 @@ -95,6 +95,28 @@ (gfs::destroy-window hwnd))))) (setf (getf (mp:process-plist mp:*current-process*) 'thread-context) nil)) +(defgeneric init-utility-hwnd (self)) +(defgeneric call-child-visitor-func (self parent child)) +(defgeneric call-display-visitor-func (self hmonitor data)) +(defgeneric call-top-level-visitor-func (self window)) +(defgeneric get-widget (self hwnd)) +(defgeneric put-widget (self widget)) +(defgeneric delete-widget (self hwnd)) +(defgeneric widget-in-progress (self)) +(defgeneric (setf widget-in-progress) (widget self)) +(defgeneric clear-widget-in-progress (self)) +(defgeneric put-kbdnav-widget (self widget)) +(defgeneric delete-kbdnav-widget (self widget)) +(defgeneric intercept-kbdnav-message (self msg-ptr)) +(defgeneric get-menuitem (self id)) +(defgeneric put-menuitem (self item)) +(defgeneric delete-menuitem (self item)) +(defgeneric increment-menuitem-id (self)) +(defgeneric get-timer (self id)) +(defgeneric put-timer (self timer)) +(defgeneric delete-timer (self timer)) +(defgeneric increment-widget-id (self)) + (defmethod init-utility-hwnd ((tc thread-context)) (register-toplevel-noerasebkgnd-window-class) (let ((hwnd (create-window "GraphicFormsTopLevelNoEraseBkgnd" ; can't use constant here Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Sat Aug 19 22:13:35 2006 @@ -115,12 +115,12 @@ (pixel-point :accessor pixel-point-of :initform nil) - (maximum-size - :accessor maximum-size + (max-size + :accessor max-size-of :initarg :maximum-size :initform nil) - (minimum-size - :accessor minimum-size + (min-size + :accessor min-size-of :initarg :minimum-size :initform nil)) (:documentation "The base class for widgets having pre-defined native behavior.")) @@ -169,12 +169,12 @@ (:documentation "The menu class represents a container for menu items (and submenus).")) (defclass window (widget layout-managed) - ((maximum-size - :accessor maximum-size + ((max-size + :accessor max-size-of :initarg :maximum-size :initform nil) - (minimum-size - :accessor minimum-size + (min-size + :accessor min-size-of :initarg :minimum-size :initform nil)) (:documentation "Base class for user-defined widgets that serve as containers.")) Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Sat Aug 19 22:13:35 2006 @@ -193,7 +193,10 @@ (:documentation "Returns T if the object is in its iconified state.")) (defgeneric image (self) - (:documentation "Returns the object's image object if it has one, or nil otherwise.")) + (:documentation "Returns self's image object if it has one, or nil otherwise.")) + +(defgeneric (setf image) (image self) + (:documentation "Sets self's image object.")) (defgeneric item-height (self) (:documentation "Return the height of the area if one of the object's items were displayed.")) @@ -211,7 +214,10 @@ (:documentation "Returns T if the object's lines are visible; nil otherwise.")) (defgeneric location (self) - (:documentation "Returns a point object describing the coordinates of the top-left corner of the object in its parent's coordinate system.")) + (:documentation "Returns a point object describing the coordinates of the top-left corner of self in its parent's coordinate system.")) + +(defgeneric (setf location) (point self) + (:documentation "Sets a point describing the coordinates of self in its parent's coordinate system.")) (defgeneric lock (self flag) (:documentation "Prevents or enables modification of the object's contents.")) @@ -229,13 +235,19 @@ (: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 dimensions to which the user may resize the widget.")) + (:documentation "Returns a size object describing the largest dimensions to which the user may resize self.")) + +(defgeneric (setf maximum-size) (size self) + (:documentation "Sets the largest dimensions to which the user may resize self.")) (defgeneric menu-bar (self) (:documentation "Returns the menu object serving as the menubar for this object.")) (defgeneric minimum-size (self) - (:documentation "Returns a size object describing the smallest size this object can exist.")) + (:documentation "Returns a size object describing the smallest supported dimensions of self.")) + +(defgeneric (setf minimum-size) (size self) + (:documentation "Sets the smallest supported dimensions of self.")) (defgeneric mouse-over-image (self) (:documentation "Returns the image displayed when the mouse is hovering over this object.")) @@ -340,7 +352,10 @@ (:documentation "This object's items are scrolled until the selection is visible.")) (defgeneric size (self) - (:documentation "Returns a size object describing the size of the object in its parent's coordinate system.")) + (:documentation "Returns the size of self in its parent's coordinate system.")) + +(defgeneric (setf size) (size self) + (:documentation "Sets the size of self in its parent's coordinate system.")) (defgeneric step-increment (self) (:documentation "Return an integer representing the configured step size for the object.")) @@ -363,6 +378,9 @@ (defgeneric text-modified-p (self) (:documentation "Returns true if the text component has been modified; nil otherwise.")) +(defgeneric (setf text-modified-p) (modified self) + (:documentation "Sets self's modified flag.")) + (defgeneric thumb-size (self) (:documentation "Returns an integer representing the width (or height) of this object's thumb.")) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Sat Aug 19 22:13:35 2006 @@ -259,15 +259,23 @@ (setf (child-visitor-results tc) nil) tmp))) -(defmethod (setf maximum-size) :after (max-size (self window)) +(defmethod maximum-size ((self window)) + (max-size-of self)) + +(defmethod (setf maximum-size) (max-size (self window)) (unless (or (gfs:disposed-p self) (null (layout-of self))) + (setf (max-size-of self) max-size) (let ((size (constrain-new-size max-size (size self) #'min))) (setf (size self) size) (perform (layout-of self) self (gfs:size-width size) (gfs:size-height size)) size))) -(defmethod (setf minimum-size) :after (min-size (self window)) +(defmethod minimum-size ((self window)) + (min-size-of self)) + +(defmethod (setf minimum-size) (min-size (self window)) (unless (or (gfs:disposed-p self) (null (layout-of self))) + (setf (min-size-of self) min-size) (let ((size (constrain-new-size min-size (size self) #'max))) (setf (size self) size) (perform (layout-of self) self (gfs:size-width size) (gfs:size-height size))

1 0

[graphic-forms-cvs] r223 - in trunk: . docs/manual src/uitoolkit/system src/uitoolkit/widgets
by junrue＠common-lisp.net 20 Aug '06

20 Aug '06

Author: junrue Date: Sat Aug 19 20:37:13 2006 New Revision: 223 Modified: trunk/NEWS.txt trunk/docs/manual/widgets-api.texinfo trunk/src/uitoolkit/system/user32.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/thread-context.lisp Log: changed obtain-event-time to call native GetMessageTime, and removed obsolete slot from thread-context Modified: trunk/NEWS.txt ============================================================================== --- trunk/NEWS.txt (original) +++ trunk/NEWS.txt Sat Aug 19 20:37:13 2006 @@ -4,6 +4,8 @@ to enable the stdcall calling convention for alien callbacks, located in src/external-libraries/sbcl-callback-patch +. Implemented the standard color chooser dialog. + ============================================================================== Modified: trunk/docs/manual/widgets-api.texinfo ============================================================================== --- trunk/docs/manual/widgets-api.texinfo (original) +++ trunk/docs/manual/widgets-api.texinfo Sat Aug 19 20:37:13 2006 @@ -1162,8 +1162,7 @@ @anchor{obtain-event-time} @defun obtain-event-time => milliseconds -Returns the timestamp for the event currently being processed, or -zero if called prior to delivery of any events. +Returns the timestamp for the event currently being processed. @end defun Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Sat Aug 19 20:37:13 2006 @@ -414,6 +414,10 @@ (filter-max UINT)) (defcfun + ("GetMessageTime" get-message-time) + LONG) + +(defcfun ("GetMonitorInfoA" get-monitor-info) BOOL (hmonitor HANDLE) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Sat Aug 19 20:37:13 2006 @@ -78,7 +78,6 @@ gfs::time gfs::pnt) msg-ptr gfs::msg) - (setf (event-time (thread-context)) gfs::time) (when (funcall msg-filter gm msg-ptr) (return-from message-loop gfs::wparam))))))) @@ -140,10 +139,8 @@ (setf ret-val (cffi:pointer-address (brush-handle-of widget)))) ret-val)) -;;; FIXME: replace event-time slot with call to GetMessageTime -;;; (defun obtain-event-time () - (event-time (thread-context))) + (gfs::get-message-time)) (defun option->reason (lparam) ;; MSDN says the value is a bitmask, so must be tested bit-wise. Modified: trunk/src/uitoolkit/widgets/thread-context.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/thread-context.lisp (original) +++ trunk/src/uitoolkit/widgets/thread-context.lisp Sat Aug 19 20:37:13 2006 @@ -40,7 +40,6 @@ (display-visitor-results :initform nil :accessor display-visitor-results) (job-table :initform (make-hash-table :test #'equal)) (job-table-lock :initform nil) - (event-time :initform 0 :accessor event-time) ; FIXME: GetMessageTime (virtual-key :initform 0 :accessor virtual-key) (menuitems-by-id :initform (make-hash-table :test #'equal)) (mouse-event-pnt :initform (gfs:make-point) :accessor mouse-event-pnt)

1 0

[graphic-forms-cvs] r222 - in trunk: . docs/manual src src/tests/uitoolkit src/uitoolkit/system src/uitoolkit/widgets
by junrue＠common-lisp.net 19 Aug '06

19 Aug '06

Author: junrue Date: Sat Aug 19 18:56:20 2006 New Revision: 222 Added: trunk/src/uitoolkit/widgets/color-dialog.lisp Modified: trunk/NEWS.txt trunk/docs/manual/widgets-api.texinfo trunk/graphic-forms-uitoolkit.asd trunk/src/packages.lisp trunk/src/tests/uitoolkit/windlg.lisp trunk/src/uitoolkit/system/comdlg32.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/system/system-types.lisp trunk/src/uitoolkit/widgets/file-dialog.lisp trunk/src/uitoolkit/widgets/font-dialog.lisp trunk/src/uitoolkit/widgets/layout.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp Log: implemented and documented system color dialog Modified: trunk/NEWS.txt ============================================================================== --- trunk/NEWS.txt (original) +++ trunk/NEWS.txt Sat Aug 19 18:56:20 2006 @@ -1,8 +1,8 @@ -. SBCL 0.9.15 is now a supported Common Lisp implementation. Graphic-Forms - includes a small patch to enable the stdcall calling convention for alien - callbacks, located in src/external-libraries/sbcl-callback-patch +. SBCL 0.9.15 is now supported. Graphic-Forms includes a small patch +to enable the stdcall calling convention for alien callbacks, located +in src/external-libraries/sbcl-callback-patch ============================================================================== Modified: trunk/docs/manual/widgets-api.texinfo ============================================================================== --- trunk/docs/manual/widgets-api.texinfo (original) +++ trunk/docs/manual/widgets-api.texinfo Sat Aug 19 18:56:20 2006 @@ -28,7 +28,7 @@ @node widget types @subsection widget types -@strong{NOTE:} A future release will provide additional widget +@strong{Note:} A future release will provide additional widget classes. @anchor{button} @@ -90,6 +90,46 @@ @end deffn @end deftp +@anchor{color-dialog} +@deftp Class color-dialog +This class provides a standard dialog for choosing (or defining new) +@ref{color}s. The @ref{with-color-dialog} macro wraps the creation of +this dialog type and subsequent retrieval of the user's color choice. +However, applications may choose to implement these steps manually, in +which case the @ref{obtain-chosen-color} function can be used.@*@* +Like other system dialogs in Graphic-Forms, @code{color-dialog} is +derived from @ref{widget} rather than @ref{dialog} since the majority +of its functionality is implemented by the system. @strong{Note:} A +future release will provide a customization mechanism. +@deffn Initarg :initial-color +This initarg causes the dialog to show the specified color as +initially selected. +@end deffn +@deffn Initarg :initial-custom-colors +This initarg accepts a list of color objects which are used to +populate the custom color editing portion of the dialog. A +maximum of 16 colors are used, with any extras supplied in the +list being ignored. Fewer than 16 may be supplied, in which case +black is displayed as a default color for the remaining entries. +@end deffn +@deffn Initarg :owner +A value is required for this initarg, and it may be either a +@ref{window} or a dialog. +@end deffn +@deffn Initarg :style +This initarg accepts a list of keyword symbols: +@table @code +@item :allow-custom-colors +This configures the dialog to enable the Define Custom Color +button, which when clicked reveals additional controls for +creating custom colors. +@item :display-solid-only +This configures the dialog to only display solid colors in the +set of basic colors. +@end table +@end deffn +@end deftp + @anchor{control} @deftp Class control brush-color brush-handle font pixel-point maximum-size minimum-size text-color The base class for widgets having pre-defined native behavior. It derives from @@ -314,7 +354,7 @@ must be followed by an explicit call to @ref{dispose}.@*@* Like other system dialogs in Graphic-Forms, @code{file-dialog} is derived from @ref{widget} rather than @ref{dialog} since the majority -of its functionality is implemented by the system. @strong{NOTE:} A +of its functionality is implemented by the system. @strong{Note:} A future release will provide a customization mechanism.@*@* @deffn Initarg :default-extension Specifies a default extension to be appended to a file name if @@ -354,7 +394,7 @@ @ref{window} or a @ref{dialog}. @end deffn @deffn Initarg :style -This initarg accepts a list of keyword symbols, as follows: +This initarg accepts a list of keyword symbols: @table @code @item :add-to-recent This enables the system to add a link to the selected file @@ -374,7 +414,7 @@ for data to be saved. @item :show-hidden This keyword enables the dialog to display files marked @sc{hidden} by -the system. @strong{NOTE:} files marked both @sc{hidden} and +the system. @strong{Note:} files marked both @sc{hidden} and @sc{system} will not be displayed in any case. Also, be aware that using this keyword effectively overrides the user's preference settings. @@ -402,7 +442,7 @@ by an explicit call to @ref{dispose}.@*@* Like other system dialogs in Graphic-Forms, @code{font-dialog} is derived from @ref{widget} rather than @ref{dialog} since the majority of its -functionality is implemented by the system. @strong{NOTE:} A future release +functionality is implemented by the system. @strong{Note:} A future release will provide a customization mechanism.@* @deffn Initarg :gc This required initarg accepts a @ref{graphics-context} object providing @@ -424,7 +464,7 @@ @ref{window} or a @ref{dialog}. @end deffn @deffn Initarg :style -This initarg accepts a list of keyword symbols, as follows: +This initarg accepts a list of keyword symbols: @table @code @item :all-fonts This is a convenience style, used by default if no other font @@ -453,7 +493,7 @@ @anchor{group} @deftp Class group children location size style -@strong{NOTE:} this class is not yet fully implemented +@strong{Note:} this class is not yet fully implemented and does not yet participate in the layout protocol.@*@* A @code{group} represents a logical rectangular aggregation of @ref{window} children which has the following properties @@ -748,7 +788,7 @@ This slot holds a margin value in pixels for the bottom side of the container. @item data -This slot holds a @sc{alist} of pairs, each one associating a +This slot holds an @sc{alist} of pairs, each one associating a @sc{plist} of layout-specific attributes with an item from a container. @item left-margin @@ -1171,7 +1211,7 @@ @end deffn @anchor{capture-mouse} -@deffn Function capture-mouse self +@defun capture-mouse self Enables the @ref{window} identified by @code{self} to receive mouse input events even when the mouse pointer is outside of the bounds of @code{self}. Only one window at a time can capture the mouse. This @@ -1179,7 +1219,7 @@ background windows may still capture the mouse, but only mouse move events will be received and those only when the mouse hotspot is within the visible portions of such a window. @xref{release-mouse}. -@end deffn +@end defun @anchor{center-on-owner} @deffn GenericFunction center-on-owner self @@ -1319,13 +1359,13 @@ @end deffn @anchor{file-dialog-paths} -@deffn Function file-dialog-paths dlg => @sc{list} +@defun file-dialog-paths dlg => @sc{list} Interrogates the data structure associated with an instance of @ref{file-dialog} to obtain the paths for selected files. This return value is either @sc{nil} if the user cancelled the dialog, or a list of file @sc{namestring}s. Use this function when manually constructing a file dialog. @xref{with-file-dialog}. -@end deffn +@end defun @deffn GenericFunction focus-p self Returns @sc{t} if @code{self} currently has keyboard focus; @sc{nil} @@ -1333,7 +1373,7 @@ @end deffn @anchor{font-dialog-results} -@deffn Function font-dialog-results dlg gc => @ref{font}, @ref{color} +@defun font-dialog-results dlg gc => @ref{font}, @ref{color} Interrogates the data structure associated with an instance of @ref{font-dialog} to obtain the @ref{font} and @ref{color} corresponding to selections made by the user, and returns @@ -1343,7 +1383,7 @@ Also, the color value will be @sc{nil} if the dialog was created with the @code{:no-effects} style keyword. Use this function when manually constructing a font dialog. @xref{with-font-dialog}. -@end deffn +@end defun @deffn GenericFunction give-focus self Places keyboard focus on @code{self}. @@ -1420,23 +1460,28 @@ 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. -@end deffn +@anchor{obtain-chosen-color} +@defun obtain-chosen-color @ref{color-dialog} => @ref{color}, list +Interrogates the data structure associated with @var{color-dialog} +to retrieve @var{color}. The secondary value is a list of color +objects corresponding to custom colors displayed by the dialog. +If the user cancelled the dialog, @sc{nil} is returned for both +values. Use this function when manually constructing a color dialog. +@xref{with-color-dialog}. +@end defun @anchor{obtain-displays} -@deffn Function obtain-displays +@defun obtain-displays => list Returns a list of @ref{display} objects, each of which describes a monitor attached to the system. The system specifies that one of these is the primary @ref{display}. -@end deffn +@end defun @anchor{obtain-primary-display} -@deffn Function obtain-primary-display -Return a @ref{display} object that is regarded by the system as +@defun obtain-primary-display => @ref{display} +Return a display object that is regarded by the system as being the primary. -@end deffn +@end defun @anchor{owner} @deffn GenericFunction owner self @@ -1461,11 +1506,12 @@ @anchor{pack} @deffn GenericFunction pack self -Causes @code{self} to be resized to its preferred @ref{size}. +Causes @var{self} to be resized to the dimensions returned +by @ref{preferred-size}. @end deffn @anchor{parent} -@deffn GenericFunction parent self +@deffn GenericFunction parent self => @ref{window} Returns the @code{parent} of @code{self}. In the case of @ref{panel}s and @ref{control}s, this will be the ancestor dialog, @ref{panel}, or @ref{top-level} window. In the case of a dialog or @ref{top-level}, @@ -1508,10 +1554,10 @@ must determine how tall it would be given that width. @end deffn -@deffn Function primary-p display +@defun primary-p display Returns T if the system regards the specified display as the primary display; nil otherwise. -@end deffn +@end defun @deffn GenericFunction redo-available-p self => boolean Returns T if @code{self} has @sc{redo} capability and has an @@ -1523,10 +1569,10 @@ @end deffn @anchor{release-mouse} -@deffn Function release-mouse +@defun release-mouse Clears the mouse capture state to restore normal mouse input processing. @xref{capture-mouse}. -@end deffn +@end defun @anchor{resizable-p} @deffn GenericFunction resizable-p self => boolean @@ -1651,6 +1697,16 @@ @end deffn @end html +@anchor{with-color-dialog} +@defmac with-color-dialog (owner style color custom-colors &key initial-color initial-custom-colors) &body body +This macro wraps the instantiation of a standard color dialog and +the subsequent retrieval of the user's color selection (supplied to @var{body} +via @var{color}). The @var{custom-colors} argument is bound to a list containing +colors that the user has modified in the extended portion of the dialog. +@xref{color-dialog}. +@end defmac + +@anchor{with-drawing-disabled} @defmac with-drawing-disabled (widget) &body body This macro executes @var{body} while updates of @var{widget} are disabled. Drawing operations attempted while @var{body} Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Sat Aug 19 18:56:20 2006 @@ -122,6 +122,9 @@ (:file "timer") (:file "item") (:file "widget") + (:file "color-dialog") + (:file "file-dialog") + (:file "font-dialog") (:file "control") (:file "edit") (:file "label") @@ -136,8 +139,6 @@ (:file "top-level") (:file "panel") (:file "dialog") - (:file "file-dialog") - (:file "font-dialog") (:file "layout") (:file "heap-layout") (:file "flow-layout"))))))))) Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Sat Aug 19 18:56:20 2006 @@ -244,6 +244,7 @@ ;; classes and structs #:button #:caret + #:color-dialog #:control #:dialog #:display @@ -462,7 +463,7 @@ #:move-above #:move-below #:moveable-p - #:object-to-display + #:obtain-chosen-color #:obtain-displays #:obtain-event-time #:obtain-primary-display @@ -523,6 +524,7 @@ #:vertical-scrollbar #:visible-item-count #:visible-p + #:with-color-dialog #:with-drawing-disabled #:with-file-dialog #:with-font-dialog Modified: trunk/src/tests/uitoolkit/windlg.lisp ============================================================================== --- trunk/src/tests/uitoolkit/windlg.lisp (original) +++ trunk/src/tests/uitoolkit/windlg.lisp Sat Aug 19 18:56:20 2006 @@ -117,6 +117,14 @@ :initial-directory #P"c:/") (print paths))) +(defun choose-color-dlg (disp item) + (declare (ignore disp item)) + (gfw:with-color-dialog (*main-win* '(:allow-custom-colors) color custom-colors :initial-custom-colors (list gfg:*color-red* gfg:*color-blue*)) + (if color + (print color)) + (if custom-colors + (print custom-colors)))) + (defun choose-font-dlg (disp item) (declare (ignore disp item)) (gfw:with-graphics-context (gc *main-win*) @@ -235,16 +243,17 @@ (setf menubar (gfw:defmenu ((:item "&File" :submenu ((:item "E&xit" :callback #'windlg-exit-fn))) (:item "&Custom Dialogs" - :submenu ((:item "&Modal" :callback #'open-modal-dlg) - (:item "&Modeless" :callback #'open-modeless-dlg))) + :submenu ((:item "&Modal" :callback #'open-modal-dlg) + (:item "&Modeless" :callback #'open-modeless-dlg))) (:item "&System Dialogs" - :submenu ((:item "&Choose Font" :callback #'choose-font-dlg) - (:item "&Open File" :callback #'open-file-dlg) - (:item "&Save File" :callback #'save-file-dlg))) + :submenu ((:item "Choose &Color" :callback #'choose-color-dlg) + (:item "Choose &Font" :callback #'choose-font-dlg) + (:item "&Open File" :callback #'open-file-dlg) + (:item "&Save File" :callback #'save-file-dlg))) (:item "&Windows" - :submenu ((:item "&Borderless" :callback #'create-borderless-win) - (:item "&Mini Frame" :callback #'create-miniframe-win) - (:item "&Palette" :callback #'create-palette-win)))))) + :submenu ((:item "&Borderless" :callback #'create-borderless-win) + (:item "&Mini Frame" :callback #'create-miniframe-win) + (:item "&Palette" :callback #'create-palette-win)))))) (setf (gfw:menu-bar *main-win*) menubar) (setf (gfw:image *main-win*) (make-instance 'gfg:icon-bundle :file (merge-pathnames "default.ico"))) (gfw:show *main-win* t))) Modified: trunk/src/uitoolkit/system/comdlg32.lisp ============================================================================== --- trunk/src/uitoolkit/system/comdlg32.lisp (original) +++ trunk/src/uitoolkit/system/comdlg32.lisp Sat Aug 19 18:56:20 2006 @@ -39,6 +39,11 @@ (load-foreign-library "comdlg32.dll") (defcfun + ("ChooseColorA" choose-color) + BOOL + (struct LPTR)) ; choosecolor struct + +(defcfun ("ChooseFontA" choose-font) BOOL (struct LPTR)) ; choosefont struct Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Sat Aug 19 18:56:20 2006 @@ -137,10 +137,20 @@ (defconstant +cbm-init+ #x04) -(defconstant +cchdevicename+ 32) +(defconstant +cc-rgbinit+ #x00000001) +(defconstant +cc-fullopen+ #x00000002) +(defconstant +cc-preventfullopen+ #x00000004) +(defconstant +cc-showhelp+ #x00000008) +(defconstant +cc-enablehook+ #x00000010) +(defconstant +cc-enabletemplate+ #x00000020) +(defconstant +cc-enabletemplatehandle+ #x00000040) +(defconstant +cc-solidcolor+ #x00000080) +(defconstant +cc-anycolor+ #x00000100) (defconstant +ccerr-choosecolorcodes+ #x5000) +(defconstant +cchdevicename+ 32) + (defconstant +cderr-dialogfailure+ #xFFFF) (defconstant +cderr-generalcodes+ #x0000) (defconstant +cderr-structsize+ #x0001) Modified: trunk/src/uitoolkit/system/system-types.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-types.lisp (original) +++ trunk/src/uitoolkit/system/system-types.lisp Sat Aug 19 18:56:20 2006 @@ -150,6 +150,17 @@ (biclrused DWORD) (biclrimp DWORD)) +(defcstruct choosecolor + (ccsize DWORD) + (howner HANDLE) + (hinst HANDLE) + (result COLORREF) + (ccolors LPTR) + (flags DWORD) + (cdata LPARAM) + (hookfn LPTR) ; CCHookProc + (templname :string)) + (defcstruct choosefont (structsize DWORD) (howner HANDLE) @@ -159,7 +170,7 @@ (flags DWORD) (color COLORREF) (data LPARAM) - (hookfn LPTR) ; FIXME: not yet used, but eventually should be CFHookProc + (hookfn LPTR) ; CFHookProc (templname :string) (hinstance HANDLE) (style :string) @@ -184,7 +195,7 @@ (whatlen WORD) (withlen WORD) (data LPARAM) - (hookfn LPTR) ; FIXME: not yet used, but eventually should be FRHookProc + (hookfn LPTR) ; FRHookProc (templname :string)) (defcstruct iconinfo Added: trunk/src/uitoolkit/widgets/color-dialog.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/widgets/color-dialog.lisp Sat Aug 19 18:56:20 2006 @@ -0,0 +1,130 @@ +;;;; +;;;; color-dialog.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.widgets) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defconstant +custom-color-array-size+ 16)) + +;;; +;;; helper functions +;;; + +(defun obtain-chosen-color (dlg) + (let ((cc-ptr (gfs:handle dlg))) + (if (cffi:null-pointer-p cc-ptr) + (error 'gfs:disposed-error)) + (cffi:with-foreign-slots ((gfs::result gfs::ccolors) cc-ptr gfs::choosecolor) + (values (gfg:rgb->color gfs::result) + (loop for index to (1- +custom-color-array-size+) + collect (gfg:rgb->color (cffi:mem-aref gfs::ccolors 'gfs::colorref index))))))) + +(defmacro with-color-dialog ((owner style color custom-colors &key initial-color initial-custom-colors) &body body) + (let ((dlg (gensym))) + `(let ((,color nil) + (,custom-colors nil) + (,dlg (make-instance 'color-dialog + :initial-custom-colors ,initial-custom-colors + :initial-color ,initial-color + :owner ,owner + :style ,style))) + (unwind-protect + (unless (zerop (show ,dlg t)) + (multiple-value-bind (tmp-color tmp-custom) + (obtain-chosen-color ,dlg) + (setf ,color tmp-color + ,custom-colors tmp-custom) + ,@body)) + (gfs:dispose ,dlg))))) + +;;; +;;; methods +;;; + +(defmethod compute-style-flags ((self color-dialog) &rest extra-data) + (let ((std-flags (logior gfs::+cc-anycolor+ gfs::+cc-preventfullopen+ (if extra-data gfs::+cc-rgbinit+ 0)))) + (loop for sym in (style-of self) + do (ecase sym + (:allow-custom-colors + (setf std-flags (logand std-flags (lognot gfs::+cc-preventfullopen+)))) + (:display-solid-only) + (setf std-flags (logior std-flags gfs::+cc-solidcolor+)))) + (values std-flags 0))) + +(defmethod gfs:dispose ((self color-dialog)) + (let ((cc-ptr (gfs:handle self))) + (unless (cffi:null-pointer-p cc-ptr) + (cffi:with-foreign-slots ((gfs::ccolors) cc-ptr gfs::choosecolor) + (unless (cffi:null-pointer-p gfs::ccolors) + (cffi:foreign-free gfs::ccolors))) + (cffi:foreign-free cc-ptr) + (setf (slot-value self 'gfs:handle) nil)))) + +(defmethod initialize-instance :after ((self color-dialog) &key initial-color initial-custom-colors owner &allow-other-keys) + (if (null owner) + (error 'gfs:toolkit-error :detail ":owner initarg is required")) + (if (gfs:disposed-p owner) + (error 'gfs:disposed-error)) + (let ((cc-ptr (cffi:foreign-alloc 'gfs::choosecolor)) + (colors-ptr (cffi:foreign-alloc 'gfs::colorref :count +custom-color-array-size+)) + (index 0) + (default-rgb (gfg:color->rgb gfg:*color-black*))) + (loop for color in initial-custom-colors + when (< index +custom-color-array-size+) + do (progn + (setf (cffi:mem-aref colors-ptr 'gfs::colorref index) (gfg:color->rgb color)) + (incf index))) + (loop until (>= index +custom-color-array-size+) + do (progn + (setf (cffi:mem-aref colors-ptr 'gfs::colorref index) default-rgb) + (incf index))) + (multiple-value-bind (std-style ex-style) + (compute-style-flags self initial-color) + (declare (ignore ex-style)) + (cffi:with-foreign-slots ((gfs::ccsize gfs::howner gfs::hinst gfs::result + gfs::ccolors gfs::flags gfs::cdata gfs::hookfn gfs::templname) + cc-ptr gfs::choosecolor) + (setf gfs::ccsize (cffi:foreign-type-size 'gfs::choosecolor) + gfs::howner (gfs:handle owner) + gfs::hinst (cffi:null-pointer) + gfs::result (gfg:color->rgb (or initial-color (gfg:make-color))) + gfs::ccolors colors-ptr + gfs::flags std-style + gfs::cdata 0 + gfs::hookfn (cffi:null-pointer) + gfs::templname (cffi:null-pointer)))) + (setf (slot-value self 'gfs:handle) cc-ptr))) + +(defmethod show ((self color-dialog) flag) + (declare (ignore flag)) + (show-common-dialog self #'gfs::choose-color)) Modified: trunk/src/uitoolkit/widgets/file-dialog.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/file-dialog.lisp (original) +++ trunk/src/uitoolkit/widgets/file-dialog.lisp Sat Aug 19 18:56:20 2006 @@ -38,19 +38,18 @@ ;;; (defun file-dialog-paths (dlg) - (let ((paths nil) - (ofn-ptr (gfs:handle dlg))) + (let ((ofn-ptr (gfs:handle dlg))) (if (cffi:null-pointer-p ofn-ptr) (error 'gfs:disposed-error)) (cffi:with-foreign-slots ((gfs::ofnfile) ofn-ptr gfs::openfilename) - (unless (or (cffi:null-pointer-p gfs::ofnfile) (= (cffi:mem-ref gfs::ofnfile :char) 0)) + (if (or (cffi:null-pointer-p gfs::ofnfile) (= (cffi:mem-ref gfs::ofnfile :char) 0)) + nil (let* ((raw-list (extract-foreign-strings gfs::ofnfile)) (dir-str (first raw-list))) - (if (cdr raw-list) - (setf paths (loop for filename in (cdr raw-list) - collect (parse-namestring (concatenate 'string dir-str "\\" filename)))) - (setf paths (list (parse-namestring dir-str))))))) - paths)) + (if (rest raw-list) + (loop for filename in (rest raw-list) + collect (parse-namestring (concatenate 'string dir-str "\\" filename))) + (list (parse-namestring dir-str)))))))) (defmacro with-file-dialog ((owner style paths &key default-extension filters initial-directory initial-filename text) &body body) (let ((dlg (gensym))) @@ -106,7 +105,7 @@ (unless (cffi:null-pointer-p gfs::ofndefext) (cffi:foreign-free gfs::ofndefext))) (cffi:foreign-free ofn-ptr) - (setf (slot-value self 'gfs:handle) (cffi:null-pointer))))) + (setf (slot-value self 'gfs:handle) nil)))) (defmethod initialize-instance :after ((self file-dialog) &key default-extension filters initial-directory initial-filename owner style text) ;; FIXME: implement an OFNHookProc to process CDN_SELCHANGE Modified: trunk/src/uitoolkit/widgets/font-dialog.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/font-dialog.lisp (original) +++ trunk/src/uitoolkit/widgets/font-dialog.lisp Sat Aug 19 18:56:20 2006 @@ -65,12 +65,11 @@ :owner ,owner :style ,style))) (unwind-protect - (progn - (unless (zerop (show ,dlg t)) - (multiple-value-bind (f c) (font-dialog-results ,dlg ,gc) - (setf ,font f) - (setf ,color c)) - ,@body)) + (unless (zerop (show ,dlg t)) + (multiple-value-bind (f c) (font-dialog-results ,dlg ,gc) + (setf ,font f) + (setf ,color c)) + ,@body) (gfs:dispose ,dlg))))) ;;; Modified: trunk/src/uitoolkit/widgets/layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/layout.lisp (original) +++ trunk/src/uitoolkit/widgets/layout.lisp Sat Aug 19 18:56:20 2006 @@ -116,15 +116,15 @@ (setf (top-margin-of self) vertical-margins (bottom-margin-of self) vertical-margins))) -(defmethod (setf layout-of) :after ((self layout-manager) (container layout-managed)) - (let ((orig-layout (layout-of container))) +(defmethod (setf layout-of) :after ((layout layout-manager) (self layout-managed)) + (let ((orig-layout (layout-of self))) (if orig-layout - (setf (data-of self) (loop for item in (data-of orig-layout) - when (not (gfs:disposed-p (first item))) - collect item) + (setf (data-of layout) (loop for item in (data-of orig-layout) + when (not (gfs:disposed-p (first item))) + collect item) (data-of orig-layout) nil) - (if (typep container 'window) - (setf (data-of self) (mapchildren container (lambda (parent child) + (if (typep self 'window) + (setf (data-of layout) (mapchildren self (lambda (parent child) (declare (ignore parent)) (list child nil)))))))) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Sat Aug 19 18:56:20 2006 @@ -142,6 +142,9 @@ (defclass label (control) () (:documentation "This class represents non-selectable controls that display a string or image.")) +(defclass color-dialog (widget) () + (:documentation "This class represents the standard color chooser dialog.")) + (defclass file-dialog (widget) ((open-mode :reader open-mode Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Sat Aug 19 18:56:20 2006 @@ -249,9 +249,6 @@ (defgeneric moveable-p (self) (:documentation "Returns T if the object is moveable; nil otherwise.")) -(defgeneric object-to-display (self pnt) - (:documentation "Return a point that is the result of transforming the specified point from this object's coordinate system to display-relative coordinates.")) - (defgeneric owner (self) (:documentation "Returns self's owner (which is not necessarily the same as parent)."))

1 0

[graphic-forms-cvs] r221 - in trunk: . src src/tests/uitoolkit src/uitoolkit/widgets
by junrue＠common-lisp.net 18 Aug '06

18 Aug '06

Author: junrue Date: Fri Aug 18 18:30:58 2006 New Revision: 221 Added: trunk/src/tests/uitoolkit/flow-layout-unit-tests.lisp Modified: trunk/src/packages.lisp trunk/src/tests/uitoolkit/layout-unit-tests.lisp trunk/src/tests/uitoolkit/mock-objects.lisp trunk/src/tests/uitoolkit/test-utils.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/flow-layout.lisp trunk/src/uitoolkit/widgets/layout.lisp trunk/tests.lisp Log: refactored flow-layout implementation, updated associated unit-tests Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Fri Aug 18 18:30:58 2006 @@ -255,6 +255,7 @@ #:flow-layout #:heap-layout #:item + #:layout-managed #:layout-manager #:menu #:menu-item Added: trunk/src/tests/uitoolkit/flow-layout-unit-tests.lisp ============================================================================== --- (empty file) +++ trunk/src/tests/uitoolkit/flow-layout-unit-tests.lisp Fri Aug 18 18:30:58 2006 @@ -0,0 +1,266 @@ +;;;; +;;;; flow-layout-unit-tests.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 *large-size* (gfs:make-size :width 25 :height 5)) +(defvar *small-size* (gfs:make-size :width 20 :height 10)) + +(defvar *flow-uniform-kids* (list (make-instance 'mock-widget :min-size *small-size*) + (make-instance 'mock-widget :min-size *small-size*) + (make-instance 'mock-widget :min-size *small-size*))) +(defvar *flow-mixed-kids* (list (make-instance 'mock-widget :min-size *small-size*) + (make-instance 'mock-widget :min-size *large-size*) + (make-instance 'mock-widget :min-size *small-size*))) + +(defvar *flow-container* (make-instance 'mock-container)) + +(define-test flow-layout-test1 + ;; orient: horizontal + ;; normalize: disabled + ;; wrap: disabled + ;; spacing: 0 + ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 + ;; container: unrestricted width and height + ;; kids: uniform + ;; + (let* ((layout (make-flow-layout *flow-uniform-kids* '(:horizontal))) + (size (gfw::compute-size layout *flow-container* -1 -1)) + (data (gfw::compute-layout layout *flow-container* -1 -1)) + (expected-rects '((0 0 20 10) (20 0 20 10) (40 0 20 10)))) + (assert-equal 60 (gfs:size-width size)) + (assert-equal 10 (gfs:size-height size)) + (validate-rects data expected-rects))) + +(define-test flow-layout-test2 + ;; orient: vertical + ;; normalize: disabled + ;; wrap: disabled + ;; spacing: 0 + ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 + ;; container: unrestricted width and height + ;; kids: uniform + ;; + (let* ((layout (make-flow-layout *flow-uniform-kids* '(:vertical))) + (size (gfw::compute-size layout *flow-container* -1 -1)) + (data (gfw::compute-layout layout *flow-container* -1 -1)) + (expected-rects '((0 0 20 10) (0 10 20 10) (0 20 20 10)))) + (assert-equal 20 (gfs:size-width size)) + (assert-equal 30 (gfs:size-height size)) + (validate-rects data expected-rects))) + +(define-test flow-layout-test3 + ;; orient: horizontal + ;; normalize: disabled + ;; wrap: enabled + ;; spacing: 0 + ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 + ;; container: restricted width, unrestricted height + ;; kids: uniform + ;; + (let* ((layout (make-flow-layout *flow-uniform-kids* '(:horizontal :wrap))) + (data (gfw::compute-layout layout *flow-container* 45 -1)) + (expected-rects '((0 0 20 10) (20 0 20 10) (0 10 20 10)))) + (validate-rects data expected-rects))) + +(define-test flow-layout-test4 + ;; orient: vertical + ;; normalize: disabled + ;; wrap: enabled + ;; spacing: 0 + ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 + ;; container: unrestricted width, restricted height + ;; kids: uniform + ;; + (let* ((layout (make-flow-layout *flow-uniform-kids* '(:vertical :wrap))) + (data (gfw::compute-layout layout *flow-container* -1 25)) + (expected-rects '((0 0 20 10) (0 10 20 10) (20 0 20 10)))) + (validate-rects data expected-rects))) + +(define-test flow-layout-test5 + ;; orient: horizontal + ;; normalize: disabled + ;; wrap: enabled + ;; spacing: 0 + ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 + ;; container: restricted width and height + ;; kids: uniform + ;; + (let* ((layout (make-flow-layout *flow-uniform-kids* '(:horizontal :wrap))) + (data (gfw::compute-layout layout *flow-container* 45 18)) + (expected-rects '((0 0 20 10) (20 0 20 10) (0 10 20 10)))) + (validate-rects data expected-rects))) + +(define-test flow-layout-test6 + ;; orient: vertical + ;; normalize: disabled + ;; wrap: enabled + ;; spacing: 0 + ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 + ;; container: restricted width and height + ;; kids: uniform + ;; + (let* ((layout (make-flow-layout *flow-uniform-kids* '(:vertical :wrap))) + (data (gfw::compute-layout layout *flow-container* 30 25)) + (expected-rects '((0 0 20 10) (0 10 20 10) (20 0 20 10)))) + (validate-rects data expected-rects))) + +(define-test flow-layout-test7 + ;; orient: horizontal + ;; normalize: disabled + ;; wrap: disabled + ;; spacing: 4 + ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 + ;; container: unrestricted width and height + ;; kids: uniform + ;; + (let* ((layout (make-flow-layout *flow-uniform-kids* '(:horizontal) 4)) + (size (gfw::compute-size layout *flow-container* -1 -1)) + (data (gfw::compute-layout layout *flow-container* -1 -1)) + (expected-rects '((0 0 20 10) (24 0 20 10) (48 0 20 10)))) + (assert-equal 68 (gfs:size-width size)) + (assert-equal 10 (gfs:size-height size)) + (validate-rects data expected-rects))) + +(define-test flow-layout-test8 + ;; orient: vertical + ;; normalize: disabled + ;; wrap: disabled + ;; spacing: 4 + ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 + ;; container: unrestricted width and height + ;; kids: uniform + ;; + (let* ((layout (make-flow-layout *flow-uniform-kids* '(:vertical) 4)) + (size (gfw::compute-size layout *flow-container* -1 -1)) + (data (gfw::compute-layout layout *flow-container* -1 -1)) + (expected-rects '((0 0 20 10) (0 14 20 10) (0 28 20 10)))) + (assert-equal 20 (gfs:size-width size)) + (assert-equal 38 (gfs:size-height size)) + (validate-rects data expected-rects))) + +(define-test flow-layout-test9 + ;; orient: horizontal + ;; normalize: disabled + ;; wrap: enabled + ;; spacing: 4 + ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 + ;; container: restricted width and height + ;; kids: uniform + ;; + (let* ((layout (make-flow-layout *flow-uniform-kids* '(:horizontal :wrap) 4)) + (data (gfw::compute-layout layout *flow-container* 45 18)) + (expected-rects '((0 0 20 10) (24 0 20 10) (0 14 20 10)))) + (validate-rects data expected-rects))) + +(define-test flow-layout-test10 + ;; orient: vertical + ;; normalize: disabled + ;; wrap: enabled + ;; spacing: 4 + ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 + ;; container: restricted width and height + ;; kids: uniform + ;; + (let* ((layout (make-flow-layout *flow-uniform-kids* '(:vertical :wrap) 4)) + (data (gfw::compute-layout layout *flow-container* 30 25)) + (expected-rects '((0 0 20 10) (0 14 20 10) (24 0 20 10)))) + (validate-rects data expected-rects))) + +(define-test flow-layout-test11 + ;; orient: horizontal + ;; normalize: disabled + ;; wrap: disabled + ;; spacing: 0 + ;; left-margin: 3, top-margin: 3, right-margin: 0, bottom-margin: 0 + ;; container: unrestricted width and height + ;; kids: uniform + ;; + (let* ((layout (make-flow-layout *flow-uniform-kids* '(:horizontal) 0 3 3)) + (size (gfw::compute-size layout *flow-container* -1 -1)) + (data (gfw::compute-layout layout *flow-container* -1 -1)) + (expected-rects '((3 3 20 10) (23 3 20 10) (43 3 20 10)))) + (assert-equal 63 (gfs:size-width size)) + (assert-equal 13 (gfs:size-height size)) + (validate-rects data expected-rects))) + +(define-test flow-layout-test12 + ;; orient: vertical + ;; normalize: disabled + ;; wrap: disabled + ;; spacing: 0 + ;; left-margin: 0, top-margin: 0, right-margin: 3, bottom-margin: 3 + ;; container: unrestricted width and height + ;; kids: uniform + ;; + (let* ((layout (make-flow-layout *flow-uniform-kids* '(:vertical) 0 0 0 3 3)) + (size (gfw::compute-size layout *flow-container* -1 -1)) + (data (gfw::compute-layout layout *flow-container* -1 -1)) + (expected-rects '((0 0 20 10) (0 10 20 10) (0 20 20 10)))) + (assert-equal 23 (gfs:size-width size)) + (assert-equal 33 (gfs:size-height size)) + (validate-rects data expected-rects))) + +(define-test flow-layout-test13 + ;; orient: horizontal + ;; normalize: enabled + ;; wrap: disabled + ;; spacing: 0 + ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 + ;; container: unrestricted width and height + ;; kids: mixed + ;; + (let* ((layout (make-flow-layout *flow-mixed-kids* '(:horizontal :normalize))) + (size (gfw::compute-size layout *flow-container* -1 -1)) + (data (gfw::compute-layout layout *flow-container* -1 -1)) + (expected-rects '((0 0 25 10) (25 0 25 10) (50 0 25 10)))) + (assert-equal 75 (gfs:size-width size)) + (assert-equal 10 (gfs:size-height size)) + (validate-rects data expected-rects))) + +(define-test flow-layout-test14 + ;; orient: vertical + ;; normalize: enabled + ;; wrap: disabled + ;; spacing: 0 + ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 + ;; container: unrestricted width and height + ;; kids: mixed + ;; + (let* ((layout (make-flow-layout *flow-mixed-kids* '(:vertical :normalize))) + (size (gfw::compute-size layout *flow-container* -1 -1)) + (data (gfw::compute-layout layout *flow-container* -1 -1)) + (expected-rects '((0 0 25 10) (0 10 25 10) (0 20 25 10)))) + (assert-equal 25 (gfs:size-width size)) + (assert-equal 30 (gfs:size-height size)) + (validate-rects data expected-rects))) Modified: trunk/src/tests/uitoolkit/layout-unit-tests.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-unit-tests.lisp (original) +++ trunk/src/tests/uitoolkit/layout-unit-tests.lisp Fri Aug 18 18:30:58 2006 @@ -33,27 +33,6 @@ (in-package :graphic-forms.uitoolkit.tests) -(defvar *large-size* (gfs:make-size :width 25 :height 5)) -(defvar *small-size* (gfs:make-size :width 20 :height 10)) -(defvar *flow-layout-uniform-kids* (list (make-instance 'mock-widget :min-size *small-size*) - (make-instance 'mock-widget :min-size *small-size*) - (make-instance 'mock-widget :min-size *small-size*))) -(defvar *flow-layout-mixed-kids* (list (make-instance 'mock-widget :min-size *small-size*) - (make-instance 'mock-widget :min-size *large-size*) - (make-instance 'mock-widget :min-size *small-size*))) - -(defun validate-layout-rects (entries expected-rects) - (let ((actual-rects (loop for entry in entries collect (cdr entry)))) - (mapc #'(lambda (expected actual) - (let ((pnt-a (gfs:location actual)) - (sz-a (gfs:size actual))) - (assert-equal (first expected) (gfs:point-x pnt-a)) - (assert-equal (second expected) (gfs:point-y pnt-a)) - (assert-equal (third expected) (gfs:size-width sz-a)) - (assert-equal (fourth expected) (gfs:size-height sz-a)))) - expected-rects - actual-rects))) - (define-test layout-attributes-test (let ((widget1 (make-instance 'mock-widget :handle 1234)) (widget2 (make-instance 'mock-widget :handle 5678))) @@ -72,229 +51,3 @@ (assert-equal 10 (gfw:layout-attribute layout widget2 'a)) (assert-equal 30 (gfw:layout-attribute layout widget2 'c)) (assert-equal 100 (gfw:layout-attribute layout widget2 'd))))) - -(define-test flow-layout-test1 - ;; orient: horizontal - ;; normalize: disabled - ;; wrap: disabled - ;; spacing: 0 - ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 - ;; container: unrestricted width and height - ;; kids: uniform - ;; - (let* ((layout (make-instance 'gfw:flow-layout :style '(:horizontal))) - (size (gfw::flow-container-size layout t *flow-layout-uniform-kids* -1 -1)) - (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* -1 -1)) - (expected-rects '((0 0 20 10) (20 0 20 10) (40 0 20 10)))) - (assert-equal 60 (gfs:size-width size)) - (assert-equal 10 (gfs:size-height size)) - (validate-layout-rects data expected-rects))) - -(define-test flow-layout-test2 - ;; orient: vertical - ;; normalize: disabled - ;; wrap: disabled - ;; spacing: 0 - ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 - ;; container: unrestricted width and height - ;; kids: uniform - ;; - (let* ((layout (make-instance 'gfw:flow-layout :style '(:vertical))) - (size (gfw::flow-container-size layout t *flow-layout-uniform-kids* -1 -1)) - (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* -1 -1)) - (expected-rects '((0 0 20 10) (0 10 20 10) (0 20 20 10)))) - (assert-equal 20 (gfs:size-width size)) - (assert-equal 30 (gfs:size-height size)) - (validate-layout-rects data expected-rects))) - -(define-test flow-layout-test3 - ;; orient: horizontal - ;; normalize: disabled - ;; wrap: enabled - ;; spacing: 0 - ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 - ;; container: restricted width, unrestricted height - ;; kids: uniform - ;; - (let* ((layout (make-instance 'gfw:flow-layout :style '(:horizontal :wrap))) - (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* 45 -1)) - (expected-rects '((0 0 20 10) (20 0 20 10) (0 10 20 10)))) - (validate-layout-rects data expected-rects))) - -(define-test flow-layout-test4 - ;; orient: vertical - ;; normalize: disabled - ;; wrap: enabled - ;; spacing: 0 - ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 - ;; container: unrestricted width, restricted height - ;; kids: uniform - ;; - (let* ((layout (make-instance 'gfw:flow-layout :style '(:vertical :wrap))) - (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* -1 25)) - (expected-rects '((0 0 20 10) (0 10 20 10) (20 0 20 10)))) - (validate-layout-rects data expected-rects))) - -(define-test flow-layout-test5 - ;; orient: horizontal - ;; normalize: disabled - ;; wrap: enabled - ;; spacing: 0 - ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 - ;; container: restricted width and height - ;; kids: uniform - ;; - (let* ((layout (make-instance 'gfw:flow-layout :style '(:horizontal :wrap))) - (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* 45 18)) - (expected-rects '((0 0 20 10) (20 0 20 10) (0 10 20 10)))) - (validate-layout-rects data expected-rects))) - -(define-test flow-layout-test6 - ;; orient: vertical - ;; normalize: disabled - ;; wrap: enabled - ;; spacing: 0 - ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 - ;; container: restricted width and height - ;; kids: uniform - ;; - (let* ((layout (make-instance 'gfw:flow-layout :style '(:vertical :wrap))) - (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* 30 25)) - (expected-rects '((0 0 20 10) (0 10 20 10) (20 0 20 10)))) - (validate-layout-rects data expected-rects))) - -(define-test flow-layout-test7 - ;; orient: horizontal - ;; normalize: disabled - ;; wrap: disabled - ;; spacing: 4 - ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 - ;; container: unrestricted width and height - ;; kids: uniform - ;; - (let* ((layout (make-instance 'gfw:flow-layout :spacing 4 :style '(:horizontal))) - (size (gfw::flow-container-size layout t *flow-layout-uniform-kids* -1 -1)) - (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* -1 -1)) - (expected-rects '((0 0 20 10) (24 0 20 10) (48 0 20 10)))) - (assert-equal 68 (gfs:size-width size)) - (assert-equal 10 (gfs:size-height size)) - (validate-layout-rects data expected-rects))) - -(define-test flow-layout-test8 - ;; orient: vertical - ;; normalize: disabled - ;; wrap: disabled - ;; spacing: 4 - ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 - ;; container: unrestricted width and height - ;; kids: uniform - ;; - (let* ((layout (make-instance 'gfw:flow-layout :spacing 4 :style '(:vertical))) - (size (gfw::flow-container-size layout t *flow-layout-uniform-kids* -1 -1)) - (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* -1 -1)) - (expected-rects '((0 0 20 10) (0 14 20 10) (0 28 20 10)))) - (assert-equal 20 (gfs:size-width size)) - (assert-equal 38 (gfs:size-height size)) - (validate-layout-rects data expected-rects))) - -(define-test flow-layout-test9 - ;; orient: horizontal - ;; normalize: disabled - ;; wrap: enabled - ;; spacing: 4 - ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 - ;; container: restricted width and height - ;; kids: uniform - ;; - (let* ((layout (make-instance 'gfw:flow-layout :spacing 4 :style '(:horizontal :wrap))) - (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* 45 18)) - (expected-rects '((0 0 20 10) (24 0 20 10) (0 14 20 10)))) - (validate-layout-rects data expected-rects))) - -(define-test flow-layout-test10 - ;; orient: vertical - ;; normalize: disabled - ;; wrap: enabled - ;; spacing: 4 - ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 - ;; container: restricted width and height - ;; kids: uniform - ;; - (let* ((layout (make-instance 'gfw:flow-layout :spacing 4 :style '(:vertical :wrap))) - (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* 30 25)) - (expected-rects '((0 0 20 10) (0 14 20 10) (24 0 20 10)))) - (validate-layout-rects data expected-rects))) - -(define-test flow-layout-test11 - ;; orient: horizontal - ;; normalize: disabled - ;; wrap: disabled - ;; spacing: 0 - ;; left-margin: 3, top-margin: 3, right-margin: 0, bottom-margin: 0 - ;; container: unrestricted width and height - ;; kids: uniform - ;; - (let* ((layout (make-instance 'gfw:flow-layout - :style '(:horizontal) - :left-margin 3 - :top-margin 3)) - (size (gfw::flow-container-size layout t *flow-layout-uniform-kids* -1 -1)) - (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* -1 -1)) - (expected-rects '((3 3 20 10) (23 3 20 10) (43 3 20 10)))) - (assert-equal 63 (gfs:size-width size)) - (assert-equal 13 (gfs:size-height size)) - (validate-layout-rects data expected-rects))) - -(define-test flow-layout-test12 - ;; orient: vertical - ;; normalize: disabled - ;; wrap: disabled - ;; spacing: 0 - ;; left-margin: 0, top-margin: 0, right-margin: 3, bottom-margin: 3 - ;; container: unrestricted width and height - ;; kids: uniform - ;; - (let* ((layout (make-instance 'gfw:flow-layout - :style '(:vertical) - :right-margin 3 - :bottom-margin 3)) - (size (gfw::flow-container-size layout t *flow-layout-uniform-kids* -1 -1)) - (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* -1 -1)) - (expected-rects '((0 0 20 10) (0 10 20 10) (0 20 20 10)))) - (assert-equal 23 (gfs:size-width size)) - (assert-equal 33 (gfs:size-height size)) - (validate-layout-rects data expected-rects))) - -(define-test flow-layout-test13 - ;; orient: horizontal - ;; normalize: enabled - ;; wrap: disabled - ;; spacing: 0 - ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 - ;; container: unrestricted width and height - ;; kids: mixed - ;; - (let* ((layout (make-instance 'gfw:flow-layout :style '(:horizontal :normalize))) - (size (gfw::flow-container-size layout t *flow-layout-mixed-kids* -1 -1)) - (data (gfw::flow-container-layout layout t *flow-layout-mixed-kids* -1 -1)) - (expected-rects '((0 0 25 10) (25 0 25 10) (50 0 25 10)))) - (assert-equal 75 (gfs:size-width size)) - (assert-equal 10 (gfs:size-height size)) - (validate-layout-rects data expected-rects))) - -(define-test flow-layout-test14 - ;; orient: vertical - ;; normalize: enabled - ;; wrap: disabled - ;; spacing: 0 - ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 - ;; container: unrestricted width and height - ;; kids: mixed - ;; - (let* ((layout (make-instance 'gfw:flow-layout :style '(:vertical :normalize))) - (size (gfw::flow-container-size layout t *flow-layout-mixed-kids* -1 -1)) - (data (gfw::flow-container-layout layout t *flow-layout-mixed-kids* -1 -1)) - (expected-rects '((0 0 25 10) (0 10 25 10) (0 20 25 10)))) - (assert-equal 25 (gfs:size-width size)) - (assert-equal 30 (gfs:size-height size)) - (validate-layout-rects data expected-rects))) Modified: trunk/src/tests/uitoolkit/mock-objects.lisp ============================================================================== --- trunk/src/tests/uitoolkit/mock-objects.lisp (original) +++ trunk/src/tests/uitoolkit/mock-objects.lisp Fri Aug 18 18:30:58 2006 @@ -33,10 +33,33 @@ (in-package :graphic-forms.uitoolkit.tests) -(defconstant +max-widget-size+ 5000) +(defconstant +max-widget-size+ 5000) +(defconstant +default-container-width+ 300) +(defconstant +default-container-height+ 200) ;;; -;;; stand-ins for widgets that would be children of windows, to be organized +;;; stand-in for a window, used as parent of mock-widget +;;; + +(defclass mock-container (gfw:layout-managed) + ((location + :accessor location-of + :initarg :location + :initform (gfs:make-point)) + (size + :accessor size-of + :initarg :size + :initform (gfs:make-size :width +default-container-width+ :height +default-container-height+)) + (visibility + :accessor visibility-of + :initarg :visibility + :initform t))) + +(defmethod gfw:visible-p ((self mock-container)) + (visibility-of self)) + +;;; +;;; stand-in for widgets that would be children of windows, to be organized ;;; via layout managers ;;; Modified: trunk/src/tests/uitoolkit/test-utils.lisp ============================================================================== --- trunk/src/tests/uitoolkit/test-utils.lisp (original) +++ trunk/src/tests/uitoolkit/test-utils.lisp Fri Aug 18 18:30:58 2006 @@ -33,9 +33,32 @@ (in-package :graphic-forms.uitoolkit.tests) +(defun make-flow-layout (kids style &optional spacing left-margin top-margin right-margin bottom-margin) + (let ((layout (make-instance 'gfw:flow-layout + :style style + :spacing (or spacing 0) + :left-margin (or left-margin 0) + :top-margin (or top-margin 0) + :right-margin (or right-margin 0) + :bottom-margin (or bottom-margin 0)))) + (loop for kid in kids do (gfw::append-layout-item layout kid)) + layout)) + (defun validate-image (image expected-size expected-depth) (declare (ignore expected-depth)) (assert-false (null image)) (assert-false (gfs:disposed-p image)) ;; (assert-equal expected-depth (gfg:depth image)) ; FIXME: image->data needed (assert-equality #'gfs:equal-size-p expected-size (gfg:size image))) + +(defun validate-rects (entries expected-rects) + (let ((actual-rects (loop for entry in entries collect (cdr entry)))) + (mapc #'(lambda (expected actual) + (let ((pnt-a (gfs:location actual)) + (sz-a (gfs:size actual))) + (assert-equal (first expected) (gfs:point-x pnt-a)) + (assert-equal (second expected) (gfs:point-y pnt-a)) + (assert-equal (third expected) (gfs:size-width sz-a)) + (assert-equal (fourth expected) (gfs:size-height sz-a)))) + expected-rects + actual-rects))) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Fri Aug 18 18:30:58 2006 @@ -34,7 +34,6 @@ (in-package :graphic-forms.uitoolkit.widgets) (eval-when (:compile-toplevel :load-toplevel :execute) - (defconstant +wm-gf-init-msg+ #xABCD) (defconstant +key-event-peek-flags+ (logior gfs::+pm-noremove+ gfs::+pm-noyield+ gfs::+pm-qs-input+ @@ -222,18 +221,8 @@ (defmethod process-message (hwnd (msg (eql gfs::+wm-create+)) wparam lparam) (let ((widget (get-widget (thread-context) hwnd))) ; has side-effect of setting handle slot (if (typep widget 'dialog) - (let ((tmp (gfs::def-dlg-proc hwnd msg wparam lparam))) - (gfs::post-message hwnd +wm-gf-init-msg+ 0 0) ; 2nd stage init with fully-baked widget - (return-from process-message tmp)) - (gfs::post-message hwnd +wm-gf-init-msg+ 0 0))) ; 2nd stage init with fully-baked widget - 0) - -(defmethod process-message (hwnd (msg (eql +wm-gf-init-msg+)) wparam lparam) - (declare (ignore wparam lparam)) - (let ((widget (get-widget (thread-context) hwnd))) - (unless widget - (return-from process-message 0))) - 0) + (gfs::def-dlg-proc hwnd msg wparam lparam) + 0))) (defmethod process-message (hwnd (msg (eql gfs::+wm-destroy+)) wparam lparam) (declare (ignore wparam lparam)) Modified: trunk/src/uitoolkit/widgets/flow-layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/flow-layout.lisp (original) +++ trunk/src/uitoolkit/widgets/flow-layout.lisp Fri Aug 18 18:30:58 2006 @@ -53,7 +53,7 @@ (start-margin-fn nil) (current nil)) -(defun init-flow-data (layout visible kids width-hint height-hint) +(defun init-flow-data (layout visible items width-hint height-hint) (let ((state (if (find :vertical (style-of layout)) (make-flow-data :hint height-hint :next-coord (top-margin-of layout) @@ -71,7 +71,8 @@ :extent-fn #'gfs:size-height :limit-margin-fn #'right-margin-of :start-margin-fn #'left-margin-of)))) - (loop for kid in kids + (loop for item in items + for kid = (first item) when (or (visible-p kid) (not visible)) do (let* ((size (preferred-size kid -1 -1)) (dist (funcall (flow-data-distance-fn state) size)) @@ -86,37 +87,6 @@ (setf (flow-data-kid-sizes state) (reverse (flow-data-kid-sizes state))) state)) -(defun flow-container-size (layout visible kids width-hint height-hint) - (let ((kid-count (length kids)) - (horz-margin-total (+ (left-margin-of layout) (right-margin-of layout))) - (vert-margin-total (+ (top-margin-of layout) (bottom-margin-of layout))) - (vertical (find :vertical (style-of layout))) - (horizontal (find :horizontal (style-of layout)))) - (let ((spacing-total (* (spacing-of layout) (1- kid-count))) - (state (init-flow-data layout - visible - kids - (if vertical width-hint -1) - (if vertical -1 height-hint)))) - (if (find :normalize (style-of layout)) - (setf (flow-data-distance-total state) (* (flow-data-max-distance state) kid-count))) - (cond - (horizontal - (gfs:make-size :width (+ (flow-data-distance-total state) - horz-margin-total - spacing-total) - :height (+ (flow-data-max-extent state) - vert-margin-total))) - (vertical - (gfs:make-size :width (+ (flow-data-max-extent state) - horz-margin-total) - :height (+ (flow-data-distance-total state) - vert-margin-total - spacing-total))) - (t - (error 'gfs:toolkit-error - :detail (format nil "unrecognized flow layout style: ~a" (style-of layout)))))))) - (defun wrap-needed-p (state layout kid-size) (and (>= (flow-data-hint state) 0) (> (+ (flow-data-next-coord state) @@ -143,12 +113,49 @@ (flow-data-spacing state))) (cons kid (gfs:make-rectangle :size kid-size :location pnt)))) -(defun flow-container-layout (layout visible kids width-hint height-hint) +;;; +;;; methods +;;; + +(defmethod compute-size ((self flow-layout) (container layout-managed) width-hint height-hint) + (cleanup-disposed-items self) + (let ((kid-count (length (data-of self))) + (horz-margin-total (+ (left-margin-of self) (right-margin-of self))) + (vert-margin-total (+ (top-margin-of self) (bottom-margin-of self))) + (vertical (find :vertical (style-of self))) + (horizontal (find :horizontal (style-of self)))) + (let ((spacing-total (* (spacing-of self) (1- kid-count))) + (state (init-flow-data self + (visible-p container) + (data-of self) + (if vertical width-hint -1) + (if vertical -1 height-hint)))) + (if (find :normalize (style-of self)) + (setf (flow-data-distance-total state) (* (flow-data-max-distance state) kid-count))) + (cond + (horizontal + (gfs:make-size :width (+ (flow-data-distance-total state) + horz-margin-total + spacing-total) + :height (+ (flow-data-max-extent state) + vert-margin-total))) + (vertical + (gfs:make-size :width (+ (flow-data-max-extent state) + horz-margin-total) + :height (+ (flow-data-distance-total state) + vert-margin-total + spacing-total))) + (t + (error 'gfs:toolkit-error + :detail (format nil "unrecognized flow layout style: ~a" (style-of self)))))))) + +(defmethod compute-layout ((self flow-layout) (container layout-managed) width-hint height-hint) + (cleanup-disposed-items self) (let ((flows nil) - (normal (find :normalize (style-of layout))) - (vertical (find :vertical (style-of layout))) - (state (init-flow-data layout visible kids width-hint height-hint))) - (loop with wrap = (find :wrap (style-of layout)) + (normal (find :normalize (style-of self))) + (vertical (find :vertical (style-of self))) + (state (init-flow-data self (visible-p container) (data-of self) width-hint height-hint))) + (loop with wrap = (find :wrap (style-of self)) for (kid kid-size) in (flow-data-kid-sizes state) do (cond ((and normal vertical) @@ -159,26 +166,13 @@ (gfs:size-height kid-size) (flow-data-max-extent state)))) (if (and wrap (flow-data-current state) - (wrap-needed-p state layout kid-size)) - (setf flows (append flows (wrap-flow state layout)))) - (push (new-flow-element state layout kid kid-size) (flow-data-current state))) + (wrap-needed-p state self kid-size)) + (setf flows (append flows (wrap-flow state self)))) + (push (new-flow-element state self kid kid-size) (flow-data-current state))) (if (flow-data-current state) - (setf flows (append flows (wrap-flow state layout)))) + (setf flows (append flows (wrap-flow state self)))) flows)) -;;; -;;; methods -;;; - -(defmethod compute-size ((self flow-layout) (container layout-managed) width-hint height-hint) - (cleanup-disposed-items self) - (let ((kids (loop for item in (data-of self) collect (first item)))) - (flow-container-size self (visible-p container) kids width-hint height-hint))) - -(defmethod compute-layout ((self flow-layout) (container layout-managed) width-hint height-hint) - (cleanup-disposed-items self) - (let ((kids (loop for item in (data-of self) collect (first item)))) - (flow-container-layout self (visible-p container) kids width-hint height-hint))) (defmethod initialize-instance :after ((self flow-layout) &key) (unless (intersection (style-of self) '(:horizontal :vertical)) Modified: trunk/src/uitoolkit/widgets/layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/layout.lisp (original) +++ trunk/src/uitoolkit/widgets/layout.lisp Fri Aug 18 18:30:58 2006 @@ -60,7 +60,7 @@ (defsetf layout-attribute set-layout-attribute) (defun append-layout-item (layout thing) - "Adds thing to layout unless it is already registered." + "Adds thing to layout. Duplicate entries are not prevented." (setf (data-of layout) (nconc (data-of layout) (list (list thing nil))))) (defun delete-layout-item (layout thing) Modified: trunk/tests.lisp ============================================================================== --- trunk/tests.lisp (original) +++ trunk/tests.lisp Fri Aug 18 18:30:58 2006 @@ -43,5 +43,6 @@ (load (concatenate 'string *gf-tests-dir* "image-unit-tests")) (load (concatenate 'string *gf-tests-dir* "icon-bundle-unit-tests")) (load (concatenate 'string *gf-tests-dir* "layout-unit-tests")) + (load (concatenate 'string *gf-tests-dir* "flow-layout-unit-tests")) (load (concatenate 'string *gf-tests-dir* "widget-unit-tests")) (load (concatenate 'string *gf-tests-dir* "misc-unit-tests")))

1 0

[graphic-forms-cvs] r220 - in trunk: docs/manual src/tests/uitoolkit src/uitoolkit/system src/uitoolkit/widgets
by junrue＠common-lisp.net 18 Aug '06

18 Aug '06

Author: junrue Date: Fri Aug 18 13:18:48 2006 New Revision: 220 Modified: trunk/docs/manual/widgets-api.texinfo trunk/src/tests/uitoolkit/layout-unit-tests.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/widgets/control.lisp trunk/src/uitoolkit/widgets/dialog.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/flow-layout.lisp trunk/src/uitoolkit/widgets/heap-layout.lisp trunk/src/uitoolkit/widgets/layout.lisp trunk/src/uitoolkit/widgets/thread-context.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/widget.lisp trunk/src/uitoolkit/widgets/window.lisp Log: implemented layout item registration, no longer directly using mapchildren to layout children Modified: trunk/docs/manual/widgets-api.texinfo ============================================================================== --- trunk/docs/manual/widgets-api.texinfo (original) +++ trunk/docs/manual/widgets-api.texinfo Fri Aug 18 13:18:48 2006 @@ -539,8 +539,10 @@ Instances of this class employ a @ref{layout-manager} to maintain the positions and sizes of their children. @deffn Accessor layout-of -Accepts or returns the @ref{layout-manager} associated with this -container. +Accepts or returns the layout-manager associated with this +container. Note that children currently registered with the previous +layout-manager are copied to the new one, but existing layout +attributes that were set for each child are not copied. @end deffn @deffn Initarg :layout Accepts a @ref{layout-manager} object whose responsibility is to manage @@ -1701,11 +1703,10 @@ @anchor{compute-layout} @deffn GenericFunction compute-layout @ref{layout-manager} container width-hint height-hint -Returns a list of pairs @code{(item rectangle)} describing the +Returns a list of conses @code{(child . rectangle)} describing the new bounds of each child within @var{container}. A layout-manager subclass implements this method based on its particular layout strategy, taking -into account attributes set by the user via @ref{layout-attribute}. Certain -Graphic-Forms functions call this method to accomplish layout within a container. +into account attributes set by the user via @ref{layout-attribute}. @table @var @item layout-manager The layout object dictating how children of @var{container} Modified: trunk/src/tests/uitoolkit/layout-unit-tests.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-unit-tests.lisp (original) +++ trunk/src/tests/uitoolkit/layout-unit-tests.lisp Fri Aug 18 13:18:48 2006 @@ -57,8 +57,8 @@ (define-test layout-attributes-test (let ((widget1 (make-instance 'mock-widget :handle 1234)) (widget2 (make-instance 'mock-widget :handle 5678))) - (let ((data1 `(,(cffi:make-pointer 1234) (a 1 b 2))) - (data2 `(,(cffi:make-pointer 5678) (a 10 c 30))) + (let ((data1 `(,widget1 (a 1 b 2))) + (data2 `(,widget2 (a 10 c 30))) (layout (make-instance 'gfw:layout-manager))) (setf (slot-value layout 'gfw::data) (list data1 data2)) (assert-equal 1 (gfw:layout-attribute layout widget1 'a)) Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Fri Aug 18 13:18:48 2006 @@ -1014,6 +1014,14 @@ (defconstant +wm-displaychange+ #x007E) (defconstant +wm-geticon+ #x007F) (defconstant +wm-seticon+ #x0080) +(defconstant +wm-nccreate+ #x0081) +(defconstant +wm-ncdestroy+ #x0082) +(defconstant +wm-nccalcsize+ #x0083) +(defconstant +wm-nchittest+ #x0084) +(defconstant +wm-ncpaint+ #x0085) +(defconstant +wm-ncactivate+ #x0086) +(defconstant +wm-getdlgcode+ #x0087) +(defconstant +wm-syncpaint+ #x0088) (defconstant +wm-ncmousemove+ #x00A0) (defconstant +wm-nclbuttondown+ #x00A1) (defconstant +wm-nclbuttonup+ #x00A2) Modified: trunk/src/uitoolkit/widgets/control.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/control.lisp (original) +++ trunk/src/uitoolkit/widgets/control.lisp Fri Aug 18 13:18:48 2006 @@ -43,7 +43,13 @@ (put-widget (thread-context) ctrl) (let ((hfont (gfs::get-stock-object gfs::+default-gui-font+))) (unless (gfs:null-handle-p hfont) - (gfs::send-message hwnd gfs::+wm-setfont+ (cffi:pointer-address hfont) 0))))) + (gfs::send-message hwnd gfs::+wm-setfont+ (cffi:pointer-address hfont) 0))) + ;; FIXME: this is a temporary hack to allow layout management testing; + ;; it breaks in the presence of virtual containers like group + ;; + (let ((parent (parent ctrl))) + (when (and parent (layout-of parent)) + (append-layout-item (layout-of parent) ctrl))))) ;;; ;;; methods Modified: trunk/src/uitoolkit/widgets/dialog.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/dialog.lisp (original) +++ trunk/src/uitoolkit/widgets/dialog.lisp Fri Aug 18 13:18:48 2006 @@ -169,7 +169,7 @@ (error 'gfs:disposed-error))) (if (null text) (setf text *default-dialog-title*)) - ;; NOTE: do not allow apps to specify the desktop window as the + ;; Don't allow apps to specify the desktop window as the ;; owner of the dialog; it would cause the desktop to become ;; disabled. ;; Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Fri Aug 18 13:18:48 2006 @@ -33,10 +33,12 @@ (in-package :graphic-forms.uitoolkit.widgets) -(defconstant +key-event-peek-flags+ (logior gfs::+pm-noremove+ - gfs::+pm-noyield+ - gfs::+pm-qs-input+ - gfs::+pm-qs-postmessage+)) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defconstant +wm-gf-init-msg+ #xABCD) + (defconstant +key-event-peek-flags+ (logior gfs::+pm-noremove+ + gfs::+pm-noyield+ + gfs::+pm-qs-input+ + gfs::+pm-qs-postmessage+))) ;;; ;;; window procedures @@ -139,6 +141,8 @@ (setf ret-val (cffi:pointer-address (brush-handle-of widget)))) ret-val)) +;;; FIXME: replace event-time slot with call to GetMessageTime +;;; (defun obtain-event-time () (event-time (thread-context))) @@ -216,13 +220,30 @@ 0) (defmethod process-message (hwnd (msg (eql gfs::+wm-create+)) wparam lparam) - (let ((w (get-widget (thread-context) hwnd))) ; has side-effect of setting handle slot - (if (typep w 'dialog) - (return-from process-message (gfs::def-dlg-proc hwnd msg wparam lparam)))) + (let ((widget (get-widget (thread-context) hwnd))) ; has side-effect of setting handle slot + (if (typep widget 'dialog) + (let ((tmp (gfs::def-dlg-proc hwnd msg wparam lparam))) + (gfs::post-message hwnd +wm-gf-init-msg+ 0 0) ; 2nd stage init with fully-baked widget + (return-from process-message tmp)) + (gfs::post-message hwnd +wm-gf-init-msg+ 0 0))) ; 2nd stage init with fully-baked widget + 0) + +(defmethod process-message (hwnd (msg (eql +wm-gf-init-msg+)) wparam lparam) + (declare (ignore wparam lparam)) + (let ((widget (get-widget (thread-context) hwnd))) + (unless widget + (return-from process-message 0))) 0) (defmethod process-message (hwnd (msg (eql gfs::+wm-destroy+)) wparam lparam) (declare (ignore wparam lparam)) + (let ((widget (get-widget (thread-context) hwnd))) + (if widget + (event-dispose (dispatcher widget) widget))) + ;; If widget is registered with a layout manager, that reference + ;; is not cleared until the next time the layout manager is invoked. + ;; This alleviates the need for slow messy code here. + ;; (delete-widget (thread-context) hwnd) 0) @@ -242,10 +263,10 @@ (defmethod process-message (hwnd (msg (eql gfs::+wm-char+)) wparam lparam) (declare (ignore lparam)) (let* ((tc (thread-context)) - (w (get-widget tc hwnd)) + (widget (get-widget tc hwnd)) (ch (code-char (lo-word wparam)))) - (when w - (event-key-down (dispatcher w) w (virtual-key tc) ch))) + (when widget + (event-key-down (dispatcher widget) widget (virtual-key tc) ch))) 0) (defmethod process-message (hwnd (msg (eql gfs::+wm-keydown+)) wparam lparam) Modified: trunk/src/uitoolkit/widgets/flow-layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/flow-layout.lisp (original) +++ trunk/src/uitoolkit/widgets/flow-layout.lisp Fri Aug 18 13:18:48 2006 @@ -170,18 +170,16 @@ ;;; methods ;;; -(defmethod compute-size ((layout flow-layout) (win window) width-hint height-hint) - (let ((kids (mapchildren win (lambda (parent child) - (declare (ignore parent)) - child)))) - (flow-container-size layout (visible-p win) kids width-hint height-hint))) +(defmethod compute-size ((self flow-layout) (container layout-managed) width-hint height-hint) + (cleanup-disposed-items self) + (let ((kids (loop for item in (data-of self) collect (first item)))) + (flow-container-size self (visible-p container) kids width-hint height-hint))) -(defmethod compute-layout ((layout flow-layout) (win window) width-hint height-hint) - (let ((kids (mapchildren win (lambda (parent child) - (declare (ignore parent)) - child)))) - (flow-container-layout layout (visible-p win) kids width-hint height-hint))) +(defmethod compute-layout ((self flow-layout) (container layout-managed) width-hint height-hint) + (cleanup-disposed-items self) + (let ((kids (loop for item in (data-of self) collect (first item)))) + (flow-container-layout self (visible-p container) kids width-hint height-hint))) -(defmethod initialize-instance :after ((layout flow-layout) &key) - (unless (intersection (style-of layout) '(:horizontal :vertical)) - (setf (style-of layout) (list :horizontal)))) +(defmethod initialize-instance :after ((self flow-layout) &key) + (unless (intersection (style-of self) '(:horizontal :vertical)) + (setf (style-of self) (list :horizontal)))) Modified: trunk/src/uitoolkit/widgets/heap-layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/heap-layout.lisp (original) +++ trunk/src/uitoolkit/widgets/heap-layout.lisp Fri Aug 18 13:18:48 2006 @@ -37,21 +37,23 @@ ;;; methods ;;; -(defmethod compute-size ((self heap-layout) win width-hint height-hint) +(defmethod compute-size ((self heap-layout) (container layout-managed) width-hint height-hint) + (cleanup-disposed-items self) (let ((size (gfs:make-size))) - (mapchildren win (lambda (parent kid) - (declare (ignore parent)) - (let ((kid-size (preferred-size kid width-hint height-hint))) - (setf (gfs:size-width size) (max (gfs:size-width size) - (gfs:size-width kid-size)) - (gfs:size-height size) (max (gfs:size-height size) - (gfs:size-height kid-size)))))) + (mapc (lambda (item) + (let ((kid-size (preferred-size (first item) width-hint height-hint))) + (setf (gfs:size-width size) (max (gfs:size-width size) + (gfs:size-width kid-size)) + (gfs:size-height size) (max (gfs:size-height size) + (gfs:size-height kid-size))))) + (data-of self)) (incf (gfs:size-width size) (+ (left-margin-of self) (right-margin-of self))) (incf (gfs:size-height size) (+ (top-margin-of self) (bottom-margin-of self))) size)) -(defmethod compute-layout ((self heap-layout) win width-hint height-hint) - (let* ((size (client-size win)) +(defmethod compute-layout ((self heap-layout) (container layout-managed) width-hint height-hint) + (cleanup-disposed-items self) + (let* ((size (client-size container)) (horz-margin (+ (left-margin-of self) (right-margin-of self))) (vert-margin (+ (top-margin-of self) (bottom-margin-of self))) (new-size (gfs:make-size :width (- (if (> width-hint horz-margin) @@ -64,16 +66,19 @@ vert-margin))) (new-pnt (gfs:make-point :x (left-margin-of self) :y (top-margin-of self))) (bounds (gfs:make-rectangle :size new-size :location new-pnt))) - (mapchildren win (lambda (parent kid) - (declare (ignore parent)) - (cons kid bounds))))) + (mapcar (lambda (item) (cons (first item) bounds)) (data-of self)))) (defmethod perform ((self heap-layout) (container layout-managed) width-hint height-hint) - (let ((top (top-child-of self)) - (kid-specs (compute-layout self container width-hint height-hint))) - (unless top - (setf top (car (first kid-specs)))) - (arrange-children kid-specs (lambda (item) - (if (cffi:pointer-eq (gfs:handle top) (gfs:handle item)) - (logior +window-pos-flags+ gfs::+swp-showwindow+) - (logior +window-pos-flags+ gfs::+swp-hidewindow+)))))) + (if (layout-p container) + (let ((top (top-child-of self)) + (kid-specs (compute-layout self container width-hint height-hint))) + (unless top + (setf top (car (first kid-specs)))) + (arrange-hwnds kid-specs (lambda (item) + (if (eql top item) + (logior +window-pos-flags+ gfs::+swp-showwindow+) + (logior +window-pos-flags+ gfs::+swp-hidewindow+))))))) + +(defmethod (setf top-child-of) :after (child (self heap-layout)) + (unless (typep child 'widget) + (error 'gfs:toolkit-error :detail "top child must be an instance of a widget subclass"))) Modified: trunk/src/uitoolkit/widgets/layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/layout.lisp (original) +++ trunk/src/uitoolkit/widgets/layout.lisp Fri Aug 18 13:18:48 2006 @@ -43,27 +43,34 @@ ;;; helper functions ;;; -(defun layout-attribute (layout widget name) - "Return the value associated with name for widget; or NIL if no value is set." - (if (gfs:disposed-p widget) - (error 'gfs:disposed-error)) - (let ((attrs (assoc (gfs:handle widget) (data-of layout) :test #'cffi:pointer-eq))) - (unless attrs - (error 'gfs:toolkit-error :detail (format nil "~a is not managed ~a" widget layout))) - (getf (first (rest attrs)) name))) - -(defun set-layout-attribute (layout widget name value) - "Sets a value associated with name for widget in the specified layout." - (if (gfs:disposed-p widget) - (error 'gfs:disposed-error)) - (let ((attrs (assoc (gfs:handle widget) (data-of layout) :test #'cffi:pointer-eq))) - (unless attrs - (error 'gfs:toolkit-error :detail (format nil "~a is not managed ~a" widget layout))) - (setf (getf (first (rest attrs)) name) value))) +(defun layout-attribute (layout thing name) + "Return the value associated with name for thing; or NIL if no value is set." + (let ((items (assoc thing (data-of layout)))) + (unless items + (error 'gfs:toolkit-error :detail (format nil "~a is not managed by ~a" thing layout))) + (getf (first (rest items)) name))) + +(defun set-layout-attribute (layout thing name value) + "Sets a value associated with name for thing in the specified layout." + (let ((items (assoc thing (data-of layout)))) + (unless items + (error 'gfs:toolkit-error :detail (format nil "~a is not managed by ~a" thing layout))) + (setf (getf (first (rest items)) name) value))) (defsetf layout-attribute set-layout-attribute) -(defun arrange-children (kid-specs flags-func) +(defun append-layout-item (layout thing) + "Adds thing to layout unless it is already registered." + (setf (data-of layout) (nconc (data-of layout) (list (list thing nil))))) + +(defun delete-layout-item (layout thing) + "Removes thing from layout." + (delete thing (data-of layout) :key #'first)) + +(defun cleanup-disposed-items (layout) + (delete-if #'gfs:disposed-p (data-of layout) :key #'first)) + +(defun arrange-hwnds (kid-specs flags-func) (let ((hdwp (gfs::begin-defer-window-pos (length kid-specs)))) (loop for k in kid-specs for rect = (cdr k) @@ -93,25 +100,37 @@ ;;; methods ;;; -(defmethod initialize-instance :after ((layout layout-manager) +(defmethod initialize-instance :after ((self layout-manager) &key style margins horizontal-margins vertical-margins &allow-other-keys) - (setf (style-of layout) (if (listp style) style (list style))) + (setf (style-of self) (if (listp style) style (list style))) (unless (null margins) - (setf (left-margin-of layout) margins - (right-margin-of layout) margins - (top-margin-of layout) margins - (bottom-margin-of layout) margins)) + (setf (left-margin-of self) margins + (right-margin-of self) margins + (top-margin-of self) margins + (bottom-margin-of self) margins)) (unless (null horizontal-margins) - (setf (left-margin-of layout) horizontal-margins - (right-margin-of layout) horizontal-margins)) + (setf (left-margin-of self) horizontal-margins + (right-margin-of self) horizontal-margins)) (unless (null vertical-margins) - (setf (top-margin-of layout) vertical-margins - (bottom-margin-of layout) vertical-margins))) + (setf (top-margin-of self) vertical-margins + (bottom-margin-of self) vertical-margins))) + +(defmethod (setf layout-of) :after ((self layout-manager) (container layout-managed)) + (let ((orig-layout (layout-of container))) + (if orig-layout + (setf (data-of self) (loop for item in (data-of orig-layout) + when (not (gfs:disposed-p (first item))) + collect item) + (data-of orig-layout) nil) + (if (typep container 'window) + (setf (data-of self) (mapchildren container (lambda (parent child) + (declare (ignore parent)) + (list child nil)))))))) (defmethod perform ((self layout-manager) (container layout-managed) width-hint height-hint) - (when (layout-p container) - (arrange-children (compute-layout self container width-hint height-hint) - (lambda (item) - (declare (ignore item)) - +window-pos-flags+)))) + (if (layout-p container) + (arrange-hwnds (compute-layout self container width-hint height-hint) + (lambda (item) + (declare (ignore item)) + +window-pos-flags+)))) Modified: trunk/src/uitoolkit/widgets/thread-context.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/thread-context.lisp (original) +++ trunk/src/uitoolkit/widgets/thread-context.lisp Fri Aug 18 13:18:48 2006 @@ -40,7 +40,7 @@ (display-visitor-results :initform nil :accessor display-visitor-results) (job-table :initform (make-hash-table :test #'equal)) (job-table-lock :initform nil) - (event-time :initform 0 :accessor event-time) + (event-time :initform 0 :accessor event-time) ; FIXME: GetMessageTime (virtual-key :initform 0 :accessor virtual-key) (menuitems-by-id :initform (make-hash-table :test #'equal)) (mouse-event-pnt :initform (gfs:make-point) :accessor mouse-event-pnt) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Fri Aug 18 13:18:48 2006 @@ -50,11 +50,7 @@ (:documentation "Instances of this class employ a layout manager to organize their children.")) (defclass group (layout-managed) - ((children - :accessor children-of - :initarg :children - :initform nil) - (location + ((location :accessor location-of :initarg :location :initform nil) Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Fri Aug 18 13:18:48 2006 @@ -219,37 +219,37 @@ (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod initialize-instance :after ((w widget) &key style &allow-other-keys) - (setf (slot-value w 'style) (if (listp style) style (list style)))) +(defmethod initialize-instance :after ((self widget) &key style &allow-other-keys) + (setf (slot-value self 'style) (if (listp style) style (list style)))) -(defmethod location :before ((w widget)) - (if (gfs:disposed-p w) +(defmethod location :before ((self widget)) + (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod location ((w widget)) +(defmethod location ((self widget)) (cffi:with-foreign-object (wi-ptr 'gfs::windowinfo) (cffi:with-foreign-slots ((gfs::cbsize gfs::clientleft gfs::clienttop) wi-ptr gfs::windowinfo) (setf gfs::cbsize (cffi::foreign-type-size 'gfs::windowinfo)) - (when (zerop (gfs::get-window-info (gfs:handle w) wi-ptr)) + (when (zerop (gfs::get-window-info (gfs:handle self) wi-ptr)) (error 'gfs:win32-error :detail "get-window-info failed")) (cffi:with-foreign-object (pnt-ptr 'gfs::point) (cffi:with-foreign-slots ((gfs::x gfs::y) pnt-ptr gfs::point) (setf gfs::x gfs::clientleft) (setf gfs::y gfs::clienttop) - (gfs::screen-to-client (gfs:handle w) pnt-ptr) + (gfs::screen-to-client (gfs:handle self) pnt-ptr) (gfs:make-point :x gfs::x :y gfs::y)))))) -(defmethod (setf location) :before ((pnt gfs:point) (w widget)) +(defmethod (setf location) :before ((pnt gfs:point) (self widget)) (declare (ignore pnt)) - (if (gfs:disposed-p w) + (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod (setf location) ((pnt gfs:point) (w widget)) - (if (zerop (gfs::set-window-pos (gfs:handle w) +(defmethod (setf location) ((pnt gfs:point) (self widget)) + (if (zerop (gfs::set-window-pos (gfs:handle self) (cffi:null-pointer) (gfs:point-x pnt) (gfs:point-y pnt) @@ -272,12 +272,12 @@ nil (get-widget (thread-context) hwnd)))) -(defmethod pack :before ((w widget)) - (if (gfs:disposed-p w) +(defmethod pack :before ((self widget)) + (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod pack ((w widget)) - (setf (size w) (preferred-size w -1 -1))) +(defmethod pack ((self widget)) + (setf (size self) (preferred-size self -1 -1))) (defmethod parent ((self widget)) ;; Unlike the owner method, this method should Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Fri Aug 18 13:18:48 2006 @@ -58,7 +58,13 @@ (error 'gfs:win32-error :detail "create-window failed")) (if (find :keyboard-navigation (style-of win)) (put-kbdnav-widget tc win)) - (put-widget tc win)))) + (put-widget tc win)) + ;; FIXME: this is a temporary hack to allow layout management testing; + ;; it breaks in the presence of virtual containers like group + ;; + (let ((parent (parent win))) + (if (and parent (layout-of parent)) + (append-layout-item (layout-of parent) win))))) (defun child-window-visitor (hwnd lparam) (let* ((tc (thread-context))

1 0

[graphic-forms-cvs] r219 - in trunk: docs/manual src/uitoolkit/widgets
by junrue＠common-lisp.net 17 Aug '06

17 Aug '06

Author: junrue Date: Thu Aug 17 18:53:32 2006 New Revision: 219 Modified: trunk/docs/manual/widgets-api.texinfo trunk/src/uitoolkit/widgets/heap-layout.lisp trunk/src/uitoolkit/widgets/layout.lisp Log: refactored gfw:perform implementations Modified: trunk/docs/manual/widgets-api.texinfo ============================================================================== --- trunk/docs/manual/widgets-api.texinfo (original) +++ trunk/docs/manual/widgets-api.texinfo Thu Aug 17 18:53:32 2006 @@ -694,14 +694,16 @@ @node layout types @subsection layout types -@strong{NOTE:} A future release will provide additional layout -manager classes. - @anchor{flow-layout} @deftp Class flow-layout spacing -This @ref{layout-manager} subclass arranges dialog or window children -in a row or column, with optional spacing (specified in pixels) -between children. +This @ref{layout-manager} subclass arranges container children +in a row or column. There are no child-specific layout attributes +defined for this class. +@table @var +@item spacing +A pixel value specifying how far apart each child should be from +the next. +@end table @deffn Initarg :style This initarg accepts a list containing one of the following style keywords: @@ -725,13 +727,15 @@ @anchor{heap-layout} @deftp Class heap-layout top-child This @ref{layout-manager} subclass resizes all children to the same -size and stacks them on top of each other. -@deffn Initarg :top-child +size and stacks them on top of each other. There are no child-specific +layout attributes defined for this class. +@table @var +@item top-child Use this initarg to specify the child widget that should be visible. The corresponding accessor @code{top-child-of} can be set subsequently, followed by calling @ref{layout} on the container, in order to make a different child visible. -@end deffn +@end table @end deftp @anchor{layout-manager} @@ -1741,11 +1745,12 @@ @anchor{layout-attribute} @defun layout-attribute @ref{layout-manager} thing symbol => value (setf (@strong{layout-attribute} @var{layout-manager} @var{thing} @var{symbol}) @var{value})@*@* -This function returns @var{value} if the attribute named by @var{symbol} -is set in @var{layout-manager}; @sc{nil} otherwise. The corresponding -@sc{setf} function allows the attribute to be set. Each layout-manager -subclass supports 0 or more attributes that apply to each @var{thing}. -This function does not restrict application code +Each layout-manager subclass supports 0 or more attributes that apply +to each @var{thing}. This function returns @var{value} if the attribute +named by @var{symbol} is set for @var{thing} in @var{layout-manager}; +it returns @sc{nil} otherwise. The corresponding @sc{setf} function +allows the attribute to be set (note: call @ref{layout} on @var{container} +after doing so). This function does not restrict application code from querying or setting attributes that are not supported by the layout manager. @table @var @@ -1763,22 +1768,22 @@ @end defun @anchor{perform} -@deffn GenericFunction perform @var{layout-manager} container width-hint height-hint -Calls @ref{compute-layout} for @code{container} and then moves and -resizes @code{container}'s children. Layout subclasses may override +@deffn GenericFunction perform @ref{layout-manager} @ref{layout-managed} width-hint height-hint +Calls @ref{compute-layout} for @var{layout-managed} and then moves and +resizes @var{layout-managed}'s children. Subclasses may override this method -- however, most derivations should call @sc{CALL-NEXT-METHOD} to allow the base implementation to execute. @table @var @item layout-manager -The layout object dictating how children of @var{container} +The layout object dictating how children of @var{layout-managed} are to be arranged. @item container -The @var{layout-manager} arranges the elements of @var{container}. +The @var{layout-manager} arranges the elements of @var{layout-managed}. @item width-hint -A hypothetical width value, or negative if @var{container}'s width is +A hypothetical width value, or negative if @var{layout-managed}'s width is not constrained. @item height-hint -A hypothetical height value, or negative if @var{container}'s height is +A hypothetical height value, or negative if @var{layout-managed}'s height is not constrained. @end table @end deffn Modified: trunk/src/uitoolkit/widgets/heap-layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/heap-layout.lisp (original) +++ trunk/src/uitoolkit/widgets/heap-layout.lisp Thu Aug 17 18:53:32 2006 @@ -69,38 +69,11 @@ (cons kid bounds))))) (defmethod perform ((self heap-layout) (container layout-managed) width-hint height-hint) - (let ((kids nil) - (hdwp (cffi:null-pointer)) - (top (top-child-of self))) - (when (layout-p container) - (setf kids (compute-layout self container width-hint height-hint)) - (unless top - (setf top (car (first kids)))) - (setf hdwp (gfs::begin-defer-window-pos (length kids))) - (loop for k in kids - do (let* ((rect (cdr k)) - (sz (gfs:size rect)) - (pnt (gfs:location rect)) - (kid-win (car k)) - (hwnd-after (cffi:null-pointer)) - (flags (logior +window-pos-flags+ gfs::+swp-hidewindow+))) - (when (cffi:pointer-eq (gfs:handle kid-win) (gfs:handle top)) - (setf flags (logior +window-pos-flags+ gfs::+swp-showwindow+))) - (if (gfs:null-handle-p hdwp) - (gfs::set-window-pos (gfs:handle kid-win) - hwnd-after - (gfs:point-x pnt) - (gfs:point-y pnt) - (gfs:size-width sz) - (gfs:size-height sz) - flags) - (setf hdwp (gfs::defer-window-pos hdwp - (gfs:handle kid-win) - hwnd-after - (gfs:point-x pnt) - (gfs:point-y pnt) - (gfs:size-width sz) - (gfs:size-height sz) - flags))))) - (unless (gfs:null-handle-p hdwp) - (gfs::end-defer-window-pos hdwp))))) + (let ((top (top-child-of self)) + (kid-specs (compute-layout self container width-hint height-hint))) + (unless top + (setf top (car (first kid-specs)))) + (arrange-children kid-specs (lambda (item) + (if (cffi:pointer-eq (gfs:handle top) (gfs:handle item)) + (logior +window-pos-flags+ gfs::+swp-showwindow+) + (logior +window-pos-flags+ gfs::+swp-hidewindow+)))))) Modified: trunk/src/uitoolkit/widgets/layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/layout.lisp (original) +++ trunk/src/uitoolkit/widgets/layout.lisp Thu Aug 17 18:53:32 2006 @@ -63,6 +63,32 @@ (defsetf layout-attribute set-layout-attribute) +(defun arrange-children (kid-specs flags-func) + (let ((hdwp (gfs::begin-defer-window-pos (length kid-specs)))) + (loop for k in kid-specs + for rect = (cdr k) + for size = (gfs:size rect) + for pnt = (gfs:location rect) + do (progn + (if (gfs:null-handle-p hdwp) + (gfs::set-window-pos (gfs:handle (car k)) + (cffi:null-pointer) + (gfs:point-x pnt) + (gfs:point-y pnt) + (gfs:size-width size) + (gfs:size-height size) + (funcall flags-func (car k))) + (gfs::defer-window-pos hdwp + (gfs:handle (car k)) + (cffi:null-pointer) + (gfs:point-x pnt) + (gfs:point-y pnt) + (gfs:size-width size) + (gfs:size-height size) + (funcall flags-func (car k)))))) + (unless (gfs:null-handle-p hdwp) + (gfs::end-defer-window-pos hdwp)))) + ;;; ;;; methods ;;; @@ -84,31 +110,8 @@ (bottom-margin-of layout) vertical-margins))) (defmethod perform ((self layout-manager) (container layout-managed) width-hint height-hint) - "Calls compute-layout for a container and then handles the actual moving and resizing of its children." - (let ((kids nil) - (hdwp (cffi:null-pointer))) - (when (layout-p container) - (setf kids (compute-layout self container width-hint height-hint)) - (setf hdwp (gfs::begin-defer-window-pos (length kids))) - (loop for k in kids - do (let* ((rect (cdr k)) - (sz (gfs:size rect)) - (pnt (gfs:location rect))) - (if (gfs:null-handle-p hdwp) - (gfs::set-window-pos (gfs:handle (car k)) - (cffi:null-pointer) - (gfs:point-x pnt) - (gfs:point-y pnt) - (gfs:size-width sz) - (gfs:size-height sz) - +window-pos-flags+) - (setf hdwp (gfs::defer-window-pos hdwp - (gfs:handle (car k)) - (cffi:null-pointer) - (gfs:point-x pnt) - (gfs:point-y pnt) - (gfs:size-width sz) - (gfs:size-height sz) - +window-pos-flags+))))) - (unless (gfs:null-handle-p hdwp) - (gfs::end-defer-window-pos hdwp))))) + (when (layout-p container) + (arrange-children (compute-layout self container width-hint height-hint) + (lambda (item) + (declare (ignore item)) + +window-pos-flags+))))

1 0

[graphic-forms-cvs] r218 - in trunk: docs/manual src src/tests/uitoolkit src/uitoolkit/graphics/plugins/default src/uitoolkit/widgets
by junrue＠common-lisp.net 17 Aug '06

17 Aug '06

Author: junrue Date: Thu Aug 17 17:55:50 2006 New Revision: 218 Modified: trunk/docs/manual/graphics-api.texinfo trunk/docs/manual/widgets-api.texinfo trunk/src/packages.lisp trunk/src/tests/uitoolkit/layout-unit-tests.lisp trunk/src/tests/uitoolkit/mock-objects.lisp trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp trunk/src/uitoolkit/widgets/layout-classes.lisp trunk/src/uitoolkit/widgets/layout-generics.lisp trunk/src/uitoolkit/widgets/layout.lisp Log: implemented and documented gfw:layout-attribute function Modified: trunk/docs/manual/graphics-api.texinfo ============================================================================== --- trunk/docs/manual/graphics-api.texinfo (original) +++ trunk/docs/manual/graphics-api.texinfo Thu Aug 17 17:55:50 2006 @@ -551,8 +551,12 @@ @item :large Identifies the largest image of the @var{icon-bundle}. @item :small -Identifies the smallest image of the @var{icon-bundle}. +Identifies the smallest image of the @var{icon-bundle}.@*@* @end table +@strong{Note:} there are actually four icon sizes that Windows +defines for various contexts. A future release will add keywords to +better distinguish amongst all four, and to help ensure the correct +sizes are chosen when an icon-bundle is passed to @sc{(setf gfw:image)}. @end table To find out how many images are stored in @var{icon-bundle}, and hence what constitutes a valid range of subscripts for this function, Modified: trunk/docs/manual/widgets-api.texinfo ============================================================================== --- trunk/docs/manual/widgets-api.texinfo (original) +++ trunk/docs/manual/widgets-api.texinfo Thu Aug 17 17:55:50 2006 @@ -735,12 +735,28 @@ @end deftp @anchor{layout-manager} -@deftp Class layout-manager style left-margin top-margin right-margin bottom-margin -Subclasses implement layout strategies on behalf of window -objects. Every layout manager allows optional margins (specified in -pixels) within the perimeter of the container being managed.@*@* The -values accepted by the @code{:style} initarg vary depending on the -actual @code{layout-manager} subclass being used. +@deftp Class layout-manager bottom-margin data left-margin right-margin top-margin style +Subclasses implement layout strategies to manage space within containers. +@table @var +@item bottom-margin +This slot holds a margin value in pixels for the bottom side of +the container. +@item data +This slot holds a @sc{alist} of pairs, each one associating a +@sc{plist} of layout-specific attributes with an item from a +container. +@item left-margin +This slot holds a margin value in pixels for the left side of +the container. +@item right-margin +This slot holds a margin value in pixels for the right side of +the container. +@item style +The values appropriate for this slot are subclass-specific. +@item top-margin +This slot holds a margin value in pixels for the top side of +the container. +@end table @deffn Initarg :horizontal-margins This initarg accepts a horizontal margin value that is applied to both the left and right sides of the container. @@ -1665,40 +1681,104 @@ @node layout functions @subsection layout functions -These functions comprise the protocol for @ref{layout-manager}s. As -such, they are not normally called by application code, but instead -are the concern of layout-manager implementers. - -The @code{width-hint} and @code{height-hint} parameters are a -mechanism to express the @emph{what-if} scenario where the total width -or height of the container is fixed; the proper response is to -calculate the container's desired dimension on the opposite -axis. While this behavior is primarily the concern of child windows -and/or controls, layout manager implementations should look for -non-negative values for either @code{width-hint} or -@code{height-hint}, indicating that the container's size is -constrained. +The functions @ref{compute-layout}, @ref{compute-size}, and +@ref{perform} comprise the internal protocol for +@ref{layout-manager}s. As such, they are not normally called by +application code, being instead the concern of layout-manager +implementations. The @var{width-hint} and @var{height-hint} parameters +passed to the following functions are a mechanism to express the +@emph{what-if} scenario where the total width or height of the +container is fixed; the proper response is to calculate the +container's desired dimension on the opposite axis. While this +behavior is primarily the concern of child windows and/or controls, +layout manager implementations should look for non-negative values for +either @var{width-hint} or @var{height-hint}, indicating that the +container's size is constrained. @anchor{compute-layout} -@deffn GenericFunction compute-layout layout container width-hint height-hint -Returns a list of conses @code{(child . rectangle)} describing the -new bounds of each child window or control. A @ref{layout-manager} subclass +@deffn GenericFunction compute-layout @ref{layout-manager} container width-hint height-hint +Returns a list of pairs @code{(item rectangle)} describing the +new bounds of each child within @var{container}. A layout-manager subclass implements this method based on its particular layout strategy, taking -into account attributes set by the user. Certain Graphic-Forms functions -call this method to accomplish layout within a container. +into account attributes set by the user via @ref{layout-attribute}. Certain +Graphic-Forms functions call this method to accomplish layout within a container. +@table @var +@item layout-manager +The layout object dictating how children of @var{container} +are to be arranged. +@item container +The @var{layout-manager} arranges the elements of @var{container}. +@item width-hint +A hypothetical width value, or negative if @var{container}'s width is +not constrained. +@item height-hint +A hypothetical height value, or negative if @var{container}'s height is +not constrained. +@end table @end deffn -@deffn GenericFunction compute-size layout container width-hint height-hint +@anchor{compute-size} +@deffn GenericFunction compute-size @ref{layout-manager} container width-hint height-hint Computes and returns the new @ref{size} of the @code{container}'s -client area. A @ref{layout-manager} subclass implements this method +client area. A layout-manager subclass implements this method based on its particular layout strategy, taking into account -attributes set by the user. The @ref{pack} function ultimately calls -this method. +attributes set by the user via @ref{layout-attribute}. +@table @var +@item layout-manager +The layout object dictating how children of @var{container} +are to be arranged. +@item container +The @var{layout-manager} arranges the elements of @var{container}. +@item width-hint +A hypothetical width value, or negative if @var{container}'s width is +not constrained. +@item height-hint +A hypothetical height value, or negative if @var{container}'s height is +not constrained. +@end table @end deffn -@deffn GenericFunction perform layout container width-hint height-hint +@anchor{layout-attribute} +@defun layout-attribute @ref{layout-manager} thing symbol => value +(setf (@strong{layout-attribute} @var{layout-manager} @var{thing} @var{symbol}) @var{value})@*@* +This function returns @var{value} if the attribute named by @var{symbol} +is set in @var{layout-manager}; @sc{nil} otherwise. The corresponding +@sc{setf} function allows the attribute to be set. Each layout-manager +subclass supports 0 or more attributes that apply to each @var{thing}. +This function does not restrict application code +from querying or setting attributes that are not supported by the +layout manager. +@table @var +@item layout-manager +The layout object dictating how children of @var{container} +are to be arranged. +@item thing +The object being managed by @var{layout-manager}. +@item symbol +A @sc{symbol} identifying an item-specific attribute supported +by @var{layout-manager}. +@item value +The data of an attribute which configures the behavior of @var{layout-manager}. +@end table +@end defun + +@anchor{perform} +@deffn GenericFunction perform @var{layout-manager} container width-hint height-hint Calls @ref{compute-layout} for @code{container} and then moves and resizes @code{container}'s children. Layout subclasses may override -this method -- most derivations should call @sc{CALL-NEXT-METHOD} to -allow the base implementation to execute. +this method -- however, most derivations should call @sc{CALL-NEXT-METHOD} +to allow the base implementation to execute. +@table @var +@item layout-manager +The layout object dictating how children of @var{container} +are to be arranged. +@item container +The @var{layout-manager} arranges the elements of @var{container}. +@item width-hint +A hypothetical width value, or negative if @var{container}'s width is +not constrained. +@item height-hint +A hypothetical height value, or negative if @var{container}'s height is +not constrained. +@end table @end deffn Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Thu Aug 17 17:55:50 2006 @@ -440,6 +440,7 @@ #:key-toggled-p #:label #:layout + #:layout-attribute #:layout-of #:layout-p #:left-margin-of Modified: trunk/src/tests/uitoolkit/layout-unit-tests.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-unit-tests.lisp (original) +++ trunk/src/tests/uitoolkit/layout-unit-tests.lisp Thu Aug 17 17:55:50 2006 @@ -54,6 +54,25 @@ expected-rects actual-rects))) +(define-test layout-attributes-test + (let ((widget1 (make-instance 'mock-widget :handle 1234)) + (widget2 (make-instance 'mock-widget :handle 5678))) + (let ((data1 `(,(cffi:make-pointer 1234) (a 1 b 2))) + (data2 `(,(cffi:make-pointer 5678) (a 10 c 30))) + (layout (make-instance 'gfw:layout-manager))) + (setf (slot-value layout 'gfw::data) (list data1 data2)) + (assert-equal 1 (gfw:layout-attribute layout widget1 'a)) + (assert-equal 2 (gfw:layout-attribute layout widget1 'b)) + (assert-equal 10 (gfw:layout-attribute layout widget2 'a)) + (assert-equal 30 (gfw:layout-attribute layout widget2 'c)) + (setf (gfw:layout-attribute layout widget1 'b) 66 + (gfw:layout-attribute layout widget2 'd) 100) + (assert-equal 1 (gfw:layout-attribute layout widget1 'a)) + (assert-equal 66 (gfw:layout-attribute layout widget1 'b)) + (assert-equal 10 (gfw:layout-attribute layout widget2 'a)) + (assert-equal 30 (gfw:layout-attribute layout widget2 'c)) + (assert-equal 100 (gfw:layout-attribute layout widget2 'd))))) + (define-test flow-layout-test1 ;; orient: horizontal ;; normalize: disabled Modified: trunk/src/tests/uitoolkit/mock-objects.lisp ============================================================================== --- trunk/src/tests/uitoolkit/mock-objects.lisp (original) +++ trunk/src/tests/uitoolkit/mock-objects.lisp Thu Aug 17 17:55:50 2006 @@ -57,8 +57,8 @@ :initarg :min-size :initform (gfs:make-size)))) -(defmethod initialize-instance :after ((widget mock-widget) &key) - (setf (slot-value widget 'gfs:handle) (cffi:make-pointer #xFFFFFFFF))) +(defmethod initialize-instance :after ((widget mock-widget) &key handle &allow-other-keys) + (setf (slot-value widget 'gfs:handle) (cffi:make-pointer (or handle #xFFFFFFFF)))) (defmethod gfw:location ((widget mock-widget)) (gfs:make-point)) Modified: trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp (original) +++ trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp Thu Aug 17 17:55:50 2006 @@ -104,7 +104,7 @@ (load-bmp-data stream t t))))) (defun loader (path) - (let* ((file-type (string-downcase (pathname-type path))) + (let* ((file-type (pathname-type path)) (helper (cond ((string-equal file-type "bmp") #'load-bmp-data) ((string-equal file-type "ico") #'load-icon-data) Modified: trunk/src/uitoolkit/widgets/layout-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/layout-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/layout-classes.lisp Thu Aug 17 17:55:50 2006 @@ -53,8 +53,11 @@ (bottom-margin :accessor bottom-margin-of :initarg :bottom-margin - :initform 0)) - (:documentation "Subclasses implement layout strategies on behalf of window objects.")) + :initform 0) + (data + :accessor data-of + :initform nil)) + (:documentation "Subclasses implement layout strategies to manage space within windows.")) (defclass flow-layout (layout-manager) ((spacing Modified: trunk/src/uitoolkit/widgets/layout-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/layout-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/layout-generics.lisp Thu Aug 17 17:55:50 2006 @@ -33,11 +33,16 @@ (in-package :graphic-forms.uitoolkit.widgets) -(defgeneric compute-size (layout win width-hint height-hint) +(defgeneric compute-size (self win width-hint height-hint) (:documentation "Computes and returns the size of the window's client area based on the layout's strategy.")) -(defgeneric compute-layout (layout win width-hint height-hint) +(defgeneric compute-layout (self win width-hint height-hint) (:documentation "Returns a list of conses (window . rectangle) describing the new bounds of each child window.")) -(defgeneric perform (layout window widget-hint height-hint) +(defgeneric obtain-default (self) + (:documentation "Returns an instance representing default values to be used when none is supplied by the application.") + (:method (self) + (declare (ignorable self)))) + +(defgeneric perform (self window widget-hint height-hint) (:documentation "Moves and resizes window children based on layout strategy.")) Modified: trunk/src/uitoolkit/widgets/layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/layout.lisp (original) +++ trunk/src/uitoolkit/widgets/layout.lisp Thu Aug 17 17:55:50 2006 @@ -40,6 +40,30 @@ gfs::+swp-nocopybits+))) ;;; +;;; helper functions +;;; + +(defun layout-attribute (layout widget name) + "Return the value associated with name for widget; or NIL if no value is set." + (if (gfs:disposed-p widget) + (error 'gfs:disposed-error)) + (let ((attrs (assoc (gfs:handle widget) (data-of layout) :test #'cffi:pointer-eq))) + (unless attrs + (error 'gfs:toolkit-error :detail (format nil "~a is not managed ~a" widget layout))) + (getf (first (rest attrs)) name))) + +(defun set-layout-attribute (layout widget name value) + "Sets a value associated with name for widget in the specified layout." + (if (gfs:disposed-p widget) + (error 'gfs:disposed-error)) + (let ((attrs (assoc (gfs:handle widget) (data-of layout) :test #'cffi:pointer-eq))) + (unless attrs + (error 'gfs:toolkit-error :detail (format nil "~a is not managed ~a" widget layout))) + (setf (getf (first (rest attrs)) name) value))) + +(defsetf layout-attribute set-layout-attribute) + +;;; ;;; methods ;;; @@ -48,16 +72,16 @@ &allow-other-keys) (setf (style-of layout) (if (listp style) style (list style))) (unless (null margins) - (setf (left-margin-of layout) margins) - (setf (right-margin-of layout) margins) - (setf (top-margin-of layout) margins) - (setf (bottom-margin-of layout) margins)) + (setf (left-margin-of layout) margins + (right-margin-of layout) margins + (top-margin-of layout) margins + (bottom-margin-of layout) margins)) (unless (null horizontal-margins) - (setf (left-margin-of layout) horizontal-margins) - (setf (right-margin-of layout) horizontal-margins)) + (setf (left-margin-of layout) horizontal-margins + (right-margin-of layout) horizontal-margins)) (unless (null vertical-margins) - (setf (top-margin-of layout) vertical-margins) - (setf (bottom-margin-of layout) vertical-margins))) + (setf (top-margin-of layout) vertical-margins + (bottom-margin-of layout) vertical-margins))) (defmethod perform ((self layout-manager) (container layout-managed) width-hint height-hint) "Calls compute-layout for a container and then handles the actual moving and resizing of its children."

1 0