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