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

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

05 Jul '06

Author: junrue Date: Wed Jul 5 00:18:46 2006 New Revision: 176 Modified: trunk/README.txt trunk/docs/manual/api.texinfo trunk/docs/manual/reference.texinfo trunk/src/packages.lisp trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/uitoolkit/widgets/dialog.lisp trunk/src/uitoolkit/widgets/flow-layout.lisp trunk/src/uitoolkit/widgets/heap-layout.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp trunk/src/uitoolkit/widgets/window.lisp Log: promoted mapchildren to a widget generic function and cleaned up its semantics, and got rid of with-children at the same time Modified: trunk/README.txt ============================================================================== --- trunk/README.txt (original) +++ trunk/README.txt Wed Jul 5 00:18:46 2006 @@ -1,5 +1,5 @@ -Graphic-Forms README for version 0.4.0 +Graphic-Forms README for version 0.5.0 Copyright (c) 2006, Jack D. Unrue Graphic-Forms is a user interface library implemented in Common Lisp focusing Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Wed Jul 5 00:18:46 2006 @@ -1107,6 +1107,13 @@ system. @xref{parent}. @end deffn +@deffn GenericFunction mapchildren self func => result-list +Calls @code{func}, which is a function of two arguments, for each +child of @code{self} and places @code{func}'s return value in +@code{result-list}. @code{func}'s two arguments are @code{self} and +the current child. +@end deffn + @anchor{maximum-size} @deffn GenericFunction maximum-size self => size Returns a @ref{size} object describing the largest dimensions to which Modified: trunk/docs/manual/reference.texinfo ============================================================================== --- trunk/docs/manual/reference.texinfo (original) +++ trunk/docs/manual/reference.texinfo Wed Jul 5 00:18:46 2006 @@ -126,7 +126,7 @@ @titlepage @title Graphic-Forms Programming Reference -@c @subtitle Version 0.4 +@c @subtitle Version 0.5 @c @author Jack D. Unrue @page @@ -136,7 +136,7 @@ @ifnottex @node Top -@top Graphic-Forms Programming Reference (version 0.4) +@top Graphic-Forms Programming Reference (version 0.5) @insertcopying @end ifnottex Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Wed Jul 5 00:18:46 2006 @@ -423,6 +423,7 @@ #:location #:lock #:locked-p + #:mapchildren #:maximize #:maximized-p #:maximum-size @@ -493,7 +494,6 @@ #:vertical-scrollbar #:visible-item-count #:visible-p - #:with-children #:with-file-dialog #:with-font-dialog Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Wed Jul 5 00:18:46 2006 @@ -172,24 +172,29 @@ (defmethod gfw:event-activate ((d child-menu-dispatcher) menu time) (declare (ignore time)) (gfw:clear-all menu) - (gfw:with-children (*layout-tester-win* kids) - (loop for k in kids - do (let ((it (gfw::append-item menu (gfw:text k) nil nil))) - (unless (null (sub-disp-class-of d)) - (setf (gfw:dispatcher it) (make-instance (sub-disp-class-of d)))) - (unless (null (check-test-fn d)) - (gfw:check it (funcall (check-test-fn d) k))))))) + (gfw:mapchildren *layout-tester-win* + (lambda (parent child) + (declare (ignore parent)) + (let ((it (gfw::append-item menu (gfw:text child) nil nil))) + (unless (null (sub-disp-class-of d)) + (setf (gfw:dispatcher it) (make-instance (sub-disp-class-of d)))) + (unless (null (check-test-fn d)) + (gfw:check it (funcall (check-test-fn d) child))))))) + +(defun find-victim (text) + (let ((victim nil)) + (gfw:mapchildren *layout-tester-win* + (lambda (parent child) + (declare (ignore parent)) + (if (string= (gfw:text child) text) + (setf victim child)))) + victim)) (defclass remove-child-dispatcher (gfw:event-dispatcher) ()) (defmethod gfw:event-select ((d remove-child-dispatcher) item time rect) (declare (ignorable time rect)) - (let ((text (gfw:text item)) - (victim nil)) - (gfw:with-children (*layout-tester-win* kids) - (loop for k in kids - do (if (string= (gfw:text k) text) - (setf victim k)))) + (let ((victim (find-victim (gfw:text item)))) (unless (null victim) (gfs:dispose victim) (gfw:layout *layout-tester-win*)))) @@ -198,12 +203,7 @@ (defmethod gfw:event-select ((d visibility-child-dispatcher) item time rect) (declare (ignorable time rect)) - (let ((text (gfw:text item)) - (victim nil)) - (gfw:with-children (*layout-tester-win* kids) - (loop for k in kids - do (if (string= (gfw:text k) text) - (setf victim k)))) + (let ((victim (find-victim (gfw:text item)))) (unless (null victim) (gfw:show victim (not (gfw:visible-p victim))) (gfw:layout *layout-tester-win*)))) Modified: trunk/src/uitoolkit/widgets/dialog.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/dialog.lisp (original) +++ trunk/src/uitoolkit/widgets/dialog.lisp Wed Jul 5 00:18:46 2006 @@ -83,10 +83,13 @@ (error 'gfs:disposed-error))) (defmethod cancel-widget ((self dialog)) - (with-children (self kids) - (loop for kid in kids - until (= (gfs::get-window-long (gfs:handle kid) gfs::+gwlp-id+) gfs::+idcancel+) - finally (return kid)))) + (let ((kid nil)) + (mapchildren self + (lambda (parent child) + (declare (ignore parent)) + (if (= (gfs::get-window-long (gfs:handle child) gfs::+gwlp-id+) gfs::+idcancel+) + (setf kid child)))) + kid)) (defmethod (setf cancel-widget) :before ((def-widget widget) (self dialog)) (if (or (gfs:disposed-p self) (gfs:disposed-p def-widget)) @@ -118,10 +121,13 @@ (error 'gfs:disposed-error))) (defmethod default-widget ((self dialog)) - (with-children (self kids) - (loop for kid in kids - until (= (gfs::get-window-long (gfs:handle kid) gfs::+gwlp-id+) gfs::+idok+) - finally (return kid)))) + (let ((kid nil)) + (mapchildren self + (lambda (parent child) + (declare (ignore parent)) + (if (= (gfs::get-window-long (gfs:handle child) gfs::+gwlp-id+) gfs::+idok+) + (setf kid child)))) + kid)) (defmethod (setf default-widget) :before ((def-widget widget) (self dialog)) (if (or (gfs:disposed-p self) (gfs:disposed-p def-widget)) Modified: trunk/src/uitoolkit/widgets/flow-layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/flow-layout.lisp (original) +++ trunk/src/uitoolkit/widgets/flow-layout.lisp Wed Jul 5 00:18:46 2006 @@ -171,11 +171,15 @@ ;;; (defmethod compute-size ((layout flow-layout) (win window) width-hint height-hint) - (with-children (win kids) + (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-layout ((layout flow-layout) (win window) width-hint height-hint) - (with-children (win kids) + (let ((kids (mapchildren win (lambda (parent child) + (declare (ignore parent)) + child)))) (flow-container-layout layout (visible-p win) kids width-hint height-hint))) (defmethod initialize-instance :after ((layout flow-layout) &key) Modified: trunk/src/uitoolkit/widgets/heap-layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/heap-layout.lisp (original) +++ trunk/src/uitoolkit/widgets/heap-layout.lisp Wed Jul 5 00:18:46 2006 @@ -39,13 +39,13 @@ (defmethod compute-size ((self heap-layout) win width-hint height-hint) (let ((size (gfs:make-size))) - (with-children (win kids) - (loop for kid in kids - do (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)))))) + (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)))))) (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)) @@ -64,8 +64,9 @@ 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))) - (with-children (win kids) - (loop for kid in kids collect (cons kid bounds))))) + (mapchildren win (lambda (parent kid) + (declare (ignore parent)) + (cons kid bounds))))) (defmethod perform ((self heap-layout) win width-hint height-hint) (let ((kids nil) Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Wed Jul 5 00:18:46 2006 @@ -204,6 +204,9 @@ (defgeneric locked-p (self) (:documentation "Returns T if this object's contents are locked from being modified.")) +(defgeneric mapchildren (self func) + (:documentation "Executes func for each direct child of self.")) + (defgeneric maximize (self flag) (:documentation "Set the object (or restore it from) the maximized state (not necessarily the same as the maximum size).")) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Wed Jul 5 00:18:46 2006 @@ -61,52 +61,35 @@ (put-kbdnav-widget tc win)) (put-widget tc win)))) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defmacro child-visitor-proper (hwnd lparam) + (let ((tc (gensym)) + (tmp-list (gensym)) + (child (gensym)) + (parent (gensym)) + (ancestor-hwnd (gensym))) + `(let* ((,tc (thread-context)) + (,child (get-widget ,tc ,hwnd)) + (,parent (get-widget ,tc (cffi:make-pointer ,lparam)))) + (unless (or (null ,parent) (null ,child)) + (let ((,ancestor-hwnd (gfs::get-ancestor (gfs:handle ,child) gfs::+ga-parent+)) + (,tmp-list (child-visitor-results ,tc))) + (if (cffi:pointer-eq (gfs:handle ,parent) ,ancestor-hwnd) + (setf (child-visitor-results ,tc) (push (call-child-visitor-func ,tc ,parent ,child) ,tmp-list))))))))) + #+lispworks (fli:define-foreign-callable ("child_window_visitor" :result-type :integer :calling-convention :stdcall) ((hwnd :pointer) (lparam :long)) - (let* ((tc (thread-context)) - (child (get-widget tc hwnd)) - (parent (get-widget tc (cffi:make-pointer lparam)))) - (unless (or (null parent) (null child)) - (call-child-visitor-func tc parent child))) + (child-visitor-proper hwnd lparam) 1) #+clisp (defun child_window_visitor (hwnd lparam) - (let* ((tc (thread-context)) - (child (get-widget tc hwnd)) - (parent (get-widget tc (cffi:make-pointer lparam)))) - (unless (or (null child) (null parent)) - (call-child-visitor-func tc parent child))) + (child-visitor-proper hwnd lparam) 1) -(defun mapchildren (win func) - ;; - ;; supplied closure should expect two parameters: - ;; parent window object - ;; current child widget - ;; - (let ((tc (thread-context))) - (setf (child-visitor-func tc) func) - (unwind-protect -#+lispworks (gfs::enum-child-windows (fli:make-pointer :address (cffi:pointer-address (gfs:handle win))) - (fli:make-pointer :symbol-name "child_window_visitor") - (cffi:pointer-address (gfs:handle win))) -#+clisp (let ((ptr (ffi:foreign-pointer (ffi:unsigned-foreign-address 0)))) - (setf ptr (ffi:set-foreign-pointer - (ffi:unsigned-foreign-address - (cffi:pointer-address (gfs:handle win))) - ptr)) - (gfs::enum-child-windows ptr - #'child_window_visitor - (cffi:pointer-address (gfs:handle win)))) - (setf (child-visitor-func tc) nil)) - (let ((tmp (reverse (child-visitor-results tc)))) - (setf (child-visitor-results tc) nil) - tmp))) - (defun register-window-class (class-name proc-ptr style bkgcolor &optional wndextra) (let ((retval 0)) (cffi:with-foreign-string (str-ptr class-name) @@ -153,17 +136,6 @@ (defun release-mouse () (gfs::release-capture)) -(eval-when (:compile-toplevel :load-toplevel :execute) - (defmacro with-children ((win var) &body body) - (let ((hwnd (gensym))) - `(let ((,var (mapchildren ,win (lambda (parent child) - (let ((,hwnd (gfs::get-ancestor - (gfs:handle child) - gfs::+ga-parent+))) - (if (cffi:pointer-eq (gfs:handle parent) ,hwnd) - (push child (child-visitor-results (thread-context))))))))) - ,@body)))) - ;;; ;;; methods ;;; @@ -242,6 +214,28 @@ (let ((sz (client-size self))) (perform (layout-of self) self (gfs:size-width sz) (gfs:size-height sz))))) +(defmethod mapchildren ((self window) func) + (let ((tc (thread-context))) + (setf (child-visitor-func tc) func) + (unwind-protect +#+lispworks + (gfs::enum-child-windows (fli:make-pointer :address (cffi:pointer-address (gfs:handle self))) + (fli:make-pointer :symbol-name "child_window_visitor") + (cffi:pointer-address (gfs:handle self))) +#+clisp + (let ((ptr (ffi:foreign-pointer (ffi:unsigned-foreign-address 0)))) + (setf ptr (ffi:set-foreign-pointer + (ffi:unsigned-foreign-address + (cffi:pointer-address (gfs:handle self))) + ptr)) + (gfs::enum-child-windows ptr + #'child_window_visitor + (cffi:pointer-address (gfs:handle self)))) + (setf (child-visitor-func tc) nil)) + (let ((tmp (reverse (child-visitor-results tc)))) + (setf (child-visitor-results tc) nil) + tmp))) + (defmethod (setf maximum-size) :after (max-size (self window)) (unless (or (gfs:disposed-p self) (null (layout-of self))) (let ((size (constrain-new-size max-size (size self) #'min)))

1 0

[graphic-forms-cvs] r175 - tags/release-0.4.0
by junrue＠common-lisp.net 03 Jul '06

03 Jul '06

Author: junrue Date: Mon Jul 3 19:32:35 2006 New Revision: 175 Added: tags/release-0.4.0/ - copied from r174, trunk/ Log: tagging the 0.4.0 release

1 0

[graphic-forms-cvs] r174 - trunk
by junrue＠common-lisp.net 03 Jul '06

03 Jul '06

Author: junrue Date: Mon Jul 3 19:22:32 2006 New Revision: 174 Added: trunk/NEWS.txt Modified: trunk/README.txt Log: more doc updates for 0.4.0 Added: trunk/NEWS.txt ============================================================================== --- (empty file) +++ trunk/NEWS.txt Mon Jul 3 19:22:32 2006 @@ -0,0 +1,97 @@ + +Release 0.4.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: + +. CFFI snapshot 060606 or later is required in order to benefit from a +bugfix for a problem when running on LispWorks where foreign structure +contents could be corrupted; the most obvious symptom of this was a +Win32 error encountered when attempting to create a window. + +. A new layout manager called `heap-layout' has been implemented. Its +purpose is to align all the children of a container in a single +Z-orderwise stack and allow the application to select which of the +children are top-most at any given time. This is useful when +implemnenting windows with panels containing related functionality, +where only one such panel should be visible at a time (e.g., property +sheets or wizard dialogs). + +. This release provides access to the standard font dialog, and +integrates with the previously-defined font and font-data classes. + +. Application-defined modal and modeless dialogs are now fully +supported, including keyboard navigation (tab traversal, default +button invocation via the ENTER key, and cancel button invocation via +the ESC key). + +. In this release, the flow-layout manager gets a new style called +:normalize which instructs the manager to size children equally using +the maximum dimension of the children's preferred sizes opposite to +the dimension in which the layout is oriented. + +. Applications may set minimum size and/or maximum size constraints +for top-level windows. Setting both constraints to the same size +implicitly disables resizing by the user. + +. It is also possible to explicitly disable resizabilty, which not +only results in a fixed window size but also causes window decorations +to be updated appropriately (no maximize box and no resize handles in +the window frame). + +. The button class has been expanded to support checkboxes, radio +buttons, toggle buttons, and tri-state button controls. + +. There is now basic support for instantiating single-line and +multi-line edit controls. Edit controls participate in the focus gain +/ focus loss protocol; they also provide notification when contents +change via the event-modify generic function. + +. Implemented event-focus-gain and event-focus-loss to allow applications +to response to changes in focus. + +. It is now possible to customize the background color, foreground +color, and font of label controls. Infrastructure to support similar +customizations for other controls is in place. + +. Functions capture-mouse and release-mouse are available to implement +mouse capturing behavior. + +. Added a function to programmatically append separators to menus; +this was already possible via DEFMENU but not yet supported for +dynamic menu management. + +. Rewrote timer event processing such that the library no longer uses +the TimerProc callback technique, but instead each call to the Win32 +SetTimer function is made with the handle to a hidden utility window +managed by the library code. + +. Changed the rectangle type to be a structure; it was a class before. + +. Started work on infrastructure required to support a new layout +manager called `group-layout' which will appear in a subsequent +release. The infrastructure developed this time includes definition of +a text-baseline method that widgets implement to help layout managers +align text appropriately. + +. Also started work on infrastructure needed to enable WinXP-themed +controls. + +. Continued work on the UnBlocked demo game. + +The above list is in addition to documentation enhancements and +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.4.0.zip?download + +The project website is: +http://common-lisp.net/project/graphic-forms/ + +Jack Unrue +jdunrue (at) gmail (dot) com +July 3rd 2006 + +============================================================================== Modified: trunk/README.txt ============================================================================== --- trunk/README.txt (original) +++ trunk/README.txt Mon Jul 3 19:22:32 2006 @@ -18,7 +18,7 @@ - Cells http://common-lisp.net/project/cells/ - - CFFI 0.9.0 + - CFFI (cffi-060606 or later) http://common-lisp.net/project/cffi/ - lw-compat @@ -62,9 +62,9 @@ display properly, expecially when a transparency is selected. 3. The src/demos/unblocked directory contains a start at a demo - program (a simple game where one clicks on block shapes to - score points, where the rest of the blocks fall down to fill - in the gaps). This demo program is not yet finished, but the + 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

1 0

[graphic-forms-cvs] r173 - in trunk/docs: manual website
by junrue＠common-lisp.net 03 Jul '06

03 Jul '06

Author: junrue Date: Mon Jul 3 14:40:32 2006 New Revision: 173 Added: trunk/docs/website/gradient.png (contents, props changed) Modified: trunk/docs/manual/overview.texinfo trunk/docs/website/index.html trunk/docs/website/style.css Log: doc update in preparation for 0.4.0 release Modified: trunk/docs/manual/overview.texinfo ============================================================================== --- trunk/docs/manual/overview.texinfo (original) +++ trunk/docs/manual/overview.texinfo Mon Jul 3 14:40:32 2006 @@ -11,35 +11,26 @@ @chapter Overview Graphic-Forms is a user interface library implemented in Common Lisp -focusing on the Windows@registeredsymbol{} platform. Graphic-Forms is -licensed under the terms of the BSD License. +focusing on the Windows platform. Graphic-Forms is licensed under the +terms of the BSD License. -Graphic-Forms has two primary goals: - -@itemize @bullet -@item -in the short term, provide a toolkit encapsulating the underlying -window system primitives, custom controls and dialogs, and -platform-specific features - -@item -in the longer-term, implement an application framework on -top of the toolkit -- as an analogy, consider the relationship between -SWT and JFace in the Eclipse framework. -@end itemize - -Support for multiple Common Lisp implementations is planned; see the -project website for up-to-date information on supported vendors and -current known issues. - -Why implement another UI toolkit? The niche for Graphic-Forms is that -it emphasizes the use of Windows@registeredsymbol{} features without -comprising functionality due to portability constraints. Applications -that need portability across windowing systems are already served by -projects such as McCLIM and LTK in the open-source world or the -toolkits provided by commercial vendors. Or you might consider helping -new portable UI projects such as wxCL. This project is aimed -specifically at Windows@registeredsymbol{} developers. +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 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 +GUI developers focused on the Windows platform who want to leverage +platform features without compromises due to portability. + +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. The remainder of this chapter provides basic information for programmers that want to use Graphic-Forms in their projects as well @@ -50,9 +41,30 @@ changes unless and until the interfaces are deemed stable, at which time a policy for backwards compatibility will be published. -The main project website: @* + +@section Project Website + @url{http://common-lisp.net/project/graphic-forms} + +@section Supported Lisp Implementations + +Graphic-Forms is currently developed and tested with: + +@itemize @bullet +@item CLISP 2.38 +@item LispWorks 4.4.6 +@end itemize + + +@section Support Windows Versions + +@itemize @bullet +@item XP SP2 +@item Vista (testing on Beta 2 is in-progress as of this release) +@end itemize + + @section Dependencies The libraries that Graphic-Forms relies upon are: @@ -109,3 +121,10 @@ Please use the following patch tracking mechanism to contribute patches: @url{http://sourceforge.net/tracker/?group_id=163034&atid=826147} + + +@section Trademarks + +Windows@registeredsymbol{} is a registered trademark of Microsoft Corporation. +LispWorks is a trademark of LispWorks Ltd. All other trademarks used are owned +by their respective owners. Added: trunk/docs/website/gradient.png ============================================================================== Binary file. No diff available. Modified: trunk/docs/website/index.html ============================================================================== --- trunk/docs/website/index.html (original) +++ trunk/docs/website/index.html Mon Jul 3 14:40:32 2006 @@ -10,7 +10,7 @@ <body> <div class="header"> <h1>Graphic-Forms</h1> - <h2>A user interface toolkit for the Windows® platform.</h2> + <h2>A user interface toolkit for the Windows platform.</h2> </div> <div class="NavBar"> @@ -26,42 +26,51 @@ <p>Graphic-Forms is a user interface library implemented in <a href="http://www.lisp.org">Common Lisp</a> focusing on the - Windows® platform. Graphic-Forms is licensed under the + Windows platform. Graphic-Forms is licensed under the terms of the <a href="http://home.earthlink.net/~jdunrue/license.html">BSD License</a>.</p> - <p>In the near term, the goal - is to provide a toolkit encapsulating the underlying - window system primitives, also providing custom controls and dialogs, - and facilitating application use of platform-specific features. A - long-term goal is to implement an application framework on top of - the toolkit -- as an analogy, consider the relationship between SWT - and JFace in the <a href="http://www.eclipse.org">Eclipse</a> - framework. Support for multiple CL implementations is planned, - but at this time development is occurring on - <a href="http://clisp.cons.org">CLISP</a> and - <a href="http://www.lispworks.com">LispWorks</a>®.</p> - - <p>Why implement another UI toolkit? The niche for Graphic-Forms is - that it emphasizes the use of Windows® features without comprising - functionality due to portability constraints. Applications that need - portability across windowing systems are already served by projects - such as - <a href="http://common-lisp.net/project/mcclim/">McCLIM</a> - and - <a href="http://www.peter-herth.de/ltk/">LTK</a> - in the open-source world or the toolkits provided by commercial - vendors. Or you might consider helping new portable UI projects - such as <a href="http://www.wxcl-project.org">wxCL</a>. <i>This - project</i> is aimed specifically at Windows® developers.</p> + <p>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.</p> + <p>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 + <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 + developers focused on the Windows platform who want to leverage + platform features without compromises due to portability. + <p>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.</p> <h3>Status</h3> - <p>The current release is version 0.3.0.</p> + <p>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.</p> - <p>This library is in the early implementation stage. Brave souls who - experiment with the code should expect significant API and - behavior changes in the preliminary releases leading up to the 1.0 release.</p> + <p>The supported Lisp implementations are: + <ul> + <li><a href="http://clisp.cons.org/">CLISP 2.38</a></li> + <li><a href="http://www.lispworks.com/">LispWorks 4.4.6</a></li> + </ul> + + <p>The supported Windows versions are: + <ul> + <li>XP SP2</li> + <li>Vista <i>(in progress, testing on Beta 2 currently underway)</i></li> + </ul> <h3 id="mailinglists">Mailing Lists</h3> <ul> @@ -76,10 +85,15 @@ graphic-forms-announce</a><br>for announcements</li> </ul> - <div class="footer"> - <a class="footerleft" href="http://common-lisp.net">common-lisp.net home</a> - Copyright © 2006 by <a href="http://home.earthlink.net/~jdunrue/">Jack D. Unrue</a> - </div> + <p><b>Trademarks</b><br> + Windows® is a registered trademark of <a href="http://www.microsoft.com/">Microsoft</a>. + LispWorks is a trademark of <a href="http://www.lispworks.com/">LispWorks Ltd</a>. All other + trademarks used are owned by their respective owners.</p> + + <div class="footer"> + <a class="footerleft" href="http://common-lisp.net">common-lisp.net home</a> + Copyright © 2006 by <a href="http://home.earthlink.net/~jdunrue/">Jack D. Unrue</a> + </div> <!-- <a href="http://sourceforge.net"><IMG src="http://sourceforge.net/sflogo.php?group_id=20959" width="88" height="31" border="0" alt="SourceForge Logo"></a> Modified: trunk/docs/website/style.css ============================================================================== --- trunk/docs/website/style.css (original) +++ trunk/docs/website/style.css Mon Jul 3 14:40:32 2006 @@ -1,11 +1,10 @@ .header { font-size: medium; - background-color:#336699; - color:#ffffff; - border-style:solid; - border-width: 5px; - border-color:#002244; + color:#fafa00; + background-image: url("gradient.png"); + background-repeat: repeat-fixed; + background-attachment: fixed; padding: 1mm 1mm 1mm 5mm; } @@ -13,11 +12,10 @@ font-size: small; font-style: italic; text-align: right; - background-color:#336699; - color:#ffffff; - border-style:solid; - border-width: 2px; - border-color:#002244; + color:#fafa00; + background-image: url("gradient.png"); + background-repeat: repeat-fixed; + background-attachment: fixed; padding: 1mm 1mm 1mm 1mm; }

1 0

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

03 Jul '06

Author: junrue Date: Mon Jul 3 12:31:37 2006 New Revision: 172 Modified: trunk/README.txt trunk/docs/manual/api.texinfo trunk/src/uitoolkit/widgets/menu-language.lisp trunk/src/uitoolkit/widgets/menu.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp trunk/src/uitoolkit/widgets/widget-with-items.lisp Log: refactored menu item/submenu/separator convenience functions and fixed behavior of :disabled in menu language Modified: trunk/README.txt ============================================================================== --- trunk/README.txt (original) +++ trunk/README.txt Mon Jul 3 12:31:37 2006 @@ -61,18 +61,13 @@ has not been tested with all of them. Therefore, images may not display properly, expecially when a transparency is selected. -3. The event-tester application's menu definition specifies that the - Test Menu | Submenu | Item A item should be disabled but it does - not get disabled. However, the GFW:ENABLE function does otherwise - work correctly for menu items. - -4. The src/demos/unblocked directory contains a start at a demo +3. The src/demos/unblocked directory contains a start at a demo program (a simple game where one clicks on block shapes to score points, where 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. -5. The text-extent generic function currently does not return +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. Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Mon Jul 3 12:31:37 2006 @@ -939,9 +939,11 @@ Returns T if ancestor is an ancestor of descendant; nil otherwise. @end deffn -@deffn GenericFunction append-item self text image dispatcher -Adds the new item with the specified text to the object, and returns -the newly-created item. +@deffn GenericFunction append-item self text image dispatcher &optional disabled checked +Adds the new item with the specified @code{text}, @code{image}, and +@ref{event-dispatcher} to the object, and returns the newly-created item. +The optional @code{checked} and @code{disabled} arguments can be used +to set the item's initial state. @end deffn @deffn GenericFunction append-separator self @@ -949,8 +951,10 @@ item. @end deffn -@deffn GenericFunction append-submenu self text submenu dispatcher -Adds a submenu anchored to a parent menu and returns the corresponding item. +@deffn GenericFunction append-submenu self text submenu dispatcher &optional disabled checked +Adds a submenu anchored to a parent menu and returns the corresponding +menu item. The optional @code{checked} and @code{disabled} arguments can +be used to set the menu item's initial state. @end deffn @deffn GenericFunction cancel-widget self Modified: trunk/src/uitoolkit/widgets/menu-language.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu-language.lisp (original) +++ trunk/src/uitoolkit/widgets/menu-language.lisp Mon Jul 3 12:31:37 2006 @@ -196,21 +196,16 @@ (push m (menu-stack-of gen)))) (defmethod define-item ((gen win32-menu-generator) label dispatcher disabled checked image) - (let* ((owner (first (menu-stack-of gen))) - (item (append-item owner label image dispatcher))) - (enable item (not disabled)) - (check item checked))) + (append-item (first (menu-stack-of gen)) label image dispatcher disabled checked)) (defmethod define-separator ((gen win32-menu-generator)) (let ((owner (first (menu-stack-of gen)))) (append-separator owner))) (defmethod define-submenu ((gen win32-menu-generator) label dispatcher disabled) - (let* ((submenu (make-instance 'menu :handle (gfs::create-popup-menu))) - (parent (first (menu-stack-of gen))) - (item (append-submenu parent label submenu dispatcher))) - (push submenu (menu-stack-of gen)) - (enable item (not disabled)))) + (let ((submenu (make-instance 'menu :handle (gfs::create-popup-menu)))) + (append-submenu (first (menu-stack-of gen)) label submenu dispatcher disabled) + (push submenu (menu-stack-of gen)))) (defmethod complete-submenu ((gen win32-menu-generator)) (pop (menu-stack-of gen))) Modified: trunk/src/uitoolkit/widgets/menu.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu.lisp (original) +++ trunk/src/uitoolkit/widgets/menu.lisp Mon Jul 3 12:31:37 2006 @@ -37,8 +37,14 @@ ;;; helper functions ;;; -(defun insert-menuitem (hmenu mid label hbmp) - (cffi:with-foreign-string (str-ptr label) +(defun insert-menuitem (hmenu mid label hbmp hchildmenu disabled checked) + (declare (ignore hbmp)) ; FIXME: ignore hbmp until we support images in menu items + (let ((info-mask (logior gfs::+miim-id+ + (if label (logior gfs::+miim-state+ gfs::+miim-string+) gfs::+miim-ftype+) + (if hchildmenu gfs::+miim-submenu+))) + (info-type (if label 0 gfs::+mft-separator+)) + (info-state (logior (if checked gfs::+mfs-checked+ 0) + (if disabled gfs::+mfs-disabled+ 0)))) (cffi:with-foreign-object (mii-ptr 'gfs::menuiteminfo) (cffi:with-foreign-slots ((gfs::cbsize gfs::mask gfs::type gfs::state gfs::id gfs::hsubmenu @@ -46,69 +52,23 @@ gfs::idata gfs::tdata gfs::cch gfs::hbmpitem) mii-ptr gfs::menuiteminfo) - (setf gfs::cbsize (cffi:foreign-type-size 'gfs::menuiteminfo)) - (setf gfs::mask (logior gfs::+miim-id+ gfs::+miim-string+)) - (setf gfs::type 0) - (setf gfs::state 0) - (setf gfs::id mid) - (setf gfs::hsubmenu (cffi:null-pointer)) - (setf gfs::hbmpchecked (cffi:null-pointer)) - (setf gfs::hbmpunchecked (cffi:null-pointer)) - (setf gfs::idata 0) - (setf gfs::tdata str-ptr) - (setf gfs::cch (length label)) - (setf gfs::hbmpitem hbmp)) - (if (zerop (gfs::insert-menu-item hmenu #x7FFFFFFF 1 mii-ptr)) - (error 'gfs::win32-error :detail "insert-menu-item failed"))))) - -(defun insert-submenu (hparent mid label hbmp hchildmenu) - (cffi:with-foreign-string (str-ptr label) - (cffi:with-foreign-object (mii-ptr 'gfs::menuiteminfo) - (cffi:with-foreign-slots ((gfs::cbsize gfs::mask gfs::type - gfs::state gfs::id gfs::hsubmenu - gfs::hbmpchecked gfs::hbmpunchecked - gfs::idata gfs::tdata gfs::cch - gfs::hbmpitem) - mii-ptr gfs::menuiteminfo) - (setf gfs::cbsize (cffi:foreign-type-size 'gfs::menuiteminfo)) - (setf gfs::mask (logior gfs::+miim-id+ - gfs::+miim-string+ - gfs::+miim-submenu+)) - (setf gfs::type 0) - (setf gfs::state 0) - (setf gfs::id mid) - (setf gfs::hsubmenu hchildmenu) - (setf gfs::hbmpchecked (cffi:null-pointer)) - (setf gfs::hbmpunchecked (cffi:null-pointer)) - (setf gfs::idata 0) - (setf gfs::tdata str-ptr) - (setf gfs::cch (length label)) - (setf gfs::hbmpitem hbmp)) - (if (zerop (gfs::insert-menu-item hparent #x7FFFFFFF 1 mii-ptr)) - (error 'gfs::win32-error :detail "insert-menu-item failed"))))) - -(defun insert-separator (hmenu mid) - (cffi:with-foreign-object (mii-ptr 'gfs::menuiteminfo) - (cffi:with-foreign-slots ((gfs::cbsize gfs::mask gfs::type - gfs::state gfs::id gfs::hsubmenu - gfs::hbmpchecked gfs::hbmpunchecked - gfs::idata gfs::tdata gfs::cch - gfs::hbmpitem) - mii-ptr gfs::menuiteminfo) - (setf gfs::cbsize (cffi:foreign-type-size 'gfs::menuiteminfo)) - (setf gfs::mask (logior gfs::+miim-id+ gfs::+miim-ftype+)) - (setf gfs::type gfs::+mft-separator+) - (setf gfs::state 0) - (setf gfs::id mid) - (setf gfs::hsubmenu (cffi:null-pointer)) - (setf gfs::hbmpchecked (cffi:null-pointer)) - (setf gfs::hbmpunchecked (cffi:null-pointer)) - (setf gfs::idata 0) - (setf gfs::tdata (cffi:null-pointer)) - (setf gfs::cch 0) - (setf gfs::hbmpitem (cffi:null-pointer))) - (if (zerop (gfs::insert-menu-item hmenu #x7FFFFFFF 1 mii-ptr)) - (error 'gfs::win32-error :detail "insert-menu-item failed")))) + (setf gfs::cbsize (cffi:foreign-type-size 'gfs::menuiteminfo) + gfs::mask info-mask + gfs::type info-type + gfs::state info-state + gfs::id mid + gfs::hsubmenu hchildmenu + gfs::hbmpchecked (cffi:null-pointer) + gfs::hbmpunchecked (cffi:null-pointer) + gfs::idata 0 + gfs::tdata (cffi:null-pointer)) + (if label + (cffi:with-foreign-string (str-ptr label) + (setf gfs::tdata str-ptr) + (if (zerop (gfs::insert-menu-item hmenu #x7FFFFFFF 1 mii-ptr)) + (error 'gfs::win32-error :detail "insert-menu-item failed"))) + (if (zerop (gfs::insert-menu-item hmenu #x7FFFFFFF 1 mii-ptr)) + (error 'gfs::win32-error :detail "insert-menu-item failed"))))))) (defun sub-menu (m index) (if (gfs:disposed-p m) @@ -130,13 +90,13 @@ ;;; methods ;;; -(defmethod append-item ((owner menu) text image disp) +(defmethod append-item ((owner menu) text image disp &optional disabled checked) (declare (ignore image)) ; FIXME: temporary measure until we support images in menu items (let* ((tc (thread-context)) (id (increment-menuitem-id tc)) (hmenu (gfs:handle owner)) (item (create-menuitem-with-callback hmenu disp))) - (insert-menuitem hmenu id text (cffi:null-pointer)) + (insert-menuitem hmenu id text (cffi:null-pointer) (cffi:null-pointer) disabled checked) (setf (item-id item) id) (put-menuitem tc item) (vector-push-extend item (items owner)) @@ -149,13 +109,13 @@ (id (increment-menuitem-id tc)) (howner (gfs:handle owner)) (item (make-instance 'menu-item :handle howner))) - (insert-separator howner id) + (insert-menuitem howner id nil (cffi:null-pointer) (cffi:null-pointer) nil nil) (setf (item-id item) id) (put-menuitem tc item) (vector-push-extend item (items owner)) item)) -(defmethod append-submenu ((parent menu) text (submenu menu) disp) +(defmethod append-submenu ((parent menu) text (submenu menu) disp &optional disabled checked) (if (or (gfs:disposed-p parent) (gfs:disposed-p submenu)) (error 'gfs:disposed-error)) (let* ((tc (thread-context)) @@ -163,7 +123,7 @@ (hparent (gfs:handle parent)) (hmenu (gfs:handle submenu)) (item (make-instance 'menu-item :handle hparent))) - (insert-submenu hparent id text (cffi:null-pointer) hmenu) + (insert-menuitem hparent id text (cffi:null-pointer) hmenu disabled checked) (setf (item-id item) id) (put-menuitem tc item) (vector-push-extend item (items parent)) Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Mon Jul 3 12:31:37 2006 @@ -45,13 +45,13 @@ (defgeneric ancestor-p (ancestor descendant) (:documentation "Returns T if ancestor is an ancestor of descendant; nil otherwise.")) -(defgeneric append-item (self text image dispatcher) +(defgeneric append-item (self text image dispatcher &optional checked disabled) (:documentation "Adds the new item with the specified text to the object, and returns the newly-created item.")) (defgeneric append-separator (self) (:documentation "Add a separator item to the object, and returns the newly-created item.")) -(defgeneric append-submenu (self text submenu dispatcher) +(defgeneric append-submenu (self text submenu dispatcher &optional checked disabled) (:documentation "Adds a submenu anchored to a parent menu and returns the corresponding item.")) (defgeneric border-width (self) Modified: trunk/src/uitoolkit/widgets/widget-with-items.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-with-items.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-with-items.lisp Mon Jul 3 12:31:37 2006 @@ -33,8 +33,8 @@ (in-package :graphic-forms.uitoolkit.widgets) -(defmethod append-item :before ((w widget-with-items) text (image gfg:image) (disp event-dispatcher)) - (declare (ignore text image disp)) +(defmethod append-item :before ((w widget-with-items) text (image gfg:image) (disp event-dispatcher) &optional checked disabled) + (declare (ignore text image disp checked disabled)) (if (gfs:disposed-p w) (error 'gfs:disposed-error)))

1 0

[graphic-forms-cvs] r171 - trunk/src/demos/unblocked
by junrue＠common-lisp.net 03 Jul '06

03 Jul '06

Author: junrue Date: Mon Jul 3 01:25:20 2006 New Revision: 171 Modified: trunk/src/demos/unblocked/about.bmp Log: finished unblocked about dialog image Modified: trunk/src/demos/unblocked/about.bmp ============================================================================== Binary files. No diff available.

1 0

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

03 Jul '06

Author: junrue Date: Sun Jul 2 23:54:05 2006 New Revision: 170 Modified: trunk/docs/manual/api.texinfo trunk/src/demos/unblocked/unblocked-window.lisp trunk/src/packages.lisp trunk/src/uitoolkit/system/datastructs.lisp trunk/src/uitoolkit/widgets/top-level.lisp trunk/src/uitoolkit/widgets/widget.lisp Log: implemented resizable-p, refactored minimum-size/maximum-size methods for top-level windows Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Sun Jul 2 23:54:05 2006 @@ -1221,6 +1221,16 @@ @xref{capture-mouse}. @end deffn +@anchor{resizable-p} +@deffn GenericFunction resizable-p self => boolean +Returns T if @code{self} can be resized by the user; @sc{nil} +otherwise. The corresponding @sc{setf} function is implemented for +the @ref{top-level} class (but only has meaning when the @code{:frame} +or @code{:workspace} styles are set), allowing the application to +modify the resizability of @code{self}, whereupon the frame +decorations are modified appropriately. +@end deffn + @anchor{show} @deffn GenericFunction show self flag Causes the object to be visible or hidden on the screen, but not Modified: trunk/src/demos/unblocked/unblocked-window.lisp ============================================================================== --- trunk/src/demos/unblocked/unblocked-window.lisp (original) +++ trunk/src/demos/unblocked/unblocked-window.lisp Sun Jul 2 23:54:05 2006 @@ -201,9 +201,12 @@ :dispatcher (make-instance 'tiles-panel-events :buffer-size tile-buffer-size))) (setf (gfw:text *unblocked-win*) "Graphic-Forms 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)) + (new-unblocked nil nil nil nil) (gfw:show *unblocked-win* t))) Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Sun Jul 2 23:54:05 2006 @@ -65,6 +65,7 @@ #:detail #:dispose #:disposed-p + #:equal-size-p #:flatten #:handle #:location Modified: trunk/src/uitoolkit/system/datastructs.lisp ============================================================================== --- trunk/src/uitoolkit/system/datastructs.lisp (original) +++ trunk/src/uitoolkit/system/datastructs.lisp Sun Jul 2 23:54:05 2006 @@ -46,3 +46,7 @@ (defmacro size (rect) `(rectangle-size ,rect)) + +(defun equal-size-p (size1 size2) + (and (= (size-width size1) (size-width size2)) + (= (size-height size1) (size-height size2)))) Modified: trunk/src/uitoolkit/widgets/top-level.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/top-level.lisp (original) +++ trunk/src/uitoolkit/widgets/top-level.lisp Sun Jul 2 23:54:05 2006 @@ -51,6 +51,24 @@ gfs::+cs-dblclks+ -1)) +(defun update-top-level-resizability (win same-size-flag) + (let* ((hwnd (gfs:handle win)) + (orig-flags (gfs::get-window-long hwnd gfs::+gwl-style+)) + (new-flags 0)) + (cond + (same-size-flag + (setf new-flags (logand orig-flags (lognot gfs::+ws-maximizebox+))) + (setf new-flags (logand new-flags (lognot gfs::+ws-thickframe+)))) + (t + (setf new-flags (logior orig-flags gfs::+ws-maximizebox+)) + (setf new-flags (logior new-flags gfs::+ws-thickframe+)))) + (when (/= orig-flags new-flags) + (gfs::set-window-long hwnd gfs::+gwl-style+ new-flags) + (gfs::set-window-pos hwnd (cffi:null-pointer) 0 0 0 0 (logior gfs::+swp-framechanged+ + gfs::+swp-nomove+ + gfs::+swp-nosize+ + gfs::+swp-nozorder+))))) + ;;; ;;; methods ;;; @@ -132,6 +150,10 @@ (setf register-func #'register-toplevel-erasebkgnd-window-class)) (init-window win classname register-func owner text))) +(defmethod (setf maximum-size) :after (max-size (self top-level)) + (when (and max-size (minimum-size self)) + (update-top-level-resizability self (gfs:equal-size-p (minimum-size self) max-size)))) + (defmethod menu-bar :before ((win top-level)) (if (gfs:disposed-p win) (error 'gfs:disposed-error))) @@ -161,6 +183,10 @@ (gfs::set-menu hwnd (gfs:handle m)) (gfs::draw-menu-bar hwnd))) +(defmethod (setf minimum-size) :after (min-size (self top-level)) + (when (and (maximum-size self) min-size) + (update-top-level-resizability self (gfs:equal-size-p min-size (maximum-size self))))) + (defmethod print-object ((self top-level) stream) (print-unreadable-object (self stream :type t) (format stream "handle: ~x " (gfs:handle self)) @@ -169,17 +195,26 @@ (format stream "min size: ~a " (minimum-size self)) (format stream "max size: ~a" (maximum-size self)))) -(defmethod text :before ((win top-level)) - (if (gfs:disposed-p win) +(defmethod resizable-p ((self top-level)) + (let ((bits (gfs::get-window-long (gfs:handle self) gfs::+gwl-style+))) + (= (logand bits gfs::+ws-thickframe+) gfs::+ws-thickframe+))) + +(defmethod (setf resizable-p) (flag (self top-level)) + (let ((style (style-of self))) + (if (or (find :frame style) (find :workspace style)) + (update-top-level-resizability self (not flag))))) + +(defmethod text :before ((self top-level)) + (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod text ((win top-level)) - (get-widget-text win)) +(defmethod text ((self top-level)) + (get-widget-text self)) -(defmethod (setf text) :before (str (win top-level)) +(defmethod (setf text) :before (str (self top-level)) (declare (ignore str)) - (if (gfs:disposed-p win) + (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod (setf text) (str (win top-level)) - (set-widget-text win str)) +(defmethod (setf text) (str (self top-level)) + (set-widget-text self str)) Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Sun Jul 2 23:54:05 2006 @@ -246,39 +246,46 @@ (format stream "handle: ~x " (gfs:handle self)) (format stream "dispatcher: ~a " (dispatcher self)))) -(defmethod redraw :before ((w widget)) - (if (gfs:disposed-p w) +(defmethod redraw :before ((self widget)) + (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod redraw ((w widget)) - (let ((hwnd (gfs:handle w))) +(defmethod redraw ((self widget)) + (let ((hwnd (gfs:handle self))) (unless (gfs:null-handle-p hwnd) (gfs::invalidate-rect hwnd nil 1)))) -(defmethod selected-p :before ((w widget)) - (if (gfs:disposed-p w) +(defmethod resizable-p :before ((self widget)) + (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod selected-p ((w widget)) - (declare (ignore w)) +(defmethod resizable-p ((self widget)) nil) -(defmethod size :before ((w widget)) - (if (gfs:disposed-p w) +(defmethod selected-p :before ((self widget)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + +(defmethod selected-p ((self widget)) + (declare (ignore self)) + nil) + +(defmethod size :before ((self widget)) + (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod size ((w widget)) - (client-size w)) +(defmethod size ((self widget)) + (client-size self)) -(defmethod (setf size) :before ((size gfs:size) (w widget)) +(defmethod (setf size) :before ((size gfs:size) (self widget)) (declare (ignore size)) - (if (gfs:disposed-p w) + (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod (setf size) ((size gfs:size) (w widget)) - (if (gfs:disposed-p w) +(defmethod (setf size) ((size gfs:size) (self widget)) + (if (gfs:disposed-p self) (error 'gfs:disposed-error)) - (if (zerop (gfs::set-window-pos (gfs:handle w) + (if (zerop (gfs::set-window-pos (gfs:handle self) (cffi:null-pointer) 0 0 (gfs:size-width size) @@ -287,13 +294,13 @@ (error 'gfs:win32-error :detail "set-window-pos failed")) size) -(defmethod show :before ((w widget) flag) +(defmethod show :before ((self widget) flag) (declare (ignore flag)) - (if (gfs:disposed-p w) + (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod show ((w widget) flag) - (gfs::show-window (gfs:handle w) (if flag gfs::+sw-shownormal+ gfs::+sw-hide+))) +(defmethod show ((self widget) flag) + (gfs::show-window (gfs:handle self) (if flag gfs::+sw-shownormal+ gfs::+sw-hide+))) (defmethod text-baseline :before ((self widget)) (if (gfs:disposed-p self)

1 0

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

03 Jul '06

Author: junrue Date: Sun Jul 2 21:08:12 2006 New Revision: 169 Modified: trunk/docs/manual/api.texinfo trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/widgets/dialog.lisp trunk/src/uitoolkit/widgets/thread-context.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp trunk/src/uitoolkit/widgets/window.lisp Log: implemented keyboard navigation for windows and modeless dialogs Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Sun Jul 2 21:08:12 2006 @@ -679,31 +679,37 @@ boundaries of the window. @end deffn @deffn Initarg :style -The :style initarg is a list of keywords that define the overall +The @code{:style} initarg is a list of keywords that define the overall look-and-feel of the window being created. Applications may choose -from one of the following primary style keywords: +from one of the following primary styles: @table @code @item :borderless -a window with a one-pixel border (so not really @emph{borderless} in the -strictest sense); no frame icon, system menu, minimize/maximize buttons, -or close buttons; the system does not paint the background +Specifies a window with a one-pixel border (so not really @emph{borderless} +in the strictest sense); no frame icon, system menu, minimize/maximize +buttons, or close buttons; the system does not paint the background. @item :frame -the standard top-level frame style with system menu, close box, and -minimize/maximize buttons; this window type is resizable; it differs +Specifies the standard top-level frame style with system menu, close box, +and minimize/maximize buttons; this window type is resizable; it differs from the @code{:workspace} style in that the application is completely -responsible for painting the contents +responsible for painting the contents. @item :miniframe -a resizable window with a shorter than normal caption; has a close box -but no system menu or minimize/maximize buttons; the system does not -paint the background +Specifies a resizable window with a shorter than normal caption; has a +close box but no system menu or minimize/maximize buttons; the system +does not paint the background. @item :palette -similar to the @code{:miniframe} style, but in this case the window -does not have a resize frame; the system does not paint the background +Similar to the @code{:miniframe} style, except that this style also +restricts the window from having a resize frame. @item :workspace -the standard top-level frame style with system menu, close box, and -minimize/maximize buttons; this window type is resizable; it differs +Specifies the standard top-level frame style with system menu, close box, +and minimize/maximize buttons; this window type is resizable; it differs from the @code{:frame} style in that the system paints the background -using the @sc{color_appworkspace} color scheme +using the @sc{color_appworkspace} Win32 color scheme. +@end table +The following style keyword(s) may also be included: +@table @code +@item :keyboard-navigation +Enables keyboard traversal of controls within the @code{window} as if +it were a @ref{dialog}. @end table @end deffn @end deftp @@ -716,8 +722,8 @@ behavior of the widget; style keywords are widget-specific. @end deftp -@anchor{widget-with-items} items -@deftp Class widget-with-items +@anchor{widget-with-items} +@deftp Class widget-with-items items The widget-with-items class is the base class for objects composed of sub-items. It derives from @ref{widget}. The @code{items} slot is an @sc{adjustable} @sc{vector} containing @ref{item} objects, @@ -725,13 +731,27 @@ @end deftp @anchor{window} -@deftp Class window +@deftp Class window layout-p layout maximum-size minimum-size This is the base class for user-defined @ref{widget}s that serve as containers. -@deffn Reader layout-p +@deffn Accessor layout-of +Accepts or returns the @ref{layout-manager} associated with this +@code{window}. +@end deffn +@deffn Accessor maximum-size +@end deffn +@deffn Accessor minimum-size @end deffn @deffn Initarg :layout +Accepts a @ref{layout-manager} object whose responsibility is to manage +the direct children of this @code{window}. @end deffn -@deffn Accessor layout-of +@deffn Reader layout-p => boolean +Returns T if layout behavior is enabled for the @code{window}; +@sc{nil} otherwise. +@end deffn +@deffn Initarg :maximum-size +@end deffn +@deffn Initarg :minimum-size @end deffn @end deftp Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Sun Jul 2 21:08:12 2006 @@ -127,7 +127,7 @@ (defconstant +ccerr-choosecolorcodes+ #x5000) -(defconstant +cderr-dialogfailure+ #xffff) +(defconstant +cderr-dialogfailure+ #xFFFF) (defconstant +cderr-generalcodes+ #x0000) (defconstant +cderr-structsize+ #x0001) (defconstant +cderr-initialization+ #x0002) @@ -138,8 +138,8 @@ (defconstant +cderr-loadresfailure+ #x0007) (defconstant +cderr-lockresfailure+ #x0008) (defconstant +cderr-memallocfailure+ #x0009) -(defconstant +cderr-memlockfailure+ #x000a) -(defconstant +cderr-nohook+ #x000b) +(defconstant +cderr-memlockfailure+ #x000A) +(defconstant +cderr-nohook+ #x000B) (defconstant +cderr-registermsgfail+ #x000C) (defconstant +cf-screenfonts+ #x00000001) Modified: trunk/src/uitoolkit/widgets/dialog.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/dialog.lisp (original) +++ trunk/src/uitoolkit/widgets/dialog.lisp Sun Jul 2 21:08:12 2006 @@ -168,6 +168,7 @@ ;; (if (cffi:pointer-eq (gfs:handle owner) (gfs::get-desktop-window)) (setf owner nil)) + (push :keyboard-navigation (style-of self)) ;; FIXME: check if owner is actually a top-level or dialog, and if not, ;; walk up the ancestors until one is found. Only top level hwnds can ;; be owners. Modified: trunk/src/uitoolkit/widgets/thread-context.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/thread-context.lisp (original) +++ trunk/src/uitoolkit/widgets/thread-context.lisp Sun Jul 2 21:08:12 2006 @@ -50,6 +50,7 @@ (next-widget-id :initform 100 :reader next-widget-id) (size-event-size :initform (gfs:make-size) :accessor size-event-size) (widgets-by-hwnd :initform (make-hash-table :test #'equal)) + (kbdnav-widgets :initform nil :accessor kbdnav-widgets) (timers-by-id :initform (make-hash-table :test #'equal)) (top-level-visitor-func :initform nil :accessor top-level-visitor-func) (top-level-visitor-results :initform nil :accessor top-level-visitor-results) @@ -149,6 +150,31 @@ "Store the widget currently under construction." (setf (slot-value tc 'wip) nil)) +(defmethod put-kbdnav-widget ((tc thread-context) (widget widget)) + (if (find :keyboard-navigation (style-of widget)) + (setf (kbdnav-widgets tc) (push widget (kbdnav-widgets tc))))) + +(defmethod remove-kbdnav-widget ((tc thread-context) (widget widget)) + (setf (kbdnav-widgets tc) + (remove-if (lambda (hwnd) (cffi:pointer-eq (gfs:handle widget) hwnd)) + (kbdnav-widgets tc) + :key #'gfs:handle))) + +(defmethod intercept-kbdnav-message ((tc thread-context) msg-ptr) + (let ((widgets (kbdnav-widgets tc))) + (unless widgets + (return-from intercept-kbdnav-message nil)) + (let ((widget (first widgets))) + (if (/= (gfs::is-dialog-message (gfs:handle widget) msg-ptr) 0) + (return-from intercept-kbdnav-message widget)) + (setf widget (find-if (lambda (w) (/= (gfs::is-dialog-message (gfs:handle w) msg-ptr))) + (rest widgets))) + (when (and widget (/= (gfs::is-dialog-message (gfs:handle widget) msg-ptr) 0)) + (let ((tmp (remove-kbdnav-widget tc widget))) + (setf (kbdnav-widgets tc) (push widget tmp))) + (return-from intercept-kbdnav-message widget)))) + nil) + (defmethod get-menuitem ((tc thread-context) id) "Returns the menu item identified by id." (gethash id (slot-value tc 'menuitems-by-id))) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Sun Jul 2 21:08:12 2006 @@ -81,7 +81,7 @@ (defclass widget (event-source) ((style - :reader style-of + :accessor style-of :initarg :style :initform nil)) (:documentation "The widget class is the base class for all windowed user interface objects.")) Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Sun Jul 2 21:08:12 2006 @@ -48,6 +48,8 @@ ((= gm-code -1) (warn 'gfs:win32-warning :detail "get-message failed") t) + ((intercept-kbdnav-message (thread-context) msg-ptr) + nil) (t (translate-and-dispatch msg-ptr) nil))) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Sun Jul 2 21:08:12 2006 @@ -57,6 +57,8 @@ (let ((hwnd (gfs:handle win))) (if (not hwnd) ; handle slot should have been set during create-window (error 'gfs:win32-error :detail "create-window failed")) + (if (find :keyboard-navigation (style-of win)) + (put-kbdnav-widget tc win)) (put-widget tc win)))) #+lispworks @@ -191,6 +193,10 @@ (gfs:size-height new-size) (- gfs::bottom gfs::top))) new-size)) +(defmethod gfs:dispose ((self window)) + (remove-kbdnav-widget (thread-context) self) + (call-next-method)) + (defmethod enable-layout :before ((win window) flag) (declare (ignore flag)) (if (gfs:disposed-p win)

1 0

[graphic-forms-cvs] r168 - in trunk: . docs/manual src src/tests/uitoolkit src/uitoolkit/graphics src/uitoolkit/system src/uitoolkit/widgets
by junrue＠common-lisp.net 02 Jul '06

02 Jul '06

Author: junrue Date: Sun Jul 2 14:32:26 2006 New Revision: 168 Added: trunk/src/uitoolkit/widgets/font-dialog.lisp Modified: trunk/docs/manual/api.texinfo trunk/graphic-forms-uitoolkit.asd trunk/src/packages.lisp trunk/src/tests/uitoolkit/image-unit-tests.lisp trunk/src/tests/uitoolkit/windlg.lisp trunk/src/uitoolkit/graphics/font-data.lisp trunk/src/uitoolkit/graphics/font.lisp trunk/src/uitoolkit/graphics/graphics-generics.lisp trunk/src/uitoolkit/graphics/image.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/widget-classes.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp Log: implemented font-dialog, refactored font-data and font classes, implemented show-common-dialog to centralize system dialog invocation Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Sun Jul 2 14:32:26 2006 @@ -377,18 +377,17 @@ @end itemize The @ref{with-file-dialog} macro wraps the creation of a @code{file-dialog} and subsequent retrieval of the file paths selected -by the user. However, applications may choose to implements these +by the user. However, applications may choose to implement these steps manually, in which case the @ref{file-dialog-paths} function can be used to obtain the user's selection(s). Unless the @code{:multiple-select} style keyword is specified, there will at most be one selected file returned. In either case, zero is returned if the -user cancelled the dialog. Also, manual construction of an instance +user cancelled the dialog. Manual construction of an instance must be followed by an explicit call to @ref{dispose}.@*@* -Like other system dialogs, @code{file-dialog} is derived from @ref{widget} -rather than @ref{dialog} since the majority of its functionality is -implemented by the system and is not directly extensible by applications. -@strong{NOTE:} A future release of Graphic-Forms will provide a -customization mechanism.@*@* +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 +future release will provide a customization mechanism.@*@* @deffn Initarg :default-extension Specifies a default extension to be appended to a file name if the user fails to provide one. Any embedded periods @samp{.} will @@ -424,8 +423,7 @@ @end deffn @deffn Initarg :owner A value is required for this initarg, and it may be either a -@ref{window} or a @ref{dialog}. The file dialog will remain above the -specified @code{owner} in the window system Z-order. +@ref{window} or a @ref{dialog}. @end deffn @deffn Initarg :style This initarg accepts a list of keyword symbols, as follows: @@ -448,7 +446,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. @@ -462,8 +460,73 @@ @end deffn @end deftp +@anchor{font-dialog} +@deftp Class font-dialog +This class provides a standard dialog for choosing attributes +of a @ref{font}, either from scratch or relative to an existing font. +A variety of style options may be selected, including strikeout +and font color.@*@* +The @ref{with-font-dialog} macro wraps the creation of a @code{font-dialog} +and provides a new font object based on the user's selections. However, +applications may choose to implement these steps manually, in which case +the @ref{font-dialog-results} function can be called to obtain the results +of the user's selections. Manual construction of an instance must be followed +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 +will provide a customization mechanism.@* +@deffn Initarg :gc +This required initarg accepts a @ref{graphics-context} object providing +context for the font selection, such as when the set of fonts to be offered +depends on a printer device. +@end deffn +@deffn Initarg :initial-color +This initarg accepts a @ref{color} object which the font dialog +will use for its initial color selection (as long as the @code{:no-effects} +style is @strong{not} set). +@end deffn +@deffn Initarg :initial-font +This initarg accepts a @ref{font} object which the font dialog +will use for its initial font attribute selections. If not +specified, the dialog will be set to the system font's attributes. +@end deffn +@deffn Initarg :owner +A value is required for this initarg, and it may be either a +@ref{window} or a @ref{dialog}. +@end deffn +@deffn Initarg :style +This initarg accepts a list of keyword symbols, as follows: +@table @code +@item :all-fonts +This is a convenience style, used by default if no other font +criteria are specified, that enables the dialog to offer all +possible fonts. +@item :fixed-pitch-fonts +Enables the dialog to offer fixed pitch fonts. +@item :no-effects +Causes the font dialog to hide the controls that +allow the user to specify strikeout, underline, and text color +attributes. +@item :printer-fonts +Enables the dialog to offer fonts supported by the printer associated +with the graphics-context supplied via the @code{:gc} initarg. +@item :screen-fonts +Enables the dialog to offer screen fonts supported by the system. +@item :truetype-fonts +Enables the dialog to offer TrueType fonts. +@item :wysiwyg-fonts +Enables the dialog to offer the intersection of the sets of fonts +available on the screen and the printer associated with the +graphics-context specified by the @code{:gc} initarg. +@end table +@end deffn +@end deftp + @anchor{group} @deftp Class group layout children location size style +@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 and behaviors: @@ -970,11 +1033,12 @@ @end deffn @anchor{file-dialog-paths} -@deffn Function file-dialog-paths dlg +@deffn Function 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. +of file @sc{namestring}s. Use this function when manually constructing +a file dialog. @xref{with-file-dialog}. @end deffn @deffn GenericFunction focus-p self @@ -982,6 +1046,19 @@ otherwise. @end deffn +@anchor{font-dialog-results} +@deffn Function 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 +them via @sc{values}. The @code{gc} parameter should be the same +@ref{graphics-context} object with which the dialog was created. +If the user cancelled the dialog, the font value will be @sc{nil}. +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 + @deffn GenericFunction give-focus self Places keyboard focus on @code{self}. @end deffn @@ -1173,8 +1250,18 @@ @anchor{with-file-dialog} @deffn Macro with-file-dialog (owner style paths &key default-extension filters initial-directory initial-filename text) &body body This macro wraps the instantiation of a standard file open/save dialog -and the subsequent retrieval of the user's file -selections. @xref{file-dialog}. +and the subsequent retrieval of the user's file selections (supplied to @code{body} +via @code{paths}). @xref{file-dialog}. +@end deffn + +@anchor{with-font-dialog} +@deffn Macro with-font-dialog (owner style font color &key gc initial-color initial-font) &body body +This macro wraps the instantiation of a standard font dialog and binds +@code{font} to a font object, and @code{color} to a @ref{color} object, +corresponding to the attributes selected by the user. If the user cancels +the dialog, @code{font} will be @sc{nil}. In addition, @code{color} will also +be @sc{nil} if the dialog was created with the @code{:no-effects} style +keyword. @xref{font-dialog}. @end deffn @@ -1226,6 +1313,7 @@ @strong{NOTE:} A future release will provide additional graphics classes. +@anchor{color} @deftp Structure color red green blue This is a structure representing a color using three bytes in the RGB colorspace. @end deftp @@ -1304,6 +1392,7 @@ may use to position graphical elements. @xref{font}. @end deftp +@anchor{graphics-context} @deftp Class graphics-context This subclass of @ref{native-object} wraps a native device context, hence instances of this class are used to perform drawing operations. @@ -1425,8 +1514,11 @@ Returns a color object corresponding to the current background color. @end deffn -@deffn GenericFunction data-obj self -Returns the data structure representing the raw form of the object. +@deffn GenericFunction data-object self &optional gc => 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}. @end deffn @deffn GenericFunction depth self Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Sun Jul 2 14:32:26 2006 @@ -113,6 +113,7 @@ (: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 Sun Jul 2 14:32:26 2006 @@ -140,7 +140,7 @@ #:copy-color #:copy-font-data #:copy-font-metrics - #:data-obj + #:data-object #:depth #:descent #:draw-arc @@ -231,6 +231,7 @@ #:event-dispatcher #:event-source #:file-dialog + #:font-dialog #:flow-layout #:heap-layout #:item @@ -393,6 +394,7 @@ #:file-dialog-paths #:focus-index #:focus-p + #:font-dialog-results #:foreground-color #:give-focus #:grid-line-width @@ -492,6 +494,7 @@ #:visible-p #:with-children #:with-file-dialog + #:with-font-dialog ;; conditions )) Modified: trunk/src/tests/uitoolkit/image-unit-tests.lisp ============================================================================== --- trunk/src/tests/uitoolkit/image-unit-tests.lisp (original) +++ trunk/src/tests/uitoolkit/image-unit-tests.lisp Sun Jul 2 14:32:26 2006 @@ -58,7 +58,7 @@ (assert-equal (gfs:size-width size1) (gfs:size-width size2) path) (assert-equal (gfs:size-height size1) (gfs:size-height size2) path)) (gfg:load im path) - (setf d3 (gfg:data-obj im)) + (setf d3 (gfg:data-object im)) (assert-equal (gfg:depth d1) (gfg:depth d3) path) (let ((size1 (gfg:size d1)) (size2 (gfg:size d3))) Modified: trunk/src/tests/uitoolkit/windlg.lisp ============================================================================== --- trunk/src/tests/uitoolkit/windlg.lisp (original) +++ trunk/src/tests/uitoolkit/windlg.lisp Sun Jul 2 14:32:26 2006 @@ -118,6 +118,17 @@ :initial-directory #P"c:/") (print paths))) +(defun choose-font-dlg (disp item time rect) + (declare (ignore disp item time rect)) + (let ((gc (make-instance 'gfg:graphics-context :widget *main-win*))) + (unwind-protect + (gfw:with-font-dialog (*main-win* nil font color :gc gc) + (if color + (print color)) + (if font + (print (gfg:data-object font gc)))) + (gfs:dispose gc)))) + (defclass dialog-events (gfw:event-dispatcher) ()) (defmethod gfw:event-close ((disp dialog-events) (dlg gfw:dialog) time) @@ -231,16 +242,17 @@ :style '(:workspace))) (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))) (:item "&System Dialogs" - :submenu ((:item "&Open File" :callback #'open-file-dlg) - (:item "&Save File" :callback #'save-file-dlg))) - (:item "&User Dialogs" - :submenu ((:item "&Modal" :callback #'open-modal-dlg) - (:item "&Modeless" :callback #'open-modeless-dlg))) + :submenu ((: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) (gfw:show *main-win* t))) Modified: trunk/src/uitoolkit/graphics/font-data.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/font-data.lisp (original) +++ trunk/src/uitoolkit/graphics/font-data.lisp Sun Jul 2 14:32:26 2006 @@ -33,50 +33,99 @@ (in-package :graphic-forms.uitoolkit.graphics) -(defun compute-font-weight (style) - (if (null (find :bold style)) - gfs::+fw-normal+ - gfs::+fw-bold+)) - -(defun compute-font-precis (style) - (if (find :truetype-only style) - (return-from compute-font-precis gfs::+out-tt-only-precis+)) - (if (find :outline style) - (return-from compute-font-precis gfs::+out-outline-precis+)) - gfs::+out-default-precis+) - -(defun compute-font-pitch (style) - (if (find :fixed style) - (return-from compute-font-pitch gfs::+fixed-pitch+)) - (if (find :variable style) - (return-from compute-font-pitch gfs::+variable-pitch+)) - gfs::+default-pitch+) +(defun pntsize->lfheight (hdc pntsize) + (let ((log-height (gfs::get-device-caps hdc gfs::+logpixelsy+))) + (- (floor (+ (/ (* pntsize log-height) 72) 0.5))))) -(defun data->font (hdc data) - (let ((hfont (cffi:null-pointer)) +(defun lfheight->pntsize (hdc lfheight) + (let ((log-height (gfs::get-device-caps hdc gfs::+logpixelsy+))) + (floor (* (+ (- lfheight) 0.5) 72) log-height))) + +(defun style->logfont (style lf-ptr) + (cffi:with-foreign-slots ((gfs::lfweight gfs::lfitalic gfs::lfunderline + gfs::lfstrikeout gfs::lfoutprec gfs::lfpitchandfamily) + lf-ptr gfs::logfont) + (setf gfs::lfweight (if (find :bold style) gfs::+fw-bold+ gfs::+fw-normal+)) + (setf gfs::lfitalic (if (find :italic style) 1 0)) + (setf gfs::lfunderline (if (find :underline style) 1 0)) + (setf gfs::lfstrikeout (if (find :strikeout style) 1 0)) + (setf gfs::lfoutprec (cond + ((find :truetype-only style) gfs::+out-tt-only-precis+) + ((find :outline style) gfs::+out-outline-precis+) + (t gfs::+out-default-precis+))) + (setf gfs::lfpitchandfamily (cond + ((find :fixed style) gfs::+fixed-pitch+) + ((find :variable style) gfs::+variable-pitch+) + (t gfs::+default-pitch+))))) + +(defun logfont->style (lf-ptr) + (let ((style nil)) + (cffi:with-foreign-slots ((gfs::lfweight gfs::lfitalic gfs::lfunderline + gfs::lfstrikeout gfs::lfoutprec gfs::lfpitchandfamily) + lf-ptr gfs::logfont) + (if (= gfs::lfweight gfs::+fw-bold+) + (push :bold style)) + (unless (zerop gfs::lfitalic) + (push :italic style)) + (unless (zerop gfs::lfunderline) + (push :underline style)) + (unless (zerop gfs::lfstrikeout) + (push :strikeout style)) + (case gfs::lfoutprec + (#.gfs::+out-tt-only-precis+ (push :truetype-only style)) + (#.gfs::+out-outline-precis+ (push :outline style))) + (case gfs::lfpitchandfamily + (#.gfs::+fixed-pitch+ (push :fixed style)) + (#.gfs::+variable-pitch+ (push :variable style)))) + style)) + +(defun data->logfont (hdc data) + (let ((lf-ptr (cffi:foreign-alloc 'gfs::logfont)) (style (font-data-style data))) - (cffi:with-foreign-object (lf-ptr 'gfs::logfont) - (gfs:zero-mem lf-ptr gfs::logfont) - (cffi:with-foreign-slots ((gfs::lfheight gfs::lfweight gfs::lfitalic gfs::lfunderline - gfs::lfstrikeout gfs::lfcharset gfs::lfoutprec - gfs::lfpitchandfamily gfs::lffacename) - lf-ptr gfs::logfont) - (setf gfs::lfheight (- (floor (+ (/ (* (font-data-point-size data) - (gfs::get-device-caps hdc gfs::+logpixelsy+)) - 72) - 0.5)))) - (setf gfs::lfweight (compute-font-weight style)) - (setf gfs::lfitalic (if (null (find :italic style)) 0 1)) - (setf gfs::lfunderline (if (null (find :underline style)) 0 1)) - (setf gfs::lfstrikeout (if (null (find :strikeout style)) 0 1)) - (setf gfs::lfcharset (font-data-char-set data)) - (setf gfs::lfoutprec (compute-font-precis style)) - (setf gfs::lfpitchandfamily (compute-font-pitch style)) - (cffi:with-foreign-string (str (font-data-face-name data)) - (let ((lffacename-ptr (cffi:foreign-slot-pointer lf-ptr 'gfs::logfont 'gfs::lffacename))) - (gfs::strncpy lffacename-ptr str (1- gfs::+lf-facesize+)) - (setf (cffi:mem-aref lffacename-ptr :char (1- gfs::+lf-facesize+)) 0)))) - (setf hfont (gfs::create-font-indirect lf-ptr)) - (if (gfs:null-handle-p hfont) - (error 'gfs:win32-error :detail "create-font-indirect failed"))) + (gfs:zero-mem lf-ptr gfs::logfont) + (cffi:with-foreign-slots ((gfs::lfheight gfs::lfcharset gfs::lffacename) lf-ptr gfs::logfont) + (setf gfs::lfheight (pntsize->lfheight hdc (font-data-point-size data))) + (setf gfs::lfcharset (font-data-char-set data)) + (style->logfont style lf-ptr) + (cffi:with-foreign-string (str (font-data-face-name data)) + (let ((lffacename-ptr (cffi:foreign-slot-pointer lf-ptr 'gfs::logfont 'gfs::lffacename))) + (gfs::strncpy lffacename-ptr str (1- gfs::+lf-facesize+)) + (setf (cffi:mem-aref lffacename-ptr :char (1- gfs::+lf-facesize+)) 0)))) + lf-ptr)) + +(defun logfont->data (hdc lf-ptr) + (let ((char-set 0) + (face-name "") + (point-size 0) + (style nil)) + (cffi:with-foreign-slots ((gfs::lfheight gfs::lfcharset gfs::lffacename) lf-ptr gfs::logfont) + (setf point-size (lfheight->pntsize hdc gfs::lfheight)) + (setf char-set gfs::lfcharset) + (setf style (logfont->style lf-ptr)) + (let ((lffacename-ptr (cffi:foreign-slot-pointer lf-ptr 'gfs::logfont 'gfs::lffacename))) + (setf face-name (cffi:foreign-string-to-lisp lffacename-ptr)))) + (gfg:make-font-data :char-set char-set + :face-name face-name + :point-size point-size + :style style))) + +(defun data->font (hdc data) + (let ((hfont (cffi:null-pointer))) + (setf hfont (gfs::create-font-indirect (data->logfont hdc data))) + (if (gfs:null-handle-p hfont) + (error 'gfs:win32-error :detail "create-font-indirect failed")) hfont)) + +(defun font->data (hdc hfont) + (cffi:with-foreign-object (lf-ptr 'gfs::logfont) + (gfs:zero-mem lf-ptr gfs::logfont) + (if (zerop (gfs::get-object hfont (cffi:foreign-type-size 'gfs::logfont) lf-ptr)) + (error 'gfs:win32-error :detail "get-object failed")) + (logfont->data hdc lf-ptr))) + +(defmethod print-object ((self font-data) stream) + (print-unreadable-object (self stream :type t) + (format stream "face name: ~a " (font-data-face-name self)) + (format stream "point size: ~d " (font-data-point-size self)) + (format stream "style: ~a " (font-data-style self)) + (format stream "char-set: ~d" (font-data-char-set self)))) Modified: trunk/src/uitoolkit/graphics/font.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/font.lisp (original) +++ trunk/src/uitoolkit/graphics/font.lisp Sun Jul 2 14:32:26 2006 @@ -37,12 +37,17 @@ ;;; methods ;;; -(defmethod gfs:dispose ((fn font)) - (let ((hgdi (gfs:handle fn))) +(defmethod data-object ((self font) &optional gc) + (if (or (gfs:disposed-p self) (gfs:disposed-p gc)) + (error 'gfs:disposed-error)) + (font->data (gfs:handle gc) (gfs:handle self))) + +(defmethod gfs:dispose ((self font)) + (let ((hgdi (gfs:handle self))) (unless (gfs:null-handle-p hgdi) (gfs::delete-object hgdi))) - (setf (slot-value fn 'gfs:handle) nil)) + (setf (slot-value self 'gfs:handle) nil)) -(defmethod initialize-instance :after ((font font) &key gc data &allow-other-keys) +(defmethod initialize-instance :after ((self font) &key gc data &allow-other-keys) (if gc - (setf (slot-value font 'gfs:handle) (data->font (gfs:handle gc) data)))) + (setf (slot-value self 'gfs:handle) (data->font (gfs:handle gc) data)))) Modified: trunk/src/uitoolkit/graphics/graphics-generics.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-generics.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-generics.lisp Sun Jul 2 14:32:26 2006 @@ -36,7 +36,7 @@ (defgeneric background-color (self) (:documentation "Returns a color object corresponding to the current background color.")) -(defgeneric data-obj (self) +(defgeneric data-object (self &optional gc) (:documentation "Returns the data structure representing the raw form of the object.")) (defgeneric depth (self) Modified: trunk/src/uitoolkit/graphics/image.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/image.lisp (original) +++ trunk/src/uitoolkit/graphics/image.lisp Sun Jul 2 14:32:26 2006 @@ -72,15 +72,16 @@ (gfs::delete-object hgdi))) (setf (slot-value im 'gfs:handle) nil)) -(defmethod data-obj ((im image)) - (when (gfs:disposed-p im) +(defmethod data-object ((self image) &optional gc) + (declare (ignore gc)) + (when (gfs:disposed-p self) (error 'gfs:disposed-error)) - (image->data (gfs:handle im))) + (image->data (gfs:handle self))) -(defmethod (setf data-obj) ((id image-data) (im image)) - (unless (gfs:disposed-p im) - (gfs:dispose im)) - (setf (slot-value im 'gfs:handle) (data->image id))) +(defmethod (setf data-object) ((id image-data) (self image)) + (unless (gfs:disposed-p self) + (gfs:dispose self)) + (setf (slot-value self 'gfs:handle) (data->image id))) (defmethod initialize-instance :after ((image image) &key file size &allow-other-keys) (cond @@ -108,7 +109,7 @@ (defmethod load ((im image) path) (let ((data (make-instance 'image-data))) (load data path) - (setf (data-obj im) data) + (setf (data-object im) data) data)) (defmethod size ((image image)) Modified: trunk/src/uitoolkit/system/comdlg32.lisp ============================================================================== --- trunk/src/uitoolkit/system/comdlg32.lisp (original) +++ trunk/src/uitoolkit/system/comdlg32.lisp Sun Jul 2 14:32:26 2006 @@ -39,6 +39,11 @@ (load-foreign-library "comdlg32.dll") (defcfun + ("ChooseFontA" choose-font) + BOOL + (struct LPTR)) + +(defcfun ("CommDlgExtendedError" comm-dlg-extended-error) DWORD) Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Sun Jul 2 14:32:26 2006 @@ -142,6 +142,35 @@ (defconstant +cderr-nohook+ #x000b) (defconstant +cderr-registermsgfail+ #x000C) +(defconstant +cf-screenfonts+ #x00000001) +(defconstant +cf-printerfonts+ #x00000002) +(defconstant +cf-both+ #x00000003) +(defconstant +cf-showhelp+ #x00000004) +(defconstant +cf-enablehook+ #x00000008) +(defconstant +cf-enabletemplate+ #x00000010) +(defconstant +cf-enabletemplatehandle+ #x00000020) +(defconstant +cf-inittologfontstruct+ #x00000040) +(defconstant +cf-usestyle+ #x00000080) +(defconstant +cf-effects+ #x00000100) +(defconstant +cf-apply+ #x00000200) +(defconstant +cf-ansionly+ #x00000400) +(defconstant +cf-scriptsonly+ #x00000400) +(defconstant +cf-novectorfonts+ #x00000800) +(defconstant +cf-nooemfonts+ #x00000800) +(defconstant +cf-nosimulations+ #x00001000) +(defconstant +cf-limitsize+ #x00002000) +(defconstant +cf-fixedpitchonly+ #x00004000) +(defconstant +cf-wysiwyg+ #x00008000) +(defconstant +cf-forcefontexist+ #x00010000) +(defconstant +cf-scalableonly+ #x00020000) +(defconstant +cf-ttonly+ #x00040000) +(defconstant +cf-nofacesel+ #x00080000) +(defconstant +cf-nostylesel+ #x00100000) +(defconstant +cf-nosizesel+ #x00200000) +(defconstant +cf-selectscript+ #x00400000) +(defconstant +cf-noscriptsel+ #x00800000) +(defconstant +cf-novertfonts+ #x01000000) + (defconstant +cferr-choosefontcodes+ #x2000) (defconstant +cferr-nofonts+ #x2001) (defconstant +cferr-maxlessthanmin+ #x2002) Modified: trunk/src/uitoolkit/system/system-types.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-types.lisp (original) +++ trunk/src/uitoolkit/system/system-types.lisp Sun Jul 2 14:32:26 2006 @@ -127,6 +127,23 @@ (biclrused DWORD) (biclrimp DWORD)) +(defcstruct choosefont + (structsize DWORD) + (howner HANDLE) + (hdc HANDLE) + (logfont LPTR) + (pointsize INT) + (flags DWORD) + (color COLORREF) + (data LPARAM) + (hookfn LPTR) ; FIXME: not yet used, but eventually should be CFHookProc + (templname :string) + (hinstance HANDLE) + (style :string) + (fonttype WORD) + (minsize INT) + (maxsize INT)) + (defcstruct drawtextparams (cbsize UINT) (tablength INT) Modified: trunk/src/uitoolkit/widgets/file-dialog.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/file-dialog.lisp (original) +++ trunk/src/uitoolkit/widgets/file-dialog.lisp Sun Jul 2 14:32:26 2006 @@ -74,12 +74,12 @@ ;;; methods ;;; -(defmethod compute-style-flags ((dlg file-dialog) &rest extra-data) +(defmethod compute-style-flags ((self file-dialog) &rest extra-data) (declare (ignore extra-data)) (let ((std-flags (logior gfs::+ofn-dontaddtorecent+ gfs::+ofn-hidereadonly+ gfs::+ofn-notestfilecreate+ gfs::+ofn-overwriteprompt+ gfs::+ofn-explorer+))) - (loop for sym in (style-of dlg) + (loop for sym in (style-of self) do (cond ((eq sym :add-to-recent) (setf std-flags (logand std-flags (lognot gfs::+ofn-dontaddtorecent+)))) @@ -91,8 +91,8 @@ (setf std-flags (logior std-flags gfs::+ofn-forceshowhidden+))))) (values std-flags 0))) -(defmethod gfs:dispose ((dlg file-dialog)) - (let ((ofn-ptr (gfs:handle dlg))) +(defmethod gfs:dispose ((self file-dialog)) + (let ((ofn-ptr (gfs:handle self))) (unless (cffi:null-pointer-p ofn-ptr) (cffi:with-foreign-slots ((gfs::ofnfile gfs::ofnfilter gfs::ofntitle gfs::ofninitialdir gfs::ofndefext) @@ -106,9 +106,9 @@ (unless (cffi:null-pointer-p gfs::ofndefext) (cffi:foreign-free gfs::ofndefext))) (cffi:foreign-free ofn-ptr) - (setf (slot-value dlg 'gfs:handle) (cffi:null-pointer))))) + (setf (slot-value self 'gfs:handle) (cffi:null-pointer))))) -(defmethod initialize-instance :after ((dlg file-dialog) &key default-extension filters initial-directory initial-filename owner style text) +(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 ;; so that the file buffer can be resized as needed for ;; multi-select mode. @@ -137,7 +137,7 @@ (gfs::strncpy file-buffer tmp-str 1023)) (setf (cffi:mem-ref file-buffer :char) 0)) (multiple-value-bind (std-style ex-style) - (compute-style-flags dlg) + (compute-style-flags self) (cffi:with-foreign-slots ((gfs::ofnsize gfs::ofnhwnd gfs::ofnhinst gfs::ofnfilter gfs::ofncustomfilter gfs::ofnmaxcustfilter gfs::ofnfilterindex gfs::ofnfile gfs::ofnmaxfile gfs::ofnfiletitle gfs::ofnmaxfiletitle @@ -168,12 +168,11 @@ gfs::ofnpvreserved (cffi:null-pointer) gfs::ofndwreserved 0 gfs::ofnexflags ex-style))) - (setf (slot-value dlg 'gfs:handle) ofn-ptr) - (setf (slot-value dlg 'open-mode) (find :open style)))) + (setf (slot-value self 'gfs:handle) ofn-ptr) + (setf (slot-value self 'open-mode) (find :open style)))) -(defmethod show ((dlg file-dialog) flag) +(defmethod show ((self file-dialog) flag) (declare (ignore flag)) - (let ((ofn-ptr (gfs:handle dlg)) - (fn (if (open-mode dlg) #'gfs::get-open-filename #'gfs::get-save-filename))) - (if (and (zerop (funcall fn ofn-ptr)) (/= (gfs::comm-dlg-extended-error) 0)) - (error 'gfs:comdlg-error :detail "file dialog function failed")))) + (if (open-mode self) + (show-common-dialog self #'gfs::get-open-filename) + (show-common-dialog self #'gfs::get-save-filename))) Added: trunk/src/uitoolkit/widgets/font-dialog.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/widgets/font-dialog.lisp Sun Jul 2 14:32:26 2006 @@ -0,0 +1,144 @@ +;;;; +;;;; font-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) + +(defconstant +font-dialog-flags+ (logior gfs::+cf-effects+ gfs::+cf-inittologfontstruct+)) + +;;; +;;; helper functions +;;; + +(defun font-dialog-results (dlg gc) + (if (or (gfs:disposed-p dlg) (gfs:disposed-p gc)) + (error 'gfs:disposed-error)) + (cffi:with-foreign-slots ((gfs::logfont gfs::color) (gfs:handle dlg) gfs::choosefont) + (values (make-instance 'gfg:font :handle (gfs::create-font-indirect gfs::logfont)) + (gfg::rgb->color gfs::color)))) + +(defun lookup-default-font () + (let ((lf-ptr (cffi:foreign-alloc 'gfs::logfont))) + (gfs:zero-mem lf-ptr gfs::logfont) + (gfs::get-object (gfs::get-stock-object gfs::+system-font+) + (cffi:foreign-type-size 'gfs::logfont) + lf-ptr) + lf-ptr)) + +(defmacro with-font-dialog ((owner style font color &key gc initial-color initial-font) &body body) + (let ((dlg (gensym))) + `(let ((,font nil) + (,color nil) + (,dlg (make-instance 'font-dialog + :gc ,gc + :initial-color ,initial-color + :initial-font ,initial-font + :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)) + (gfs:dispose ,dlg))))) + +;;; +;;; methods +;;; + +(defmethod compute-style-flags ((self font-dialog) &rest extra-data) + (declare (ignore extra-data)) + (let ((std-flags (logior gfs::+cf-both+ +font-dialog-flags+))) + (loop for sym in (style-of self) + do (ecase sym + ;; primary styles + ;; + (:all-fonts + (setf std-flags (logior gfs::+cf-both+ +font-dialog-flags+))) + (:fixed-pitch-fonts + (setf std-flags (logior gfs::+cf-fixedpitchonly+ +font-dialog-flags+))) + (:printer-fonts + (setf std-flags (logior gfs::+cf-printerfonts+ +font-dialog-flags+))) + (:screen-fonts + (setf std-flags (logior gfs::+cf-screenfonts+ +font-dialog-flags+))) + (:truetype-fonts + (setf std-flags (logior gfs::+cf-ttonly+ +font-dialog-flags+))) + (:wsyiwyg-fonts + (setf std-flags (logior gfs::+cf-both+ + gfs::+cf-scalableonly+ + gfs::+cf-wysiwyg+ + +font-dialog-flags+))) + + ;; styles that can be combined + ;; + (:no-effects + (setf std-flags (logand std-flags (lognot gfs::+cf-effects+)))))) + (values std-flags 0))) + +(defmethod gfs:dispose ((self font-dialog)) + (let ((cf-ptr (gfs:handle self))) + (unless (cffi:null-pointer-p cf-ptr) + (cffi:with-foreign-slots ((gfs::logfont) cf-ptr gfs::choosefont) + (unless (cffi:null-pointer-p gfs::logfont) + (cffi:foreign-free gfs::logfont))) + (cffi:foreign-free cf-ptr))) + (setf (slot-value self 'gfs:handle) (cffi:null-pointer))) + +(defmethod initialize-instance :after ((self font-dialog) &key gc initial-color initial-font owner &allow-other-keys) + (if (null gc) + (error 'gfs:toolkit-error :detail ":gc initarg is required")) + (if (null owner) + (error 'gfs:toolkit-error :detail ":owner initarg is required")) + (if (gfs:disposed-p owner) + (error 'gfs:disposed-error)) + (let ((cf-ptr (cffi:foreign-alloc 'gfs::choosefont)) + (lf-ptr (if initial-font + (gfg::data->logfont (gfs:handle gc) (gfg:data-object initial-font gc)) + (lookup-default-font)))) + (multiple-value-bind (std-style ex-style) (compute-style-flags self) + (declare (ignore ex-style)) + (cffi:with-foreign-slots ((gfs::structsize gfs::howner gfs::hdc gfs::logfont + gfs::flags gfs::color) + cf-ptr gfs::choosefont) + (setf gfs::structsize (cffi:foreign-type-size 'gfs::choosefont) + gfs::howner (gfs:handle owner) + gfs::hdc (gfs:handle gc) + gfs::logfont lf-ptr + gfs::flags std-style + gfs::color (if initial-color (gfg:color->rgb initial-color) 0)))) + (setf (slot-value self 'gfs:handle) cf-ptr))) + +(defmethod show ((self font-dialog) flag) + (declare (ignore flag)) + (show-common-dialog self #'gfs::choose-font)) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Sun Jul 2 14:32:26 2006 @@ -130,6 +130,9 @@ :initform t)) (:documentation "This class represents the standard file open/save dialog.")) +(defclass font-dialog (widget) () + (:documentation "This class represents the standard font dialog.")) + (defclass widget-with-items (widget) ((items :accessor items Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Sun Jul 2 14:32:26 2006 @@ -107,6 +107,13 @@ (error 'gfs:win32-error :detail "create-window failed")) hwnd)))) +(defun show-common-dialog (dlg dlg-func) + (let* ((struct-ptr (gfs:handle dlg)) + (retval (funcall dlg-func struct-ptr))) + (if (and (zerop retval) (not (zerop (gfs::comm-dlg-extended-error)))) + (error 'gfs:comdlg-error :detail (format nil "~a failed" (symbol-name dlg-func)))) + retval)) + (defun get-widget-text (w) (if (gfs:disposed-p w) (error 'gfs:disposed-error))

1 0

[graphic-forms-cvs] r167 - in trunk/src: tests/uitoolkit uitoolkit/system uitoolkit/widgets
by junrue＠common-lisp.net 28 Jun '06

28 Jun '06

Author: junrue Date: Wed Jun 28 17:44:07 2006 New Revision: 167 Modified: trunk/src/tests/uitoolkit/windlg.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/widgets/event.lisp Log: introduced infrastructure for dispatching control notifications, and used this to implement event-focus-gain/event-focus-loss and event-modify for edit controls Modified: trunk/src/tests/uitoolkit/windlg.lisp ============================================================================== --- trunk/src/tests/uitoolkit/windlg.lisp (original) +++ trunk/src/tests/uitoolkit/windlg.lisp Wed Jun 28 17:44:07 2006 @@ -126,6 +126,23 @@ (call-next-method) (gfs:dispose dlg)) +(defclass edit-control-events (gfw:event-dispatcher) ()) + +(defun truncate-text (str) + (subseq str 0 (min (length str) 5))) + +(defmethod gfw:event-focus-gain ((disp edit-control-events) (ctrl gfw:edit) time) + (declare (ignore time)) + (format t "gained focus: ~a...~%" (truncate-text (gfw:text ctrl)))) + +(defmethod gfw:event-focus-loss ((disp edit-control-events) (ctrl gfw:edit) time) + (declare (ignore time)) + (format t "lost focus: ~a...~%" (truncate-text (gfw:text ctrl)))) + +(defmethod gfw:event-modify ((disp edit-control-events) (ctrl gfw:edit) time) + (declare (ignore time)) + (format t "modified: ~a...~%" (truncate-text (gfw:text ctrl)))) + (defun open-dlg (title style) (let* ((dlg (make-instance 'gfw:dialog :owner *main-win* :dispatcher (make-instance 'dialog-events) @@ -135,6 +152,7 @@ :style '(:horizontal)) :style style :text title)) + (edit-disp (make-instance 'edit-control-events)) (left-panel (make-instance 'gfw:panel :layout (make-instance 'gfw:flow-layout :spacing 4 @@ -145,6 +163,7 @@ :parent left-panel)) (name-edit (make-instance 'gfw:edit :text "WWWWWWWWWWWWWWWWWWWWWWWW" + :dispatcher edit-disp :parent left-panel)) (serial-label (make-instance 'gfw:label :text "Serial Number:" @@ -152,6 +171,7 @@ (serial-edit (make-instance 'gfw:edit :style '(:read-only) :text "323K DSKL3 DSKE23" + :dispatcher edit-disp :parent left-panel)) (pw-label (make-instance 'gfw:label :text "Password:" @@ -159,6 +179,7 @@ (pw-edit (make-instance 'gfw:edit :style '(:mask-characters) :text "WWWWWWWWWWWWWWWWWWWWWWWW" + :dispatcher edit-disp :parent left-panel)) (desc-label (make-instance 'gfw:label :text "Description:" @@ -166,6 +187,7 @@ (desc-edit (make-instance 'gfw:edit :style '(:multi-line :auto-hscroll :auto-vscroll :vertical-scrollbar :want-return) :text (format nil "WWWWWWWWWWWWWWWWWWWWWWWW~%W~%W~%W~%W~%W") + :dispatcher edit-disp :parent left-panel)) (btn-panel (make-instance 'gfw:panel :layout (make-instance 'gfw:flow-layout Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Wed Jun 28 17:44:07 2006 @@ -271,6 +271,17 @@ (defconstant +em-setimestatus+ #x00D8) (defconstant +em-getimestatus+ #x00D9) +(defconstant +en-setfocus+ #x0100) +(defconstant +en-killfocus+ #x0200) +(defconstant +en-change+ #x0300) +(defconstant +en-update+ #x0400) +(defconstant +en-errspace+ #x0500) +(defconstant +en-maxtext+ #x0501) +(defconstant +en-hscroll+ #x0601) +(defconstant +en-vscroll+ #x0602) +(defconstant +en-align-ltr-ec+ #x0700) +(defconstant +en-align-rtl-ec+ #x0701) + (defconstant +es-left+ #x0000) (defconstant +es-center+ #x0001) (defconstant +es-right+ #x0002) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Wed Jun 28 17:44:07 2006 @@ -118,6 +118,15 @@ (cffi:get-callback 'subclassing_wndproc)))) (error 'gfs:win32-error :detail "set-window-long failed"))) +(defun dispatch-notification (widget wparam-hi) + (let ((disp (dispatcher widget)) + (time (event-time (thread-context)))) + (case wparam-hi + (0 (event-select disp widget time (gfs:make-rectangle))) ; FIXME: debug + (#.gfs::+en-killfocus+ (event-focus-loss disp widget time)) + (#.gfs::+en-setfocus+ (event-focus-gain disp widget time)) + (#.gfs::+en-update+ (event-modify disp widget time))))) + ;;; ;;; process-message methods ;;; @@ -156,14 +165,10 @@ ((eq wparam-hi 1) (format t "accelerator wparam: ~x lparam: ~x~%" wparam lparam)) ; FIXME: debug (t - (let ((w (get-widget tc (cffi:make-pointer lparam)))) - (if (null w) - (warn 'gfs:toolkit-warning :detail "no object for hwnd") - (unless (null (dispatcher w)) - (event-select (dispatcher w) - w - (event-time tc) - (gfs:make-rectangle))))))) ; FIXME + (let ((widget (get-widget tc (cffi:make-pointer lparam)))) + (when (and widget (dispatcher widget)) + ; (format t "wparam-hi: ~x wparam-lo: ~x lparam: ~x~%" wparam-hi wparam-lo lparam) + (dispatch-notification widget wparam-hi))))) (warn 'gfs:toolkit-warning :detail "no object for hwnd"))) 0)

1 0