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

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

26 Apr '06

Author: junrue Date: Tue Apr 25 21:24:16 2006 New Revision: 106 Modified: trunk/docs/manual/api.texinfo trunk/docs/manual/overview.texinfo trunk/src/uitoolkit/system/user32.lisp trunk/src/uitoolkit/widgets/control.lisp trunk/src/uitoolkit/widgets/dialog.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/window.lisp Log: implemented focus-p and give-focus methods for widgets; enabled repeated event delivery for virtual keys; some other miscellaneous doc cleanup Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Tue Apr 25 21:24:16 2006 @@ -674,7 +674,16 @@ @end deffn @deffn GenericFunction enabled-p self -Returns T if the object is enabled; nil otherwise. +Returns @sc{t} if @code{self} is enabled; @sc{nil} otherwise. +@end deffn + +@deffn GenericFunction focus-p self +Returns @sc{t} if @code{self} currently has keyboard focus; @sc{nil} +otherwise. +@end deffn + +@deffn GenericFunction give-focus self +Places keyboard focus on @code{self}. @end deffn @deffn GenericFunction item-index self item @@ -694,9 +703,9 @@ @anchor{maximum-size} @deffn GenericFunction maximum-size self Returns a @ref{size} object describing the largest dimensions to which -the user may resize this widget; by default returns @code{nil}, +the user may resize this widget; by default returns @sc{nil}, indicating that there is effectively no constraint. The corresponding -@code{setf} function sets this value; if the new maximum size is +@sc{setf} function sets this value; if the new maximum size is smaller than the current size, the widget is resized to the new maximum. @xref{minimum-size}. @end deffn @@ -708,9 +717,9 @@ @anchor{minimum-size} @deffn GenericFunction minimum-size self Returns a @ref{size} object describing the smallest dimensions to -which the user may resize this widget; by default returns @code{nil}, +which the user may resize this widget; by default returns @sc{nil}, indicating that the minimum constraint is determined by the windowing -system's configuration. The corresponding @code{setf} function sets +system's configuration. The corresponding @sc{setf} function sets this value; if the new minimum size is larger than the current size, the widget is resized to the new minimum. @xref{maximum-size}. @end deffn @@ -741,7 +750,7 @@ @ref{top-level}s and dialogs. And it is possible for a window to be unowned but still have a @ref{parent}. Consequently, calling @ref{parent} on a @ref{top-level} will return an instance of -@ref{root-window}, but calling @ref{owner} may return @code{nil}. In +@ref{root-window}, but calling @ref{owner} may return @sc{nil}. In a reply to an entry at @url{http://blogs.msdn.com/oldnewthing/archive/2004/02/24/79212.aspx}, Raymond Chen says: @@ -766,7 +775,7 @@ @ref{top-level} window. In the case of a dialog or @ref{top-level}, then a @ref{root-window} is returned. In the case of a @code{submenu}, this will be the @ref{menu}'s ancestor in the hierarchy; but for a -menubar or context @ref{menu}, @code{parent} returns @code{nil}. In a +menubar or context @ref{menu}, @code{parent} returns @sc{nil}. In a reply to an entry at @url{http://blogs.msdn.com/oldnewthing/archive/2004/02/24/79212.aspx}, Raymond Chen says: @@ -1007,7 +1016,7 @@ The default pen style is equivalent to @code{(:flat :square-endcap :round-bevel)}. -Specifying @code{nil} for @code{pen-style} equates to selecting the +Specifying @sc{nil} for @code{pen-style} equates to selecting the Win32 @sc{PS_NULL} pen style, meaning that the pen is invisible. @end deffn @anchor{pen-width} Modified: trunk/docs/manual/overview.texinfo ============================================================================== --- trunk/docs/manual/overview.texinfo (original) +++ trunk/docs/manual/overview.texinfo Tue Apr 25 21:24:16 2006 @@ -61,12 +61,12 @@ @item ASDF @url{http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/cclan/asdf} +@item Cells +@url{http://common-lisp.net/project/cells} + @item CFFI @url{http://common-lisp.net/project/cffi} -@item lw-compat -@url{http://common-lisp.net/project/cl-containers/lw-compat/lw-compat_latest.tar.gz} - @item Closer to MOP @url{http://common-lisp.net/project/cl-containers/closer-mop/closer-mop_latest.tar.gz} @@ -75,6 +75,9 @@ @item lisp-unit @url{http://www.cs.northwestern.edu/academics/courses/325/readings/lisp-unit.html} + +@item lw-compat +@url{http://common-lisp.net/project/cl-containers/lw-compat/lw-compat_latest.tar.gz} @end table Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Tue Apr 25 21:24:16 2006 @@ -274,6 +274,10 @@ HANDLE) (defcfun + ("GetFocus" get-focus) + HANDLE) + +(defcfun ("GetKeyState" get-key-state) SHORT (virtkey INT)) @@ -470,6 +474,11 @@ (lparam WPARAM)) (defcfun + ("SetFocus" set-focus) + HANDLE + (hwnd HANDLE)) + +(defcfun ("SetMenu" set-menu) BOOL (hwnd HANDLE) Modified: trunk/src/uitoolkit/widgets/control.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/control.lisp (original) +++ trunk/src/uitoolkit/widgets/control.lisp Tue Apr 25 21:24:16 2006 @@ -61,6 +61,22 @@ (declare (ignore ctrl)) (gfg:rgb->color (gfs::get-sys-color gfs::+color-btnface+))) +(defmethod focus-p :before ((ctrl control)) + (if (gfs:disposed-p ctrl) + (error 'gfs:disposed-error))) + +(defmethod focus-p ((ctrl control)) + (let ((focus-hwnd (gfs::get-focus))) + (and (not (gfs:null-handle-p focus-hwnd)) (cffi:pointer-eq focus-hwnd (gfs:handle ctrl))))) + +(defmethod give-focus :before ((ctrl control)) + (if (gfs:disposed-p ctrl) + (error 'gfs:disposed-error))) + +(defmethod give-focus ((ctrl control)) + (if (gfs:null-handle-p (gfs::set-focus (gfs:handle ctrl))) + (error 'gfs:toolkit-error "set-focus failed"))) + (defmethod initialize-instance :after ((ctrl control) &key parent &allow-other-keys) (if (gfs:disposed-p parent) (error 'gfs:disposed-error))) Modified: trunk/src/uitoolkit/widgets/dialog.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/dialog.lisp (original) +++ trunk/src/uitoolkit/widgets/dialog.lisp Tue Apr 25 21:24:16 2006 @@ -37,6 +37,22 @@ ;;; methods ;;; +(defmethod focus-p :before ((dlg dialog)) + (if (gfs:disposed-p dlg) + (error 'gfs:disposed-error))) + +(defmethod focus-p ((dlg dialog)) + (let ((focus-hwnd (gfs::get-focus))) + (and (not (gfs:null-handle-p focus-hwnd)) (cffi:pointer-eq focus-hwnd (gfs:handle dlg))))) + +(defmethod give-focus :before ((dlg dialog)) + (if (gfs:disposed-p dlg) + (error 'gfs:disposed-error))) + +(defmethod give-focus ((dlg dialog)) + (if (gfs:null-handle-p (gfs::set-focus (gfs:handle dlg))) + (error 'gfs:toolkit-error "set-focus failed"))) + (defmethod print-object ((self dialog) stream) (print-unreadable-object (self stream :type t) (format stream "handle: ~x " (gfs:handle self)) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Tue Apr 25 21:24:16 2006 @@ -209,12 +209,13 @@ 0) (defmethod process-message (hwnd (msg (eql gfs::+wm-keydown+)) wparam lparam) + (declare (ignore lparam)) (let* ((tc (thread-context)) (wparam-lo (lo-word wparam)) (ch (gfs::map-virtual-key wparam-lo 2)) (w (get-widget tc hwnd))) (setf (virtual-key tc) wparam-lo) - (when (and w (= ch 0) (= (logand lparam #x40000000) 0)) + (when (and w (= ch 0)) (event-key-down (dispatcher w) w (event-time tc) wparam-lo (code-char ch)))) 0) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Tue Apr 25 21:24:16 2006 @@ -183,6 +183,22 @@ (let ((sz (client-size win))) (perform-layout win (gfs:size-width sz) (gfs:size-height sz)))) +(defmethod focus-p :before ((win window)) + (if (gfs:disposed-p win) + (error 'gfs:disposed-error))) + +(defmethod focus-p ((win window)) + (let ((focus-hwnd (gfs::get-focus))) + (and (not (gfs:null-handle-p focus-hwnd)) (cffi:pointer-eq focus-hwnd (gfs:handle win))))) + +(defmethod give-focus :before ((win window)) + (if (gfs:disposed-p win) + (error 'gfs:disposed-error))) + +(defmethod give-focus ((win window)) + (if (gfs:null-handle-p (gfs::set-focus (gfs:handle win))) + (error 'gfs:toolkit-error "set-focus failed"))) + (defmethod location ((win window)) (if (gfs:disposed-p win) (error 'gfs:disposed-error))

1 0

[graphic-forms-cvs] r105 - in trunk: . src/uitoolkit/graphics
by junrue＠common-lisp.net 24 Apr '06

24 Apr '06

Author: junrue Date: Mon Apr 24 13:46:06 2006 New Revision: 105 Modified: trunk/README.txt trunk/config.lisp trunk/src/uitoolkit/graphics/image-data.lisp trunk/tests.lisp Log: revised image loading code such that it relies on merge-pathnames and *default-pathname-defaults* rather than the current working directory; also made some cleanup edits in preparation for 0.3.0 release Modified: trunk/README.txt ============================================================================== --- trunk/README.txt (original) +++ trunk/README.txt Mon Apr 24 13:46:06 2006 @@ -1,5 +1,5 @@ -Graphic-Forms README for version 0.2.0 +Graphic-Forms README for version 0.3.0 Copyright (c) 2006, Jack D. Unrue Graphic-Forms is a user interface library implemented in Common Lisp focusing @@ -15,6 +15,9 @@ - ASDF http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/cclan/asdf/ + - Cells + http://common-lisp.net/project/cells/ + - CFFI 0.9.0 http://common-lisp.net/project/cffi/ @@ -34,36 +37,30 @@ Known Problems -------------- -Aside from the fact that there are a myriad number of classes, functions, -and features in general that are not yet implemented, this section lists +Aside from the fact that there are a myriad of classes, functions, and +features in general that are not yet implemented, this section lists known problems in this release: -1. When running the layout-tester application on CLISP, you may experience - intermittent GPFs given sufficient playing around with window sizing, - or adding/removing/hiding/showing controls if the flow layout is set to - wrap. - - This problem needs further in-depth investigation. +1. The following bug filed against CLISP 2.38 -2. When running the event-tester application on CLISP, you may experience - intermittent GPFs after selecting File | Start Timer to start the - timer test. + http://sourceforge.net/tracker/index.php?func=detail&aid=1463994&group_id=1… - This problem needs further in-depth investigation. + may result in intermittent GPFs when windows with layout managers are + resized or when timer objects are initialized. -3. Image loading currently requires installation of the ImageMagick +2. Image loading currently requires installation of the ImageMagick library as described in the next section. I have tested with Windows BMP files (and this is what the image-tester application displays). ImageMagick itself supports many image formats, but Graphic-Forms has not been tested with all of them. Therefore, images may not display properly, expecially when a transparency is selected. -4. The event-tester application's menu definition specifies that the +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. -5. Graphic-Forms supports CLISP 2.38 and LispWorks 4.4.6. The +4. Graphic-Forms supports CLISP 2.38 and LispWorks 4.4.6. The intention is to support additional Lisp vendors, but currently the library will not run on anything but CLISP or LW due to some vendor-specific features that have to be used. @@ -91,14 +88,15 @@ (load "config.lisp") ;; - ;; If ImageMagic is not installed in the default location, execute: + ;; If ImageMagick is not installed in the default location, execute: ;; - (setf gfsys::*imagemagick-dir* "c:/path/to/your/ImageMagick/install/") + (setf cl-user::*magick-library-directory* "c:/path/to/your/ImageMagick/install/") ;; setf these variables as needed for your specific environment to ;; load the other dependencies besides ImageMagick. Or if your Lisp ;; image already has these systems loaded, set the variables to nil. ;; + ;; gfsys::*cells-dir* ;; gfsys::*cffi-dir* ;; gfsys::*closer-mop-dir* ;; gfsys::*lw-compat-dir* @@ -119,9 +117,14 @@ ;; (asdf:operate 'asdf:load-op :graphic-forms-uitoolkit) -6. Proceed to the next section to run the tests, or start coding! - (note: I will add instructions in the future for building the - documentation) +6. You may optionally compile the reference manual. GNU Make and + makeinfo are prerequisites. Assuming you already have those + components installed, the reference manual can be built by + opening a command prompt and cd'ing to the `docs\manual' + subdirectory, then typing `make'. The output will be + produced within a subdirectory called `reference'. + +7. Proceed to the next section to run the tests, or start coding! How To Run Tests And Samples @@ -136,15 +139,10 @@ (asdf:operate 'asdf:load-op :graphic-forms-tests) - ;; Change the working directory to the uitoolkit tests - ;; directory. - ;; - - (chdir "c:/example/path/graphic-forms/src/tests/uitoolkit/") - - ;; then execute one or more of the following: + ;; execute one or more of the following: ;; + (in-package :gft) (run-tests) ;; runs the unit tests (many more to be added) (gft::run-event-tester) @@ -159,13 +157,15 @@ Support and Feedback -------------------- -Please provide feedback via the development mailing list: +Please provide feedback via the following channels: + +The development mailing list: http://www.common-lisp.net/mailman/listinfo/graphic-forms-devel -Bug reports via the bug tracking system: - http://sourceforge.net/tracker/?group_id=163034&atid=826147 +The bug tracking system: + http://sourceforge.net/tracker/?group_id=163034&atid=826145 -Patches via the patch tracker: +The patch tracker: http://sourceforge.net/tracker/?group_id=163034&atid=826147 Modified: trunk/config.lisp ============================================================================== --- trunk/config.lisp (original) +++ trunk/config.lisp Mon Apr 24 13:46:06 2006 @@ -47,11 +47,6 @@ (defvar *lisp-unit-file* "lisp-unit") -#+lispworks (defmacro chdir (path) - `(hcl:change-directory ,path)) -#+clisp (defmacro chdir (path) - `(ext:cd ,path)) - (defun configure-asdf () (pushnew *cells-dir* asdf:*central-registry* :test #'equal) (pushnew *cffi-dir* asdf:*central-registry* :test #'equal) Modified: trunk/src/uitoolkit/graphics/image-data.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/image-data.lisp (original) +++ trunk/src/uitoolkit/graphics/image-data.lisp Mon Apr 24 13:46:06 2006 @@ -206,8 +206,8 @@ (defmethod load ((data image-data) path) (setf path (cond - ((typep path 'pathname) (namestring path)) - ((typep path 'string) path) + ((typep path 'pathname) (namestring (merge-pathnames path))) + ((typep path 'string) (namestring (merge-pathnames path))) (t (error 'gfs:toolkit-error :detail "pathname or string required")))) (let ((handle (gfs:handle data))) @@ -220,7 +220,7 @@ (if (not (eql (cffi:foreign-slot-value ex 'exception-info 'severity) :undefined)) (error 'gfs:toolkit-error :detail (format nil "exception reason: ~s" - (cffi:foreign-slot-value ex 'exception-info 'reason)))) + (cffi:foreign-slot-value ex 'exception-info 'reason)))) (if (cffi:null-pointer-p handle) (error 'gfs:toolkit-error :detail (format nil "could not load image: ~a" path))) (setf (slot-value data 'gfs:handle) handle)))) Modified: trunk/tests.lisp ============================================================================== --- trunk/tests.lisp (original) +++ trunk/tests.lisp Mon Apr 24 13:46:06 2006 @@ -36,5 +36,5 @@ (load (compile-file *lisp-unit-file*)) (defun load-tests () - (asdf:operate 'asdf:load-op :graphic-forms-tests) - (chdir *gf-tests-dir*)) + (setf *default-pathname-defaults* (parse-namestring *gf-tests-dir*)) + (asdf:operate 'asdf:load-op :graphic-forms-tests))

1 0

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

24 Apr '06

Author: junrue Date: Mon Apr 24 12:19:53 2006 New Revision: 104 Added: trunk/src/uitoolkit/widgets/dialog.lisp Modified: trunk/docs/manual/api.texinfo trunk/graphic-forms-uitoolkit.asd trunk/src/uitoolkit/widgets/control.lisp trunk/src/uitoolkit/widgets/menu-language.lisp trunk/src/uitoolkit/widgets/menu.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/widget-with-items.lisp trunk/src/uitoolkit/widgets/widget.lisp trunk/src/uitoolkit/widgets/window.lisp Log: reverted widget-with-items back to storing items as a vector; fixed a bug introduced in print-object for widgets Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Mon Apr 24 12:19:53 2006 @@ -246,9 +246,9 @@ overwrite when an existing file is selected @end itemize Applications retrieve selected files by calling the @code{items} -function, which returns a list of @sc{file namestring}s, one for each -selection. Unless the @code{:multiple-select} style keyword is -specified, there will at most be one selected file returned, and +function, which returns a @sc{vector} of @sc{file namestring}s, one +for each selection. Unless the @code{:multiple-select} style keyword +is specified, there will at most be one selected file returned, and possibly zero if the user cancelled the dialog.@*@* @deffn Initarg :default-extension Specifies a default extension to be appended to a file name if Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Mon Apr 24 12:19:53 2006 @@ -109,6 +109,7 @@ (:file "root-window") (:file "top-level") (:file "panel") + (:file "dialog") (:file "file-dialog") (:file "layout") (:file "flow-layout"))))))))) Modified: trunk/src/uitoolkit/widgets/control.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/control.lisp (original) +++ trunk/src/uitoolkit/widgets/control.lisp Mon Apr 24 12:19:53 2006 @@ -69,3 +69,9 @@ (declare (ignorable width-hint height-hint)) (if (gfs:disposed-p ctrl) (error 'gfs:disposed-error))) + +(defmethod print-object ((self control) stream) + (print-unreadable-object (self stream :type t) + (format stream "handle: ~x " (gfs:handle self)) + (format stream "dispatcher: ~a " (dispatcher self)) + (format stream "size: ~a" (size self)))) Added: trunk/src/uitoolkit/widgets/dialog.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/widgets/dialog.lisp Mon Apr 24 12:19:53 2006 @@ -0,0 +1,44 @@ +;;;; +;;;; 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) + +;;; +;;; methods +;;; + +(defmethod print-object ((self dialog) stream) + (print-unreadable-object (self stream :type t) + (format stream "handle: ~x " (gfs:handle self)) + (format stream "dispatcher: ~a " (dispatcher self)) + (format stream "size: ~a" (size 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 Apr 24 12:19:53 2006 @@ -208,7 +208,7 @@ (put-menuitem (thread-context) it) (insert-separator hmenu) (setf (slot-value it 'gfs:handle) hmenu) - (push it (items owner)))) + (vector-push-extend it (items owner)))) (defmethod define-submenu ((gen win32-menu-generator) label dispatcher disabled) (let* ((submenu (make-instance 'menu :handle (gfs::create-popup-menu))) Modified: trunk/src/uitoolkit/widgets/menu.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu.lisp (original) +++ trunk/src/uitoolkit/widgets/menu.lisp Mon Apr 24 12:19:53 2006 @@ -139,7 +139,7 @@ (insert-menuitem hmenu id text (cffi:null-pointer)) (setf (item-id item) id) (put-menuitem tc item) - (push item (items owner)) + (vector-push-extend item (items owner)) item)) (defmethod append-submenu ((parent menu) text (submenu menu) disp) @@ -153,7 +153,7 @@ (insert-submenu hparent id text (cffi:null-pointer) hmenu) (setf (item-id item) id) (put-menuitem tc item) - (push item (items parent)) + (vector-push-extend item (items parent)) (put-widget tc submenu) (cond ((null disp)) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Mon Apr 24 12:19:53 2006 @@ -77,7 +77,8 @@ (defclass widget-with-items (widget) ((items :accessor items - :initform nil)) + ;; FIXME: allow subclasses to set initial size? + :initform (make-array 7 :fill-pointer 0 :adjustable t))) (:documentation "The widget-with-items class is the base class for objects composed of sub-items.")) (defclass dialog (widget-with-items) () 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 Apr 24 12:19:53 2006 @@ -46,7 +46,7 @@ (defmethod clear-item ((w widget-with-items) index) (let* ((items (items w)) (it (elt items index))) - (setf (items w) (remove-if #'(lambda (x) (items-equal-p x it)) items)) + (delete it (items w) :test #'items-equal-p) (if (gfs:disposed-p it) (error 'gfs:disposed-error)) (gfs:dispose it))) Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Mon Apr 24 12:19:53 2006 @@ -236,8 +236,7 @@ (defmethod print-object ((self widget) stream) (print-unreadable-object (self stream :type t) (format stream "handle: ~x " (gfs:handle self)) - (format stream "dispatcher: ~a " (dispatcher self)) - (format stream "client size: ~a" (size self)))) + (format stream "dispatcher: ~a " (dispatcher self)))) (defmethod redraw :before ((w widget)) (if (gfs:disposed-p w) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Mon Apr 24 12:19:53 2006 @@ -205,6 +205,12 @@ (compute-outer-size win new-client-sz)) (size win)))) +(defmethod print-object ((self window) stream) + (print-unreadable-object (self stream :type t) + (format stream "handle: ~x " (gfs:handle self)) + (format stream "dispatcher: ~a " (dispatcher self)) + (format stream "size: ~a" (size self)))) + (defmethod show ((win window) flag) (declare (ignore flag)) (call-next-method)

1 0

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

24 Apr '06

Author: junrue Date: Mon Apr 24 02:38:32 2006 New Revision: 103 Added: trunk/src/uitoolkit/widgets/file-dialog.lisp Modified: trunk/docs/manual/api.texinfo trunk/graphic-forms-uitoolkit.asd trunk/src/packages.lisp trunk/src/tests/uitoolkit/drawing-tester.lisp trunk/src/tests/uitoolkit/event-tester.lisp trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/tests/uitoolkit/windlg.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/system/system-types.lisp trunk/src/uitoolkit/system/system-utils.lisp trunk/src/uitoolkit/widgets/button.lisp trunk/src/uitoolkit/widgets/menu-language.lisp trunk/src/uitoolkit/widgets/menu.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp trunk/src/uitoolkit/widgets/widget-with-items.lisp Log: implemented open and save file dialogs; revised widget-with-items to store items as a list rather than a vector Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Mon Apr 24 02:38:32 2006 @@ -186,6 +186,14 @@ @ref{widget}. @end deftp +@anchor{dialog} +@deftp Class dialog +This is the base class for system and user-defined dialogs. A dialog +is a windowed UI component that is @emph{typically} defined to remain +on top of the primary application window(s). Of course, some +applications are entirely dialog-based. +@end deftp + @anchor{display} @deftp Class display primary Instances of this class describe characteristics of monitors attached @@ -227,6 +235,94 @@ @end deffn @end deftp +@anchor{file-dialog} +@deftp Class file-dialog +This class provides a standard @ref{dialog} for navigating the file +system to select or enter file names. A variety of configurations are +possible; however, please note that the following behaviors are +implemented regardless of other style flags or initarg values: +@itemize @bullet +@item in @code{:save} mode, the user will be prompted to confirm +overwrite when an existing file is selected +@end itemize +Applications retrieve selected files by calling the @code{items} +function, which returns a list of @sc{file namestring}s, one for each +selection. Unless the @code{:multiple-select} style keyword is +specified, there will at most be one selected file returned, and +possibly zero if the user cancelled the dialog.@*@* +@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 +be removed. Also, only the first three characters are used. +@end deffn +@deffn Initarg :filters +This initarg accepts a list of conses, @sc{first} holding a string +that describes a filter, e.g., @samp{Text Files}, and @sc{second} +specifying the actual filter pattern, e.g., @samp{*.TXT}. Note that +multiple filter patterns can be grouped with a single description by +separating them with semicolons, e.g., @samp{*.TXT;*.BAK}. +@end deffn +@deffn Initarg :initial-directory +This initarg accepts a @sc{directory namestring} identifying the +location in the file system whose contents are to be browsed by the +file dialog. @strong{Note:} setting this value will result in the +side-effect of changing the current working directory of the @sc{lisp} +process. Also, the supplied value is used only if the @sc{namestring} +supplied for @code{:initial-filename} does not contain a path. +@end deffn +@deffn Initarg :initial-filename +This initarg accepts a @sc{file namestring} which has several +purposes: +@itemize @bullet +@item populate the edit field in the file dialog with the file name +and extension +@item set the initial directory of the file dialog (and hence +the current working directory of the @sc{lisp} process) if it contains +a directory path +@item if the file actually exists in the directory, set the other +components of the file dialog to reflect the attributes of the file +@end itemize +@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. +@end deffn +@deffn Initarg :style +This initarg accepts a list of keyword symbols, as follows: +@table @code +@item :add-to-recent +This enables the system to add a link to the selected file +in the directory that contains the user's most recently +used documents. +@item :multiple-select +This configures the dialog to accept multiple selections. +@item :open +This configures the dialog to be used to select one or more files +for loading data. +@item :path-must-exist +This keyword enables a validation check that constrains the user's +selection to file paths that actually exist. A warning dialog will be +displayed if the user supplies a non-existent path. +@item :save +This configures the dialog to be used to specify a destination file +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 +@sc{system} will not be displayed in any case. Also, be aware that +using this keyword effectively overrides the user's preference +settings. +@end table +@end deffn +@deffn Initarg :text +This initarg accepts a string that will become the title of the file +dialog. By default, a file dialog with the @code{:open} style flag +will display @samp{Open} whereas the @code{:save} style flag will +result in a title of @samp{Save As}. +@end deffn +@end deftp + @anchor{item} @deftp Class item item-id The @code{item} class is the base class for all non-windowed user @@ -581,14 +677,6 @@ Returns T if the object is enabled; nil otherwise. @end deffn -@deffn GenericFunction item-at self index -Return the item at the given zero-based index from the object. -@end deffn - -@deffn GenericFunction item-count self -Return the number of items possessed by the object. -@end deffn - @deffn GenericFunction item-index self item Return the zero-based index of the location of the other object in this object. @end deffn Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Mon Apr 24 02:38:32 2006 @@ -109,5 +109,6 @@ (:file "root-window") (:file "top-level") (:file "panel") + (:file "file-dialog") (:file "layout") (:file "flow-layout"))))))))) Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Mon Apr 24 02:38:32 2006 @@ -81,6 +81,7 @@ #:zero-mem ;; conditions + #:comdlg-error #:disposed-error #:toolkit-error #:toolkit-warning @@ -219,6 +220,7 @@ #:display #:event-dispatcher #:event-source + #:file-dialog #:flow-layout #:item #:layout-manager @@ -387,8 +389,6 @@ #:initial-delay-of #:horizontal-scrollbar #:image - #:item-at - #:item-count #:item-height #:item-id #:item-index Modified: trunk/src/tests/uitoolkit/drawing-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/drawing-tester.lisp (original) +++ trunk/src/tests/uitoolkit/drawing-tester.lisp Mon Apr 24 02:38:32 2006 @@ -44,8 +44,8 @@ (defun find-checked-item (disp menu time) (declare (ignore disp time)) - (dotimes (i (gfw:item-count menu)) - (let ((item (gfw:item-at menu i))) + (dotimes (i (length (gfw:items menu))) + (let ((item (elt (gfw:items menu) i))) (when (gfw:checked-p item) (setf *last-checked-drawing-item* item) (return))))) Modified: trunk/src/tests/uitoolkit/event-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/event-tester.lisp (original) +++ trunk/src/tests/uitoolkit/event-tester.lisp Mon Apr 24 02:38:32 2006 @@ -200,7 +200,7 @@ (defun manage-file-menu (disp menu time) (declare (ignore disp time)) - (let ((item (gfw:item-at menu 0))) + (let ((item (elt (gfw:items menu) 0))) (setf (gfw:text item) (if *timer* "Sto&p Timer" "&Start Timer")))) (defun manage-timer (disp item time rect) Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Mon Apr 24 02:38:32 2006 @@ -183,8 +183,8 @@ (defun check-flow-orient-items (disp menu time) (declare (ignore disp time)) (let ((layout (gfw:layout-of *layout-tester-win*))) - (gfw:check (gfw:item-at menu 0) (find :horizontal (gfw:style-of layout))) - (gfw:check (gfw:item-at menu 1) (find :vertical (gfw:style-of layout))))) + (gfw:check (elt (gfw:items menu) 0) (find :horizontal (gfw:style-of layout))) + (gfw:check (elt (gfw:items menu) 1) (find :vertical (gfw:style-of layout))))) (defun set-flow-horizontal (disp item time rect) (declare (ignorable disp item time rect)) @@ -216,7 +216,7 @@ (defun enable-flow-spacing-items (disp menu time) (declare (ignore disp time)) (let ((spacing (gfw:spacing-of (gfw:layout-of *layout-tester-win*)))) - (gfw:enable (gfw:item-at menu 0) (> spacing 0)))) + (gfw:enable (elt (gfw:items menu) 0) (> spacing 0)))) (defun decrease-flow-spacing (disp item time rect) (declare (ignore disp item time rect)) @@ -236,22 +236,22 @@ (defun enable-left-flow-margin-items (disp menu time) (declare (ignore disp time)) (let ((layout (gfw:layout-of *layout-tester-win*))) - (gfw:enable (gfw:item-at menu 0) (> (gfw:left-margin-of layout) 0)))) + (gfw:enable (elt (gfw:items menu) 0) (> (gfw:left-margin-of layout) 0)))) (defun enable-top-flow-margin-items (disp menu time) (declare (ignore disp time)) (let ((layout (gfw:layout-of *layout-tester-win*))) - (gfw:enable (gfw:item-at menu 0) (> (gfw:top-margin-of layout) 0)))) + (gfw:enable (elt (gfw:items menu) 0) (> (gfw:top-margin-of layout) 0)))) (defun enable-right-flow-margin-items (disp menu time) (declare (ignore disp time)) (let ((layout (gfw:layout-of *layout-tester-win*))) - (gfw:enable (gfw:item-at menu 0) (> (gfw:right-margin-of layout) 0)))) + (gfw:enable (elt (gfw:items menu) 0) (> (gfw:right-margin-of layout) 0)))) (defun enable-bottom-flow-margin-items (disp menu time) (declare (ignore disp time)) (let ((layout (gfw:layout-of *layout-tester-win*))) - (gfw:enable (gfw:item-at menu 0) (> (gfw:bottom-margin-of layout) 0)))) + (gfw:enable (elt (gfw:items menu) 0) (> (gfw:bottom-margin-of layout) 0)))) (defun inc-left-flow-margin (disp item time rect) (declare (ignore disp item time rect)) Modified: trunk/src/tests/uitoolkit/windlg.lisp ============================================================================== --- trunk/src/tests/uitoolkit/windlg.lisp (original) +++ trunk/src/tests/uitoolkit/windlg.lisp Mon Apr 24 02:38:32 2006 @@ -96,16 +96,40 @@ (setf (gfw:text window) "Palette") (gfw:show window t))) +(defun open-file-dlg (disp item time rect) + (declare (ignore disp item time rect)) + (let ((dlg (make-instance 'gfw:file-dialog :owner *main-win* + :filters '(("FASL Files (*.fas;*.fsl)" . "*.fas;*.fsl") + ("Lisp Source Files (*.lisp;*.lsp)" . "*.lisp;*.lsp") + ("All Files (*.*)" . "*.*")) + :initial-directory #P"c:/" + :style '(:add-to-recent :multiple-select :open) + :text "Select Lisp-related files..."))) + (print (gfw:items dlg)))) + +(defun save-file-dlg (disp item time rect) + (declare (ignore disp item time rect)) + (let ((dlg (make-instance 'gfw:file-dialog :owner *main-win* + :default-extension "dat" + :filters '(("Data files (*.dat)" . "*.dat") + ("All Files (*.*)" . "*.*")) + :initial-directory #P"c:/" + :style '(:save)))) + (print (gfw:items dlg)))) + (defun run-windlg-internal () (let ((menubar nil)) (setf *main-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'main-win-events) :style '(:workspace))) (setf menubar (gfw:defmenu ((:item "&File" :submenu ((:item "E&xit" :callback #'windlg-exit-fn))) + (:item "&Dialogs" + :submenu ((: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/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Mon Apr 24 02:38:32 2006 @@ -109,6 +109,27 @@ (defconstant +cchdevicename+ 32) +(defconstant +ccerr-choosecolorcodes+ #x5000) + +(defconstant +cderr-dialogfailure+ #xffff) +(defconstant +cderr-generalcodes+ #x0000) +(defconstant +cderr-structsize+ #x0001) +(defconstant +cderr-initialization+ #x0002) +(defconstant +cderr-notemplate+ #x0003) +(defconstant +cderr-nohinstance+ #x0004) +(defconstant +cderr-loadstrfailure+ #x0005) +(defconstant +cderr-findresfailure+ #x0006) +(defconstant +cderr-loadresfailure+ #x0007) +(defconstant +cderr-lockresfailure+ #x0008) +(defconstant +cderr-memallocfailure+ #x0009) +(defconstant +cderr-memlockfailure+ #x000a) +(defconstant +cderr-nohook+ #x000b) +(defconstant +cderr-registermsgfail+ #x000c) + +(defconstant +cferr-choosefontcodes+ #x2000) +(defconstant +cferr-nofonts+ #x2001) +(defconstant +cferr-maxlessthanmin+ #x2002) + (defconstant +color-scrollbar+ 0) (defconstant +color-background+ 1) (defconstant +color-activecaption+ 2) @@ -199,6 +220,11 @@ (defconstant +eto-ignorelanguage+ #x1000) (defconstant +eto-pdy+ #x2000) +(defconstant +fnerr-filenamecodes+ #x3000) +(defconstant +fnerr-subclassfailure+ #x3001) +(defconstant +fnerr-invalidfilename+ #x3002) +(defconstant +fnerr-buffertoosmall+ #x3003) + (defconstant +ff-dontcare+ #x0000) (defconstant +ff-roman+ #x0010) (defconstant +ff-swiss+ #x0020) @@ -209,6 +235,9 @@ (defconstant +fr-private+ #x10) (defconstant +fr-not-enum+ #x20) +(defconstant +frerr-findreplacecodes+ #x4000) +(defconstant +frerr-bufferlengthzero+ #x4001) + (defconstant +fw-dontcare+ 0) (defconstant +fw-thin+ 100) (defconstant +fw-extralight+ 200) @@ -372,6 +401,38 @@ (defconstant +obm-size+ 32766) (defconstant +obm-old-close+ 32767) +(defconstant +ofn-readonly+ #x00000001) +(defconstant +ofn-overwriteprompt+ #x00000002) +(defconstant +ofn-hidereadonly+ #x00000004) +(defconstant +ofn-nochangedir+ #x00000008) +(defconstant +ofn-showhelp+ #x00000010) +(defconstant +ofn-enablehook+ #x00000020) +(defconstant +ofn-enabletemplate+ #x00000040) +(defconstant +ofn-enabletemplatehandle+ #x00000080) +(defconstant +ofn-novalidate+ #x00000100) +(defconstant +ofn-allowmultiselect+ #x00000200) +(defconstant +ofn-extensiondifferent+ #x00000400) +(defconstant +ofn-pathmustexist+ #x00000800) +(defconstant +ofn-filemustexist+ #x00001000) +(defconstant +ofn-createprompt+ #x00002000) +(defconstant +ofn-shareaware+ #x00004000) +(defconstant +ofn-noreadonlyreturn+ #x00008000) +(defconstant +ofn-notestfilecreate+ #x00010000) +(defconstant +ofn-nonetworkbutton+ #x00020000) +(defconstant +ofn-nolongnames+ #x00040000) +(defconstant +ofn-explorer+ #x00080000) +(defconstant +ofn-nodereferencelinks+ #x00100000) +(defconstant +ofn-longnames+ #x00200000) +(defconstant +ofn-enableincludenotify+ #x00400000) +(defconstant +ofn-enablesizing+ #x00800000) +(defconstant +ofn-dontaddtorecent+ #x02000000) +(defconstant +ofn-forceshowhidden+ #x10000000) +(defconstant +ofn-ex-noplacesbar+ #x00000001) + +(defconstant +ofn-sharefallthrough 2) +(defconstant +ofn-sharenowarn 1) +(defconstant +ofn-sharewarn 0) + (defconstant +oic-sample+ 32512) (defconstant +oic-hand+ 32513) (defconstant +oic-ques+ 32514) @@ -408,6 +469,20 @@ (defconstant +out-screen-outline-precis+ 9) (defconstant +out-ps-only-precis+ 10) +(defconstant +pderr-printercodes+ #x1000) +(defconstant +pderr-setupfailure+ #x1001) +(defconstant +pderr-parsefailure+ #x1002) +(defconstant +pderr-retdeffailure+ #x1003) +(defconstant +pderr-loaddrvfailure+ #x1004) +(defconstant +pderr-getdevmodefail+ #x1005) +(defconstant +pderr-initfailure+ #x1006) +(defconstant +pderr-nodevices+ #x1007) +(defconstant +pderr-nodefaultprn+ #x1008) +(defconstant +pderr-dndmmismatch+ #x1009) +(defconstant +pderr-createicfailure+ #x100a) +(defconstant +pderr-printernotfound+ #x100b) +(defconstant +pderr-defaultdifferent+ #x100c) + (defconstant +qs-key+ #x0001) (defconstant +qs-mousemove+ #x0002) (defconstant +qs-mousebutton+ #x0004) Modified: trunk/src/uitoolkit/system/system-types.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-types.lisp (original) +++ trunk/src/uitoolkit/system/system-types.lisp Mon Apr 24 02:38:32 2006 @@ -212,11 +212,11 @@ (ofnsize DWORD) (ofnhwnd HANDLE) (ofnhinst HANDLE) - (ofnfilter :string) - (ofncustomfilter :string) + (ofnfilter LPTR) + (ofncustomfilter LPTR) (ofnmaxcustfilter DWORD) (ofnfilterindex DWORD) - (ofnfile :string) + (ofnfile LPTR) (ofnmaxfile DWORD) (ofnfiletitle :string) (ofnmaxfiletitle DWORD) Modified: trunk/src/uitoolkit/system/system-utils.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-utils.lisp (original) +++ trunk/src/uitoolkit/system/system-utils.lisp Mon Apr 24 02:38:32 2006 @@ -50,6 +50,10 @@ `(loop for ,i from 0 below (foreign-type-size (quote ,type)) do (setf (mem-aref ,object :char ,i) 0)))) +#+lispworks (defun native-object-special-action (obj) + (if (typep obj 'gfs:native-object) + (gfs:dispose obj))) + ;;; ;;; convenience macros ;;; Modified: trunk/src/uitoolkit/widgets/button.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/button.lisp (original) +++ trunk/src/uitoolkit/widgets/button.lisp Mon Apr 24 02:38:32 2006 @@ -38,7 +38,7 @@ ;;; (defmethod compute-style-flags ((btn button) style &rest extra-data) - (declare (ignore btn extra-data)) + (declare (ignore extra-data)) (let ((std-flags 0) (ex-flags 0)) (setf style (gfs:flatten style)) Added: trunk/src/uitoolkit/widgets/file-dialog.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/widgets/file-dialog.lisp Mon Apr 24 02:38:32 2006 @@ -0,0 +1,141 @@ +;;;; +;;;; file-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) + +;;; +;;; helper functions +;;; + +;;; +;;; methods +;;; + +(defmethod compute-style-flags ((dlg file-dialog) style &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 + do (cond + ((eq sym :add-to-recent) + (setf std-flags (logand std-flags (lognot gfs::+ofn-dontaddtorecent+)))) + ((eq sym :multiple-select) + (setf std-flags (logior std-flags gfs::+ofn-allowmultiselect+))) + ((eq sym :path-must-exist) + (setf std-flags (logior std-flags gfs::+ofn-filemustexist+))) + ((eq sym :show-hidden) + (setf std-flags (logior std-flags gfs::+ofn-forceshowhidden+))))) + (values std-flags 0))) + +(defmethod initialize-instance :after ((dlg 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. + ;; + (if (null owner) + (error 'gfs:toolkit-error :detail ":owner initarg is required")) + (if (gfs:disposed-p owner) + (error 'gfs:disposed-error)) + (let ((struct-ptr (cffi:foreign-alloc 'gfs::openfilename)) + (filters-buffer (if filters + (collect-foreign-strings (loop for entry in filters + append (list (car entry) (cdr entry)))) + (cffi:null-pointer))) + (title-buffer (cffi:null-pointer)) + (dir-buffer (cffi:null-pointer)) + (ext-buffer (cffi:null-pointer)) + (file-buffer (cffi:foreign-alloc :char :count 1024))) ; see FIXME above + (if text + (setf title-buffer (collect-foreign-strings (list text)))) + (if initial-directory + (setf dir-buffer (collect-foreign-strings (list initial-directory)))) + (if default-extension + (progn + (setf ext-buffer (collect-foreign-strings (list (remove #\. default-extension)))))) + (if initial-filename + (cffi:with-foreign-string (tmp-str (namestring initial-filename)) + (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 style) + (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 + gfs::ofninitialdir gfs::ofntitle gfs::ofnflags gfs::ofnfileoffset + gfs::ofnfileext gfs::ofndefext gfs::ofncustdata gfs::ofnhookfn + gfs::ofntemplname gfs::ofnpvreserved gfs::ofndwreserved gfs::ofnexflags) + struct-ptr gfs::openfilename) + (setf gfs::ofnsize (cffi:foreign-type-size 'gfs::openfilename) + gfs::ofnhwnd (gfs:handle owner) + gfs::ofnhinst (cffi:null-pointer) + gfs::ofnfilter filters-buffer + gfs::ofncustomfilter (cffi:null-pointer) + gfs::ofnmaxcustfilter 0 + gfs::ofnfilterindex 1 ; first pair of filter strings is identified by index 1 not 0 + gfs::ofnfile file-buffer + gfs::ofnmaxfile 1024 + gfs::ofnfiletitle (cffi:null-pointer) + gfs::ofnmaxfiletitle 0 + gfs::ofninitialdir dir-buffer + gfs::ofntitle title-buffer + gfs::ofnflags std-style + gfs::ofnfileoffset 0 + gfs::ofnfileext 0 + gfs::ofndefext ext-buffer + gfs::ofncustdata 0 + gfs::ofnhookfn (cffi:null-pointer) + gfs::ofntemplname (cffi:null-pointer) + gfs::ofnpvreserved (cffi:null-pointer) + gfs::ofndwreserved 0 + gfs::ofnexflags ex-style))) + (unwind-protect + (let ((fn (if (find :save style) #'gfs::get-save-filename #'gfs::get-open-filename))) + (if (and (zerop (funcall fn struct-ptr)) (/= (gfs::comm-dlg-extended-error) 0)) + (error 'gfs:comdlg-error :detail "file dialog function failed")) + (unless (or (cffi:null-pointer-p file-buffer) (= (cffi:mem-ref file-buffer :char) 0)) + (let* ((raw-list (extract-foreign-strings file-buffer)) + (dir-str (first raw-list))) + (if (cdr raw-list) + (setf (items dlg) (loop for filename in (cdr raw-list) + collect (parse-namestring (concatenate 'string dir-str "\\" filename)))) + (setf (items dlg) (list (parse-namestring dir-str))))))) + (cffi:foreign-free file-buffer) + (cffi:foreign-free filters-buffer) + (unless (cffi:null-pointer-p title-buffer) + (cffi:foreign-free title-buffer)) + (unless (cffi:null-pointer-p dir-buffer) + (cffi:foreign-free dir-buffer)) + (unless (cffi:null-pointer-p ext-buffer) + (cffi:foreign-free ext-buffer)) + (cffi:foreign-free struct-ptr)))) Modified: trunk/src/uitoolkit/widgets/menu-language.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu-language.lisp (original) +++ trunk/src/uitoolkit/widgets/menu-language.lisp Mon Apr 24 02:38:32 2006 @@ -208,7 +208,7 @@ (put-menuitem (thread-context) it) (insert-separator hmenu) (setf (slot-value it 'gfs:handle) hmenu) - (vector-push-extend it (items owner)))) + (push it (items owner)))) (defmethod define-submenu ((gen win32-menu-generator) label dispatcher disabled) (let* ((submenu (make-instance 'menu :handle (gfs::create-popup-menu))) Modified: trunk/src/uitoolkit/widgets/menu.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu.lisp (original) +++ trunk/src/uitoolkit/widgets/menu.lisp Mon Apr 24 02:38:32 2006 @@ -119,8 +119,8 @@ nil))) (defun visit-menu-tree (menu fn) - (dotimes (index (item-count menu)) - (let ((it (item-at menu index)) + (dotimes (index (length (items menu))) + (let ((it (elt (items menu) index)) (child (sub-menu menu index))) (unless (null child) (visit-menu-tree child fn)) @@ -139,7 +139,7 @@ (insert-menuitem hmenu id text (cffi:null-pointer)) (setf (item-id item) id) (put-menuitem tc item) - (vector-push-extend item (items owner)) + (push item (items owner)) item)) (defmethod append-submenu ((parent menu) text (submenu menu) disp) @@ -153,7 +153,7 @@ (insert-submenu hparent id text (cffi:null-pointer) hmenu) (setf (item-id item) id) (put-menuitem tc item) - (vector-push-extend item (items parent)) + (push item (items parent)) (put-widget tc submenu) (cond ((null disp)) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Mon Apr 24 02:38:32 2006 @@ -77,10 +77,15 @@ (defclass widget-with-items (widget) ((items :accessor items - ;; FIXME: allow subclasses to set initial size? - :initform (make-array 7 :fill-pointer 0 :adjustable t))) + :initform nil)) (:documentation "The widget-with-items class is the base class for objects composed of sub-items.")) +(defclass dialog (widget-with-items) () + (:documentation "The dialog class is the base class for both system-defined and application-defined dialogs.")) + +(defclass file-dialog (dialog) () + (:documentation "This class represents the standard file open/save dialog.")) + (defclass menu (widget-with-items) () (:documentation "The menu class represents a container for menu items (and submenus).")) Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Mon Apr 24 02:38:32 2006 @@ -183,12 +183,6 @@ (defgeneric image (self) (:documentation "Returns the object's image object if it has one, or nil otherwise.")) -(defgeneric item-at (self index) - (:documentation "Return the item at the given zero-based index from the object.")) - -(defgeneric item-count (self) - (:documentation "Return the number of items possessed by the object.")) - (defgeneric item-height (self) (:documentation "Return the height of the area if one of the object's items were displayed.")) Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Mon Apr 24 02:38:32 2006 @@ -41,6 +41,7 @@ (run-default-message-loop)) #+lispworks (defun startup (thread-name start-fn) + (hcl:add-special-free-action 'gfs::native-object-special-action) (gfg::initialize-magick (cffi:null-pointer)) (when (null (mp:list-all-processes)) (mp:initialize-multiprocessing)) @@ -55,7 +56,7 @@ (gfs::post-quit-message exit-code)) (defun clear-all (w) - (let ((count (gfw:item-count w))) + (let ((count (length (items w)))) (unless (zerop count) (gfw:clear-span w (gfs:make-span :start 0 :end (1- count)))))) @@ -129,3 +130,24 @@ (setf hfont (cffi:make-pointer (gfs::send-message hwnd gfs::+wm-getfont+ 0 0))) (gfs::with-hfont-selected (hdc hfont) (gfg::text-bounds hdc (text widget) dt-flags 0))))) + +(defun extract-foreign-strings (buffer) + (let ((strings nil)) + (do ((curr-ptr buffer)) + ((zerop (cffi:mem-ref curr-ptr :char))) + (let ((tmp (cffi:foreign-string-to-lisp curr-ptr))) + (push tmp strings) + (setf curr-ptr (cffi:make-pointer (+ (cffi:pointer-address curr-ptr) (1+ (length tmp))))))) + (reverse strings))) + +(defun collect-foreign-strings (strings) + (let* ((total-size (1+ (loop for str in strings + sum (1+ (length (namestring str)))))) + (buffer (cffi:foreign-alloc :char :initial-element 0 :count total-size)) + (curr-addr (cffi:pointer-address buffer))) + (loop for str in strings + do (let* ((tmp-str (namestring str)) + (str-len (1+ (length tmp-str)))) + (cffi:lisp-string-to-foreign tmp-str (cffi:make-pointer curr-addr) str-len) + (incf curr-addr str-len))) + buffer)) 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 Apr 24 02:38:32 2006 @@ -44,8 +44,9 @@ (error 'gfs:disposed-error))) (defmethod clear-item ((w widget-with-items) index) - (let ((it (item-at w index))) - (delete it (items w) :test #'items-equal-p) + (let* ((items (items w)) + (it (elt items index))) + (setf (items w) (remove-if #'(lambda (x) (items-equal-p x it)) items)) (if (gfs:disposed-p it) (error 'gfs:disposed-error)) (gfs:dispose it))) @@ -59,26 +60,6 @@ (dotimes (i (1+ (- (gfs:span-end sp) (gfs:span-start sp)))) (clear-item w (gfs:span-start sp)))) -(defmethod item-at :before ((w widget-with-items) index) - (declare (ignore index)) - (if (gfs:disposed-p w) - (error 'gfs:disposed-error))) - -(defmethod item-at ((w widget-with-items) index) - (elt (items w) index)) - -(defmethod (setf item-at) :before (index (it item) (w widget-with-items)) - (declare (ignorable index it)) - (if (gfs:disposed-p w) - (error 'gfs:disposed-error))) - -(defmethod item-count :before ((w widget-with-items)) - (if (gfs:disposed-p w) - (error 'gfs:disposed-error))) - -(defmethod item-count ((w widget-with-items)) - (length (items w))) - (defmethod item-index :before ((w widget-with-items) (it item)) (declare (ignore it)) (if (gfs:disposed-p w)

1 0

[graphic-forms-cvs] r102 - in trunk: . src/uitoolkit/system
by junrue＠common-lisp.net 18 Apr '06

18 Apr '06

Author: junrue Date: Tue Apr 18 00:51:57 2006 New Revision: 102 Added: trunk/src/uitoolkit/system/comdlg32.lisp Modified: trunk/graphic-forms-uitoolkit.asd trunk/src/uitoolkit/system/system-conditions.lisp trunk/src/uitoolkit/system/system-types.lisp Log: initial infrastructure for open/save dialogs Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Tue Apr 18 00:51:57 2006 @@ -59,6 +59,7 @@ (:file "system-types") (:file "datastructs") (:file "clib") + (:file "comdlg32") (:file "gdi32") (:file "kernel32") (:file "user32") Added: trunk/src/uitoolkit/system/comdlg32.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/system/comdlg32.lisp Tue Apr 18 00:51:57 2006 @@ -0,0 +1,53 @@ +;;;; +;;;; comdlg32.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.system) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (use-package :cffi)) + +(load-foreign-library "comdlg32.dll") + +(defcfun + ("CommDlgExtendedError" comm-dlg-extended-error) + DWORD) + +(defcfun + ("GetOpenFileNameA" get-open-filename) + BOOL + (ofn LPTR)) + +(defcfun + ("GetSaveFileNameA" get-save-filename) + BOOL + (ofn LPTR)) Modified: trunk/src/uitoolkit/system/system-conditions.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-conditions.lisp (original) +++ trunk/src/uitoolkit/system/system-conditions.lisp Tue Apr 18 00:51:57 2006 @@ -62,3 +62,10 @@ (defmethod print-object ((obj win32-warning) stream) (print-unreadable-object (obj stream :type t) (format stream "~s: error code: ~a" (detail obj) (code obj)))) + +(define-condition comdlg-error (win32-error) + ((dlg-code :reader dlg-code :initarg :dlg-code :initform (comm-dlg-extended-error)))) + +(defmethod print-object ((obj comdlg-error) stream) + (print-unreadable-object (obj stream :type t) + (format stream "~s: common dialog error code: ~a" (detail obj) (dlg-code obj)))) Modified: trunk/src/uitoolkit/system/system-types.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-types.lisp (original) +++ trunk/src/uitoolkit/system/system-types.lisp Tue Apr 18 00:51:57 2006 @@ -208,6 +208,31 @@ (flags DWORD) (device TCHAR :count 32)) ; CCHDEVICENAME +(defcstruct openfilename + (ofnsize DWORD) + (ofnhwnd HANDLE) + (ofnhinst HANDLE) + (ofnfilter :string) + (ofncustomfilter :string) + (ofnmaxcustfilter DWORD) + (ofnfilterindex DWORD) + (ofnfile :string) + (ofnmaxfile DWORD) + (ofnfiletitle :string) + (ofnmaxfiletitle DWORD) + (ofninitialdir :string) + (ofntitle :string) + (ofnflags DWORD) + (ofnfileoffset WORD) + (ofnfileext WORD) + (ofndefext :string) + (ofncustdata LPARAM) + (ofnhookfn LPTR) + (ofntemplname :string) + (ofnpvreserved LPTR) + (ofndwreserved DWORD) + (ofnexflags DWORD)) + (defcstruct rgbquad (rgbblue BYTE) (rgbgreen BYTE)

1 0

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

17 Apr '06

Author: junrue Date: Mon Apr 17 00:31:21 2006 New Revision: 101 Modified: trunk/src/demos/unblocked/double-buffered-event-dispatcher.lisp trunk/src/tests/uitoolkit/drawing-tester.lisp trunk/src/tests/uitoolkit/hello-world.lisp trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/tests/uitoolkit/windlg.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp Log: every event-source gets a default dispatcher now (subclasses or application can override the default, of course); minor cleanup of some places that instantiate gfs:rectangle which can use the default coordinate of (0,0) Modified: trunk/src/demos/unblocked/double-buffered-event-dispatcher.lisp ============================================================================== --- trunk/src/demos/unblocked/double-buffered-event-dispatcher.lisp (original) +++ trunk/src/demos/unblocked/double-buffered-event-dispatcher.lisp Mon Apr 17 00:31:21 2006 @@ -49,8 +49,7 @@ (let ((image (image-buffer-of self))) (setf (gfg:background-color gc) *background-color*) (setf (gfg:foreground-color gc) *background-color*) - (gfg:draw-filled-rectangle gc (make-instance 'gfs:rectangle :location (gfs:make-point) - :size (gfg:size image))))) + (gfg:draw-filled-rectangle gc (make-instance 'gfs:rectangle :size (gfg:size image))))) (defmethod dispose ((self double-buffered-event-dispatcher)) (let ((image (image-buffer-of self))) Modified: trunk/src/tests/uitoolkit/drawing-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/drawing-tester.lisp (original) +++ trunk/src/tests/uitoolkit/drawing-tester.lisp Mon Apr 17 00:31:21 2006 @@ -69,9 +69,7 @@ (declare (ignore time rect)) (setf (gfg:background-color gc) gfg:*color-white*) (setf (gfg:foreground-color gc) gfg:*color-white*) - (gfg:draw-filled-rectangle gc - (make-instance 'gfs:rectangle :location (gfs:make-point) - :size (gfw:client-size window))) + (gfg:draw-filled-rectangle gc (make-instance 'gfs:rectangle :size (gfw:client-size window))) (let ((func (draw-func-of self))) (unless (null func) (funcall func gc)))) Modified: trunk/src/tests/uitoolkit/hello-world.lisp ============================================================================== --- trunk/src/tests/uitoolkit/hello-world.lisp (original) +++ trunk/src/tests/uitoolkit/hello-world.lisp Mon Apr 17 00:31:21 2006 @@ -48,12 +48,10 @@ (exit-fn disp nil time nil)) (defmethod gfw:event-paint ((disp hellowin-events) window time gc rect) - (declare (ignore time)) - (setf rect (make-instance 'gfs:rectangle :location (gfs:make-point) - :size (gfw:client-size window))) + (declare (ignore time rect)) (setf (gfg:background-color gc) gfg:*color-white*) (setf (gfg:foreground-color gc) gfg:*color-white*) - (gfg:draw-filled-rectangle gc rect) + (gfg:draw-filled-rectangle gc (make-instance 'gfs:rectangle :size (gfw:client-size window))) (setf (gfg:background-color gc) gfg:*color-red*) (setf (gfg:foreground-color gc) gfg:*color-green*) (gfg:draw-text gc "Hello World!" (gfs:make-point))) Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Mon Apr 17 00:31:21 2006 @@ -74,9 +74,7 @@ (declare (ignore time rect)) (setf (gfg:background-color gc) gfg:*color-white*) (setf (gfg:foreground-color gc) gfg:*color-white*) - (gfg:draw-filled-rectangle gc - (make-instance 'gfs:rectangle :location (gfs:make-point) - :size (gfw:client-size window)))) + (gfg:draw-filled-rectangle gc (make-instance 'gfs:rectangle :size (gfw:client-size window)))) (defclass test-panel (gfw:panel) ()) Modified: trunk/src/tests/uitoolkit/windlg.lisp ============================================================================== --- trunk/src/tests/uitoolkit/windlg.lisp (original) +++ trunk/src/tests/uitoolkit/windlg.lisp Mon Apr 17 00:31:21 2006 @@ -50,12 +50,10 @@ (defclass test-win-events (gfw:event-dispatcher) ()) (defmethod gfw:event-paint ((d test-win-events) window time gc rect) - (declare (ignore time)) - (setf rect (make-instance 'gfs:rectangle :location (gfs:make-point) - :size (gfw:client-size window))) + (declare (ignore time rect)) (setf (gfg:background-color gc) gfg:*color-white*) (setf (gfg:foreground-color gc) gfg:*color-white*) - (gfg:draw-filled-rectangle gc rect)) + (gfg:draw-filled-rectangle gc (make-instance 'gfs:rectangle :size (gfw:client-size window)))) (defclass test-mini-events (test-win-events) ()) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Mon Apr 17 00:31:21 2006 @@ -46,7 +46,7 @@ ((dispatcher :accessor dispatcher :initarg :dispatcher - :initform nil)) + :initform (make-instance 'event-dispatcher))) (:documentation "This is the base class for user interface objects that generate events.")) (defclass item (event-source)

1 0

[graphic-forms-cvs] r100 - trunk/src/uitoolkit/widgets
by junrue＠common-lisp.net 17 Apr '06

17 Apr '06

Author: junrue Date: Sun Apr 16 23:59:10 2006 New Revision: 100 Modified: trunk/src/uitoolkit/widgets/event-source.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/flow-layout.lisp trunk/src/uitoolkit/widgets/top-level.lisp trunk/src/uitoolkit/widgets/widget.lisp trunk/src/uitoolkit/widgets/window.lisp Log: fixed a bug in with-children macro where I shouldn't have been using ancestor-p to filter the results from enum-child-windows; added a couple of debug statements enabled with #+gf-debug-widgets; added a couple strategic implementations of print-object to aid debugging Modified: trunk/src/uitoolkit/widgets/event-source.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event-source.lisp (original) +++ trunk/src/uitoolkit/widgets/event-source.lisp Sun Apr 16 23:59:10 2006 @@ -81,3 +81,8 @@ (defmethod parent :before ((self event-source)) (if (gfs:disposed-p self) (error 'gfs:disposed-error))) + +(defmethod print-object ((self event-source) stream) + (print-unreadable-object (self stream :type t) + (format stream "handle: ~x " (gfs:handle self)) + (format stream "dispatcher: ~a " (dispatcher self)))) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Sun Apr 16 23:59:10 2006 @@ -357,6 +357,7 @@ (t nil)))) (when w (outer-size w (size-event-size tc)) + #+gf-debug-widgets (format t "about to call event-resize: ~a~%" hwnd) (event-resize (dispatcher w) w (event-time tc) (size-event-size tc) type))) 0) Modified: trunk/src/uitoolkit/widgets/flow-layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/flow-layout.lisp (original) +++ trunk/src/uitoolkit/widgets/flow-layout.lisp Sun Apr 16 23:59:10 2006 @@ -131,6 +131,7 @@ (defmethod compute-layout ((layout flow-layout) (win window) width-hint height-hint) (with-children (win kids) + #+gf-debug-widgets (format t "compute-layout: ~a~%~a~%" win kids) (flow-container-layout layout (visible-p win) kids width-hint height-hint))) (defmethod initialize-instance :after ((layout flow-layout) Modified: trunk/src/uitoolkit/widgets/top-level.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/top-level.lisp (original) +++ trunk/src/uitoolkit/widgets/top-level.lisp Sun Apr 16 23:59:10 2006 @@ -183,6 +183,14 @@ (setf (size win) size) (perform-layout win (gfs:size-width size) (gfs:size-height size))))) +(defmethod print-object ((self top-level) stream) + (print-unreadable-object (self stream :type t) + (format stream "handle: ~x " (gfs:handle self)) + (format stream "dispatcher: ~a " (dispatcher self)) + (format stream "client size: ~a " (size self)) + (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) (error 'gfs:disposed-error))) Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Sun Apr 16 23:59:10 2006 @@ -233,6 +233,12 @@ (error 'gfs:toolkit-error :detail "no widget for hwnd"))) widget)) +(defmethod print-object ((self widget) stream) + (print-unreadable-object (self stream :type t) + (format stream "handle: ~x " (gfs:handle self)) + (format stream "dispatcher: ~a " (dispatcher self)) + (format stream "client size: ~a" (size self)))) + (defmethod redraw :before ((w widget)) (if (gfs:disposed-p w) (error 'gfs:disposed-error))) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Sun Apr 16 23:59:10 2006 @@ -138,12 +138,14 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (defmacro with-children ((win var) &body body) - `(let ((,var nil)) - (visit-child-widgets ,win #'(lambda (parent child) - (when (gfw:ancestor-p parent child) - (push child ,var)))) - (setf ,var (reverse ,var)) - ,@body))) + (let ((hwnd (gensym))) + `(let ((,var nil)) + (visit-child-widgets ,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 ,var))))) + (setf ,var (reverse ,var)) + ,@body)))) ;;; ;;; methods

1 0

[graphic-forms-cvs] r99 - trunk/docs/manual
by junrue＠common-lisp.net 16 Apr '06

16 Apr '06

Author: junrue Date: Sun Apr 16 02:16:53 2006 New Revision: 99 Modified: trunk/docs/manual/api.texinfo Log: documented :file initarg for image class Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Sun Apr 16 02:16:53 2006 @@ -935,6 +935,9 @@ This subclass of @ref{native-object} wraps a native image object. Instances may be drawn directly via a graphics-context (see @ref{draw-image}) or set as the content of a @ref{label} control. +@deffn Initarg :file +Supply a path to a file containing image data to be loaded. +@end deffn @deffn Initarg :size Supply a @ref{size} object via this initarg to create a new image object with the desired width and height.

1 0

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

16 Apr '06

Author: junrue Date: Sun Apr 16 02:14:03 2006 New Revision: 98 Modified: trunk/docs/manual/api.texinfo trunk/src/packages.lisp trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/uitoolkit/graphics/image.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/system/user32.lisp trunk/src/uitoolkit/widgets/button.lisp trunk/src/uitoolkit/widgets/control.lisp trunk/src/uitoolkit/widgets/label.lisp trunk/src/uitoolkit/widgets/panel.lisp trunk/src/uitoolkit/widgets/top-level.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp trunk/src/uitoolkit/widgets/window.lisp Log: revised label control to support both text and image content Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Sun Apr 16 02:14:03 2006 @@ -238,9 +238,46 @@ @end deffn @end deftp +@anchor{label} @deftp Class label -This @ref{control} class represents non-selectable controls that -display a string or image. +This @ref{control} subclass represents non-selectable controls that +display a string, image, or etched line. +@deffn Initarg :image +Supply an @ref{image} object as the value of this initarg to configure +the label to display the image rather than text. +@end deffn +@deffn Initarg :separator +Supply @sc{t} for the value of this initarg to configure the label to +render itself as an etched horizontal (or vertical) divider. The +@code{:style} initarg is used to select the desired orientation. +@end deffn +@deffn Initarg :style +When configured as a @code{text} label, the following keyword symbols +are relevant: +@itemize bullet +@item @code{:beginning} +@item @code{:center} +@item @code{:ellipsis} +@item @code{:end} +@item @code{:wrap} +@end itemize +The following style style keywords apply for both @code{text} and +@code{image} modes: +@itemize bullet +@item @code{:raised} +@item @code{:sunken} +@end itemize +Finally, the following style keywords apply when a label is +configured as a @code{separator}: +@itemize bullet +@item @code{:horizontal} +@item @code{:vertical} +@end itemize +@end deffn +@deffn Initarg :text +Supply a string as the value of this initarg to configure the label to +act as a text label. This mode is also the default. +@end deffn @end deftp @anchor{menu} @@ -893,9 +930,22 @@ @end deffn @end deftp +@anchor{image} +@deftp Class image +This subclass of @ref{native-object} wraps a native image object. +Instances may be drawn directly via a graphics-context (see +@ref{draw-image}) or set as the content of a @ref{label} control. +@deffn Initarg :size +Supply a @ref{size} object via this initarg to create a new image +object with the desired width and height. +@end deffn +@xref{image-data}. +@end deftp + +@anchor{image-data} @deftp Class image-data This subclass of @ref{native-object} maintains image attributes, -color, and pixel data. +color, and pixel data. @xref{image}. @end deftp @node graphics functions @@ -1020,6 +1070,7 @@ determined by @code{arc-size}. @end deffn +@anchor{draw-image} @deffn GenericFunction draw-image self image point Draws @code{image} in the receiver where @code{point} identifies the position of the upper-left corner of the image. Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Sun Apr 16 02:14:03 2006 @@ -184,6 +184,7 @@ #:multiply #:pen-style #:pen-width + #:rgb->color #:red-mask #:red-shift #:rotate Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Sun Apr 16 02:14:03 2006 @@ -103,6 +103,12 @@ (setf flag nil) (format nil "~d ~a" (id be) +btn-text-after+)))))) (setf (gfw:text w) (funcall (toggle-fn be)))) + ((eql subtype :image-label) + ;; NOTE: we are leaking a bitmap handle by not tracking the + ;; image being created here + (let ((tmp-image (make-instance 'gfg:image :file "happy.bmp"))) + (gfg:with-image-transparency (tmp-image (gfs:make-point)) + (setf (gfw:image w) tmp-image)))) ((eql subtype :text-label) (setf (gfw:text w) (format nil "~d ~a" (id be) +label-text+)))) (incf *widget-counter*))) @@ -350,6 +356,8 @@ (add-btn-disp (make-instance 'add-child-dispatcher)) (add-panel-disp (make-instance 'add-child-dispatcher :widget-class 'test-panel :subtype :panel)) + (add-image-label-disp (make-instance 'add-child-dispatcher :widget-class 'gfw:label + :subtype :image-label)) (add-text-label-disp (make-instance 'add-child-dispatcher :widget-class 'gfw:label :subtype :text-label)) (rem-menu-disp (make-instance 'child-menu-dispatcher :sub-disp-class 'remove-child-dispatcher)) @@ -366,7 +374,8 @@ (:item "&Children" :submenu ((:item "Add" :submenu ((:item "Button" :dispatcher add-btn-disp) - (:item "Label" :dispatcher add-text-label-disp) + (:item "Label - Image" :dispatcher add-image-label-disp) + (:item "Label - Text" :dispatcher add-text-label-disp) (:item "Panel" :dispatcher add-panel-disp))) (:item "Remove" :dispatcher rem-menu-disp :submenu ((:item ""))) Modified: trunk/src/uitoolkit/graphics/image.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/image.lisp (original) +++ trunk/src/uitoolkit/graphics/image.lisp Sun Apr 16 02:14:03 2006 @@ -82,25 +82,28 @@ (gfs:dispose im)) (setf (slot-value im 'gfs:handle) (data->image id))) -(defmethod initialize-instance :after ((image image) &key size &allow-other-keys) - (unless (null size) - (cffi:with-foreign-object (bih-ptr 'gfs::bitmapinfoheader) - (gfs::zero-mem bih-ptr gfs::bitmapinfoheader) - (cffi:with-foreign-slots ((gfs::bisize gfs::biwidth gfs::biheight gfs::biplanes - gfs::bibitcount gfs::bicompression) - bih-ptr gfs::bitmapinfoheader) - (setf gfs::bisize (cffi:foreign-type-size 'gfs::bitmapinfoheader) - gfs::biwidth (gfs:size-width size) - gfs::biheight (- (gfs:size-height size)) - gfs::biplanes 1 - gfs::bibitcount 32 - gfs::bicompression gfs::+bi-rgb+) - (let ((nptr (cffi:null-pointer)) - (hbmp (cffi:null-pointer))) - (cffi:with-foreign-object (buffer :pointer) - (gfs::with-compatible-dcs (nptr memdc) - (setf hbmp (gfs::create-dib-section memdc bih-ptr gfs::+dib-rgb-colors+ buffer nptr 0)))) - (setf (slot-value image 'gfs:handle) hbmp)))))) +(defmethod initialize-instance :after ((image image) &key file size &allow-other-keys) + (cond + (file + (load image file)) + (size + (cffi:with-foreign-object (bih-ptr 'gfs::bitmapinfoheader) + (gfs::zero-mem bih-ptr gfs::bitmapinfoheader) + (cffi:with-foreign-slots ((gfs::bisize gfs::biwidth gfs::biheight gfs::biplanes + gfs::bibitcount gfs::bicompression) + bih-ptr gfs::bitmapinfoheader) + (setf gfs::bisize (cffi:foreign-type-size 'gfs::bitmapinfoheader) + gfs::biwidth (gfs:size-width size) + gfs::biheight (- (gfs:size-height size)) + gfs::biplanes 1 + gfs::bibitcount 32 + gfs::bicompression gfs::+bi-rgb+) + (let ((nptr (cffi:null-pointer)) + (hbmp (cffi:null-pointer))) + (cffi:with-foreign-object (buffer :pointer) + (gfs::with-compatible-dcs (nptr memdc) + (setf hbmp (gfs::create-dib-section memdc bih-ptr gfs::+dib-rgb-colors+ buffer nptr 0)))) + (setf (slot-value image 'gfs:handle) hbmp))))))) (defmethod load ((im image) path) (let ((data (make-instance 'image-data))) @@ -127,18 +130,20 @@ (hbmp (gfs:handle im)) (hmask (cffi:null-pointer)) (nptr (cffi:null-pointer))) - (unless (null pixel-pnt) - (cffi:with-foreign-object (bmp-ptr 'gfs::bitmap) - (gfs::get-object (gfs:handle im) (cffi:foreign-type-size 'gfs::bitmap) bmp-ptr) - (cffi:with-foreign-slots ((gfs::width gfs::height) bmp-ptr gfs::bitmap) - (setf hmask (gfs::create-bitmap gfs::width gfs::height 1 1 (cffi:null-pointer))) - (if (gfs:null-handle-p hmask) - (error 'gfs:win32-error :detail "create-bitmap failed")) - (gfs::with-compatible-dcs (nptr memdc1 memdc2) - (gfs::select-object memdc1 hbmp) - (gfs::set-bk-color memdc1 (gfs::get-pixel memdc1 - (gfs:point-x pixel-pnt) - (gfs:point-y pixel-pnt))) - (gfs::select-object memdc2 hmask) - (gfs::bit-blt memdc2 0 0 gfs::width gfs::height memdc1 0 0 gfs::+blt-srccopy+))) - (make-instance 'image :handle hmask))))) + (if pixel-pnt + (progn + (cffi:with-foreign-object (bmp-ptr 'gfs::bitmap) + (gfs::get-object (gfs:handle im) (cffi:foreign-type-size 'gfs::bitmap) bmp-ptr) + (cffi:with-foreign-slots ((gfs::width gfs::height) bmp-ptr gfs::bitmap) + (setf hmask (gfs::create-bitmap gfs::width gfs::height 1 1 (cffi:null-pointer))) + (if (gfs:null-handle-p hmask) + (error 'gfs:win32-error :detail "create-bitmap failed")) + (gfs::with-compatible-dcs (nptr memdc1 memdc2) + (gfs::select-object memdc1 hbmp) + (gfs::set-bk-color memdc1 (gfs::get-pixel memdc1 + (gfs:point-x pixel-pnt) + (gfs:point-y pixel-pnt))) + (gfs::select-object memdc2 hmask) + (gfs::bit-blt memdc2 0 0 gfs::width gfs::height memdc1 0 0 gfs::+blt-srccopy+)))) + (make-instance 'image :handle hmask)) + nil))) Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Sun Apr 16 02:14:03 2006 @@ -602,6 +602,17 @@ (defconstant +ss-wordellipsis+ #x0000C000) (defconstant +ss-ellipsismask+ #x0000C000) +(defconstant +stm-seticon+ #x0170) +(defconstant +stm-geticon+ #x0171) +(defconstant +stm-setimage+ #x0172) +(defconstant +stm-getimage+ #x0173) +(defconstant +stm-msgmax+ #x0174) + +(defconstant +stn-clicked+ 0) +(defconstant +stn-dblclk+ 1) +(defconstant +stn-enable+ 2) +(defconstant +stn-disable+ 3) + (defconstant +sw-hide+ 0) (defconstant +sw-shownormal+ 1) (defconstant +sw-normal+ 1) Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Sun Apr 16 02:14:03 2006 @@ -323,6 +323,11 @@ (pos INT)) (defcfun + ("GetSysColor" get-sys-color) + DWORD + (index INT)) + +(defcfun ("GetSystemMetrics" get-system-metrics) INT (index INT)) Modified: trunk/src/uitoolkit/widgets/button.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/button.lisp (original) +++ trunk/src/uitoolkit/widgets/button.lisp Sun Apr 16 02:14:03 2006 @@ -37,8 +37,8 @@ ;;; methods ;;; -(defmethod compute-style-flags ((btn button) style) - (declare (ignore btn)) +(defmethod compute-style-flags ((btn button) style &rest extra-data) + (declare (ignore btn extra-data)) (let ((std-flags 0) (ex-flags 0)) (setf style (gfs:flatten style)) Modified: trunk/src/uitoolkit/widgets/control.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/control.lisp (original) +++ trunk/src/uitoolkit/widgets/control.lisp Sun Apr 16 02:14:03 2006 @@ -53,6 +53,14 @@ ;;; methods ;;; +(defmethod background-color :before ((ctrl control)) + (if (gfs:disposed-p ctrl) + (error 'gfs:disposed-error))) + +(defmethod background-color ((ctrl control)) + (declare (ignore ctrl)) + (gfg:rgb->color (gfs::get-sys-color gfs::+color-btnface+))) + (defmethod initialize-instance :after ((ctrl control) &key parent &allow-other-keys) (if (gfs:disposed-p parent) (error 'gfs:disposed-error))) Modified: trunk/src/uitoolkit/widgets/label.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/label.lisp (original) +++ trunk/src/uitoolkit/widgets/label.lisp Sun Apr 16 02:14:03 2006 @@ -37,77 +37,157 @@ ;;; methods ;;; -(defmethod compute-style-flags ((label label) style) - (declare (ignore label)) - (let ((std-flags 0) - (ex-flags 0)) - (setf style (gfs:flatten style)) - (unless (or (find :beginning style) - (find :center style) - (find :end style)) - (setf std-flags gfs::+ss-leftnowordwrap+)) +(defun compute-image-style-flags (style) + (let ((flags (logior gfs::+ss-bitmap+ gfs::+ss-realsizeimage+ gfs::+ss-centerimage+))) + (when (find :raised style) + (setf flags (logand (lognot gfs::+ss-sunken+) flags)) + (setf flags (logior flags gfs::+ss-etchedframe+))) + (when (find :sunken style) + (setf flags (logand (lognot gfs::+ss-etchedframe+) flags)) + (setf flags (logior flags gfs::+ss-sunken+))) + flags)) + +(defun compute-text-style-flags (style) + (let ((flags 0)) + (unless (intersection style (list :beginning :center :end)) + (setf flags gfs::+ss-leftnowordwrap+)) (loop for sym in style do (cond - ;; primary static styles + ;; primary text static styles ;; ((eq sym :beginning) - (setf std-flags gfs::+ss-leftnowordwrap+)) ; FIXME: i18n + (setf flags gfs::+ss-leftnowordwrap+)) ; FIXME: i18n ((eq sym :center) - (setf std-flags gfs::+ss-center+)) + (setf flags gfs::+ss-center+)) ((eq sym :end) - (setf std-flags gfs::+ss-right+)) ; FIXME: i18n + (setf flags gfs::+ss-right+)) ; FIXME: i18n ;; styles that can be combined ;; ((eq sym :ellipsis) - (setf std-flags (logior std-flags gfs::+ss-endellipsis+))) + (setf flags (logior flags gfs::+ss-endellipsis+))) ((eq sym :raised) - (setf std-flags (logand (lognot gfs::+ss-sunken+) std-flags)) - (setf std-flags (logior std-flags gfs::+ss-etchedframe+))) + (setf flags (logand (lognot gfs::+ss-sunken+) flags)) + (setf flags (logior flags gfs::+ss-etchedframe+))) ((eq sym :sunken) - (setf std-flags (logand (lognot gfs::+ss-etchedframe+) std-flags)) - (setf std-flags (logior std-flags gfs::+ss-sunken+))) + (setf flags (logand (lognot gfs::+ss-etchedframe+) flags)) + (setf flags (logior flags gfs::+ss-sunken+))) ((eq sym :wrap) - (setf std-flags (logand (lognot gfs::+ss-leftnowordwrap+) std-flags)) - (setf std-flags (logior std-flags gfs::+ss-left+))))) - (values std-flags ex-flags))) + (setf flags (logand (lognot gfs::+ss-leftnowordwrap+) flags)) + (setf flags (logior flags gfs::+ss-left+))))) + flags)) + +(defmethod compute-style-flags ((label label) style &rest extra-data) + (declare (ignore label)) + (if (> (count-if-not #'null extra-data) 1) + (error 'gfs:toolkit-error :detail "only one of :image, :separator, or :text are allowed")) + (values (cond + ((first extra-data) + (compute-image-style-flags (gfs:flatten style))) + ((second extra-data) + (if (find :vertical style) gfs::+ss-etchedvert+ gfs::+ss-etchedhorz+)) + (t + (compute-text-style-flags (gfs:flatten style)))) + 0)) + +(defmethod image ((label label)) + (if (gfs:disposed-p label) + (error 'gfs:disposed-error)) + (let ((addr (gfs::send-message (gfs:handle label) gfs::+stm-getimage+ gfs::+image-bitmap+ 0))) + (if (zerop addr) + nil + (make-instance 'gfg:image :handle (cffi:make-pointer addr))))) + +(defmethod (setf image) ((image gfg:image) (label label)) + (if (or (gfs:disposed-p label) (gfs:disposed-p image)) + (error 'gfs:disposed-error)) + (let* ((hwnd (gfs:handle label)) + (orig-flags (gfs::get-window-long hwnd gfs::+gwl-style+)) + (etch-flags (logior (logand orig-flags gfs::+ss-etchedframe+) + (logand orig-flags gfs::+ss-sunken+))) + (flags (logior etch-flags + gfs::+ss-bitmap+ + gfs::+ss-realsizeimage+ + gfs::+ss-centerimage+ + gfs::+ws-child+ + gfs::+ws-visible+)) + (tr-pnt (gfg:transparency-pixel-of image))) + (if tr-pnt + (let* ((color (background-color label)) + (size (gfg:size image)) + (bounds (make-instance 'gfs:rectangle :size size)) + (tmp-image (make-instance 'gfg:image :size size)) + (gc (make-instance 'gfg:graphics-context :image tmp-image))) + (unwind-protect + (progn + (setf (gfg:background-color gc) color) + (let ((orig-color (gfg:foreground-color gc))) + (setf (gfg:foreground-color gc) color) + (gfg:draw-filled-rectangle gc bounds) + (setf (gfg:foreground-color gc) orig-color)) + (gfg:draw-image gc image (gfs:location bounds))) + (gfs:dispose gc)) + (setf image tmp-image))) + (if (/= orig-flags flags) + (gfs::set-window-long hwnd gfs::+gwl-style+ flags)) + (gfs::send-message hwnd + gfs::+stm-setimage+ + gfs::+image-bitmap+ + (cffi:pointer-address (gfs:handle image))))) -(defmethod initialize-instance :after ((label label) &key parent style &allow-other-keys) +(defmethod initialize-instance :after ((label label) &key image parent separator style text &allow-other-keys) (if (not (listp style)) (setf style (list style))) (multiple-value-bind (std-style ex-style) - (compute-style-flags label style) + (compute-style-flags label style image separator text) (let ((hwnd (create-window gfs::+static-classname+ - " " + (or text " ") (gfs:handle parent) (logior std-style gfs::+ws-child+ gfs::+ws-visible+) ex-style))) (if (not hwnd) (error 'gfs:win32-error :detail "create-window failed")) - (setf (slot-value label 'gfs:handle) hwnd))) + (setf (slot-value label 'gfs:handle) hwnd) + (if image + (setf (image label) image)))) (init-control label)) - (defmethod preferred-size ((label label) width-hint height-hint) + (declare (ignorable width-hint height-hint)) (let* ((hwnd (gfs:handle label)) (bits (gfs::get-window-long hwnd gfs::+gwl-style+)) (b-width (border-width label)) - (sz nil) - (flags (logior gfs::+dt-editcontrol+ - gfs::+dt-expandtabs+))) - (if (and (= (logand bits gfs::+ss-left+) gfs::+ss-left+) (> width-hint 0)) - (setf flags (logior flags gfs::+dt-wordbreak+))) - (setf sz (widget-text-size label flags)) - (if (>= width-hint 0) - (setf (gfs:size-width sz) width-hint)) - (if (>= height-hint 0) - (setf (gfs:size-height sz) height-hint)) - (incf (gfs:size-width sz) (* b-width 2)) - (incf (gfs:size-height sz) (* b-width 2)) - sz)) + (sz nil)) + (if (= (logand bits gfs::+ss-bitmap+) gfs::+ss-bitmap+) ; SS_BITMAP is not a single bit + (let ((image (image label))) + (if image + (gfg:size image) + (gfs:make-size))) + (let ((flags (logior gfs::+dt-editcontrol+ gfs::+dt-expandtabs+))) + (if (and (= (logand bits gfs::+ss-left+) gfs::+ss-left+) (> width-hint 0)) + (setf flags (logior flags gfs::+dt-wordbreak+))) + (setf sz (widget-text-size label flags)) + (if (>= width-hint 0) + (setf (gfs:size-width sz) width-hint)) + (if (>= height-hint 0) + (setf (gfs:size-height sz) height-hint)) + (incf (gfs:size-width sz) (* b-width 2)) + (incf (gfs:size-height sz) (* b-width 2)) + sz)))) (defmethod text ((label label)) (get-widget-text label)) (defmethod (setf text) (str (label label)) + (let* ((hwnd (gfs:handle label)) + (orig-flags (gfs::get-window-long hwnd gfs::+gwl-style+)) + (etch-flags (logior (logand orig-flags gfs::+ss-etchedframe+) + (logand orig-flags gfs::+ss-sunken+)))) + (multiple-value-bind (std-flags ex-flags) + (compute-style-flags label nil nil nil str) + (declare (ignore ex-flags)) + (gfs::set-window-long hwnd gfs::+gwl-style+ (logior etch-flags + std-flags + gfs::+ws-child+ + gfs::+ws-visible+)))) (set-widget-text label str)) Modified: trunk/src/uitoolkit/widgets/panel.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/panel.lisp (original) +++ trunk/src/uitoolkit/widgets/panel.lisp Sun Apr 16 02:14:03 2006 @@ -49,7 +49,8 @@ ;;; methods ;;; -(defmethod compute-style-flags ((self panel) style) +(defmethod compute-style-flags ((self panel) style &rest extra-data) + (declare (ignore extra-data)) (let ((std-flags (logior gfs::+ws-child+ gfs::+ws-visible+)) (ex-flags 0)) (mapc #'(lambda (sym) Modified: trunk/src/uitoolkit/widgets/top-level.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/top-level.lisp (original) +++ trunk/src/uitoolkit/widgets/top-level.lisp Sun Apr 16 02:14:03 2006 @@ -63,8 +63,8 @@ ;;; methods ;;; -(defmethod compute-style-flags ((win top-level) style) - (declare (ignore win)) +(defmethod compute-style-flags ((win top-level) style &rest extra-data) + (declare (ignore win extra-data)) (let ((std-flags 0) (ex-flags 0)) (mapc #'(lambda (sym) Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Sun Apr 16 02:14:03 2006 @@ -105,7 +105,7 @@ (defgeneric columns (self) (:documentation "Returns the column objects displayed by the object.")) -(defgeneric compute-style-flags (self style) +(defgeneric compute-style-flags (self style &rest extra-data) (:documentation "Convert a list of keyword symbols to a pair of native bitmasks; the first conveys normal/standard flags, whereas the second any extended flags that the system supports.")) (defgeneric compute-outer-size (self desired-client-size) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Sun Apr 16 02:14:03 2006 @@ -149,6 +149,9 @@ ;;; methods ;;; +(defmethod background-color ((win window)) + (gfg:rgb->color (gfs::get-class-long (gfs:handle win) gfs::+gclp-hbrbackground+))) + (defmethod compute-outer-size ((win window) desired-client-size) ;; TODO: consider reimplementing this with AdjustWindowRect ;;

1 0

[graphic-forms-cvs] r97 - trunk/src/uitoolkit/system
by junrue＠common-lisp.net 15 Apr '06

15 Apr '06

Author: junrue Date: Fri Apr 14 20:05:49 2006 New Revision: 97 Modified: trunk/src/uitoolkit/system/gdi32.lisp trunk/src/uitoolkit/system/system-constants.lisp Log: added bindings for font resource registration and removal functions Modified: trunk/src/uitoolkit/system/gdi32.lisp ============================================================================== --- trunk/src/uitoolkit/system/gdi32.lisp (original) +++ trunk/src/uitoolkit/system/gdi32.lisp Fri Apr 14 20:05:49 2006 @@ -40,6 +40,13 @@ (load-foreign-library "msimg32.dll") (defcfun + ("AddFontResourceExA" add-font-resource-ex) + INT + (filename :string) + (flags DWORD) + (reserved LPTR)) + +(defcfun ("Arc" arc) BOOL (hdc HANDLE) @@ -137,6 +144,14 @@ (color COLORREF)) (defcfun + ("CreateScalableFontResourceA" create-scalable-font-resource) + BOOL + (hidden DWORD) + (resfile :string) + (fontfile :string) + (path :string)) + +(defcfun ("DeleteDC" delete-dc) BOOL (hdc HANDLE)) @@ -316,6 +331,11 @@ (y2 INT)) (defcfun + ("RemoveFontResourceA" remove-font-resource) + BOOL + (filename :string)) + +(defcfun ("RoundRect" round-rect) BOOL (hdc HANDLE) Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Fri Apr 14 20:05:49 2006 @@ -206,6 +206,9 @@ (defconstant +ff-script+ #x0040) (defconstant +ff-decorative+ #x0050) +(defconstant +fr-private+ #x10) +(defconstant +fr-not-enum+ #x20) + (defconstant +fw-dontcare+ 0) (defconstant +fw-thin+ 100) (defconstant +fw-extralight+ 200)

1 0