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

[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

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

14 Apr '06

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

1 0

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

13 Apr '06

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

1 0