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

[graphic-forms-cvs] r196 - trunk/src/uitoolkit/system
by junrue＠common-lisp.net 13 Jul '06

13 Jul '06

Author: junrue Date: Thu Jul 13 13:46:23 2006 New Revision: 196 Modified: trunk/src/uitoolkit/system/comdlg32.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/system/system-types.lisp trunk/src/uitoolkit/system/user32.lisp Log: preparation for implementing standard find/replace dialog Modified: trunk/src/uitoolkit/system/comdlg32.lisp ============================================================================== --- trunk/src/uitoolkit/system/comdlg32.lisp (original) +++ trunk/src/uitoolkit/system/comdlg32.lisp Thu Jul 13 13:46:23 2006 @@ -41,18 +41,28 @@ (defcfun ("ChooseFontA" choose-font) BOOL - (struct LPTR)) + (struct LPTR)) ; choosefont struct (defcfun ("CommDlgExtendedError" comm-dlg-extended-error) DWORD) (defcfun + ("FindTextA" find-text) + HANDLE + (fr LPTR)) ; findreplace struct + +(defcfun ("GetOpenFileNameA" get-open-filename) BOOL - (ofn LPTR)) + (ofn LPTR)) ; openfilename struct (defcfun ("GetSaveFileNameA" get-save-filename) BOOL - (ofn LPTR)) + (ofn LPTR)) ; openfilename struct + +(defcfun + ("ReplaceTextA" replace-text) + HANDLE + (fr LPTR)) ; findreplace struct Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Thu Jul 13 13:46:23 2006 @@ -33,10 +33,24 @@ (in-package :graphic-forms.uitoolkit.system) +;;; +;;; control class names +;;; (defconstant +button-classname+ "button") (defconstant +edit-classname+ "edit") (defconstant +static-classname+ "static") +;;; +;;; registered message names +;;; +(defconstant +lbselchstringa+ "commdlg_LBSelChangedNotify") +(defconstant +sharevistringa+ "commdlg_ShareViolation") +(defconstant +fileokstringa+ "commdlg_FileNameOK") +(defconstant +colorokstringa+ "commdlg_ColorOK") +(defconstant +setrgbstringa+ "commdlg_SetRGBColor") +(defconstant +helpmsgstringa+ "commdlg_help") +(defconstant +findmsgstringa+ "commdlg_FindReplace") + (defconstant +ad-counterclockwise+ 1) (defconstant +ad-clockwise+ 2) @@ -374,6 +388,31 @@ (defconstant +fr-private+ #x10) (defconstant +fr-not-enum+ #x20) +;;; +;;; find/replace dialog-related constants +;;; +(defconstant +fr-down+ #x00000001) +(defconstant +fr-wholeword+ #x00000002) +(defconstant +fr-matchcase+ #x00000004) +(defconstant +fr-findnext+ #x00000008) +(defconstant +fr-replace+ #x00000010) +(defconstant +fr-replaceall+ #x00000020) +(defconstant +fr-dialogterm+ #x00000040) +(defconstant +fr-showhelp+ #x00000080) +(defconstant +fr-enablehook+ #x00000100) +(defconstant +fr-enabletemplate+ #x00000200) +(defconstant +fr-noupdown+ #x00000400) +(defconstant +fr-nomatchcase+ #x00000800) +(defconstant +fr-nowholeword+ #x00001000) +(defconstant +fr-enabletemplatehandle+ #x00002000) +(defconstant +fr-hideupdown+ #x00004000) +(defconstant +fr-hidematchcase+ #x00008000) +(defconstant +fr-hidewholeword+ #x00010000) +(defconstant +fr-raw+ #x00020000) +(defconstant +fr-matchdiac+ #x20000000) +(defconstant +fr-matchkashida+ #x40000000) +(defconstant +fr-matchalefhamza+ #x80000000) + (defconstant +frerr-findreplacecodes+ #x4000) (defconstant +frerr-bufferlengthzero+ #x4001) Modified: trunk/src/uitoolkit/system/system-types.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-types.lisp (original) +++ trunk/src/uitoolkit/system/system-types.lisp Thu Jul 13 13:46:23 2006 @@ -151,6 +151,19 @@ (rightmargin INT) (lengthdrawn UINT)) +(defcstruct findreplace + (structsize DWORD) + (howner HANDLE) + (hinst HANDLE) + (flags DWORD) + (whatstr :string) + (withstr :string) + (whatlen WORD) + (withlen WORD) + (data LPARAM) + (hookfn LPTR) ; FIXME: not yet used, but eventually should be FRHookProc + (templname :string)) + (defcstruct initcommoncontrolsex (size DWORD) (icc DWORD)) Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Thu Jul 13 13:46:23 2006 @@ -541,6 +541,11 @@ (wndclass LPTR)) (defcfun + ("RegisterWindowMessageA" register-window-message) + UINT + (str :string)) + +(defcfun ("ReleaseCapture" release-capture) BOOL)

1 0

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

13 Jul '06

Author: junrue Date: Thu Jul 13 12:21:53 2006 New Revision: 195 Modified: trunk/docs/manual/api.texinfo trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/uitoolkit/widgets/button.lisp trunk/src/uitoolkit/widgets/item.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp trunk/src/uitoolkit/widgets/widget.lisp Log: documented select/selected-p methods and implemented them for buttons Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Thu Jul 13 12:21:53 2006 @@ -1607,6 +1607,11 @@ decorations are modified appropriately. @end deffn +@deffn GenericFunction select self flag +Sets @var{self} to the selected state if @var{flag} is not @sc{nil} +or to the unselected state if @sc{nil}. +@end deffn + @deffn GenericFunction select-all self flag Sets the entire content of @code{self} to the selected state if @var{flag} is not @sc{nil} or to the unselected state if @sc{nil}. @@ -1634,6 +1639,10 @@ returns @sc{nil}. @end deffn +@deffn GenericFunction selected-p self => boolean +Returns T if @var{self} is in the selected state; @sc{nil} otherwise. +@end deffn + @anchor{show} @deffn GenericFunction show self flag Causes the object to be visible or hidden on the screen, but not Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Thu Jul 13 12:21:53 2006 @@ -112,7 +112,10 @@ :dispatcher be :style (list subtype))) (setf (toggle-fn be) (create-button-toggler be)) - (setf (gfw:text w) (funcall (toggle-fn be)))) + (setf (gfw:text w) (funcall (toggle-fn be))) + (if (eql subtype :tri-state) + (gfw:check w t) + (gfw:check w t))) ((eql subtype :single-line-edit) (setf w (make-instance widget-class :parent *layout-tester-win* Modified: trunk/src/uitoolkit/widgets/button.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/button.lisp (original) +++ trunk/src/uitoolkit/widgets/button.lisp Thu Jul 13 12:21:53 2006 @@ -40,6 +40,17 @@ ;;; methods ;;; +(defmethod check ((self button) flag) + (let ((bits (if flag gfs::+bst-checked+ gfs::+bst-unchecked+))) + (gfs::send-message (gfs:handle self) gfs::+bm-setcheck+ bits 0))) + +(defmethod checked-p ((self button)) + (let ((bits (gfs::send-message (gfs:handle self) gfs::+bm-getcheck+ 0 0))) + (case bits + (gfs::+bst-checked+ t) + (gfs::+bst-unchecked+ nil) + (otherwise nil)))) + (defmethod compute-style-flags ((self button) &rest extra-data) (declare (ignore extra-data)) (let ((std-flags (logior +default-child-style+ gfs::+ws-tabstop+)) @@ -115,6 +126,12 @@ (gfs:size-height text-size))))) size)) +(defmethod select ((self button) flag) + (check self flag)) + +(defmethod selected-p ((self button)) + (checked-p self)) + (defmethod text ((self button)) (get-widget-text self)) Modified: trunk/src/uitoolkit/widgets/item.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/item.lisp (original) +++ trunk/src/uitoolkit/widgets/item.lisp Thu Jul 13 12:21:53 2006 @@ -36,7 +36,12 @@ (defun items-equal-p (item1 item2) (= (item-id item1) (item-id item2))) -(defmethod check :before ((it item) flag) +(defmethod check :before ((self item) flag) (declare (ignore flag)) - (if (gfs:null-handle-p (gfs:handle it)) + (if (gfs:null-handle-p (gfs:handle self)) + (error 'gfs:toolkit-error :detail "null owner handle"))) + +(defmethod checked-p :before ((self item)) + (declare (ignore flag)) + (if (gfs:null-handle-p (gfs:handle self)) (error 'gfs:toolkit-error :detail "null owner handle"))) Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Thu Jul 13 12:21:53 2006 @@ -297,6 +297,9 @@ (defgeneric scroll (self dest-pnt src-rect children-too) (:documentation "Scrolls a rectangular region (optionally including children) by copying the source area, then causing the uncovered area of the source to be marked as needing repainting.")) +(defgeneric select (self flag) + (:documentation "Set self into (or out of) the selected state.")) + (defgeneric select-all (self flag) (:documentation "Set all items of this object into (or out of) the selected state.")) Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Thu Jul 13 12:21:53 2006 @@ -125,12 +125,16 @@ (defmethod center-on-parent ((self widget)) (center-object (parent self) self)) +(defmethod check :before ((self widget) flag) + (declare (ignore flag)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + (defmethod checked-p :before ((self widget)) (if (gfs:disposed-p self) (error 'gfs:disposed-error))) (defmethod checked-p ((self widget)) - (declare (ignore self)) nil) (defmethod client-size :before ((self widget))

1 0

[graphic-forms-cvs] r194 - in trunk/src: demos/textedit uitoolkit/widgets
by junrue＠common-lisp.net 13 Jul '06

13 Jul '06

Author: junrue Date: Thu Jul 13 10:15:32 2006 New Revision: 194 Modified: trunk/src/demos/textedit/textedit-window.lisp trunk/src/uitoolkit/widgets/event.lisp Log: WM_ACTIVATE seems to be getting additional notification values than documented so changed an ecase to case; fix select all item enabling in textedit when text is empty Modified: trunk/src/demos/textedit/textedit-window.lisp ============================================================================== --- trunk/src/demos/textedit/textedit-window.lisp (original) +++ trunk/src/demos/textedit/textedit-window.lisp Thu Jul 13 10:15:32 2006 @@ -91,16 +91,17 @@ (unless *textedit-control* (return-from manage-textedit-edit-menu nil)) (let ((items (gfw:items menu)) + (text (gfw:text *textedit-control*)) (text-sel (gfw:selection-span *textedit-control*))) (gfw:enable (elt items 0) (gfw:undo-available-p *textedit-control*)) (gfw:enable (elt items 2) text-sel) (gfw:enable (elt items 3) text-sel) (gfw:enable (elt items 4) (gfw:text-for-pasting-p *textedit-control*)) (gfw:enable (elt items 5) text-sel) - (gfw:enable (elt items 12) (or (null text-sel) - (> (gfs:span-start text-sel) 0) - (< (gfs:span-end text-sel) - (length (gfw:text *textedit-control*))))))) + (gfw:enable (elt items 12) (and (> (length text) 0) + (or (null text-sel) + (> (gfs:span-start text-sel) 0) + (< (gfs:span-end text-sel) (length text))))))) (defun textedit-edit-copy (disp item) (declare (ignore disp item)) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Thu Jul 13 10:15:32 2006 @@ -353,7 +353,7 @@ (declare (ignore lparam)) (let ((widget (get-widget (thread-context) hwnd))) (if widget - (ecase wparam + (case wparam (#.gfs::+wa-active+ (event-activate (dispatcher widget) widget)) (#.gfs::+wa-clickactive+ (event-activate (dispatcher widget) widget)) (#.gfs::+wa-inactive+ (event-deactivate (dispatcher widget) widget)))))

1 0

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

13 Jul '06

Author: junrue Date: Thu Jul 13 02:38:01 2006 New Revision: 193 Modified: trunk/docs/manual/api.texinfo trunk/docs/manual/miscellaneous.texinfo trunk/src/demos/textedit/textedit-window.lisp trunk/src/packages.lisp trunk/src/uitoolkit/system/user32.lisp trunk/src/uitoolkit/widgets/edit.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp trunk/src/uitoolkit/widgets/widget.lisp Log: implemented select-all and select-span for edit controls Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Thu Jul 13 02:38:01 2006 @@ -128,9 +128,9 @@ @end defun @anchor{location} -@deffn Macro location rect +@defmac location rect This macro returns the @var{location} slot of a @ref{rectangle}. -@end deffn +@end defmac @deffn Function make-point :x :y :z This function creates a new @ref{point} object. @@ -148,9 +148,9 @@ This function creates a new @ref{span} object. @end deffn -@deffn Macro size rect +@defmac size rect This macro returns the @code{size} slot of a @ref{rectangle}. -@end deffn +@end defmac @node system conditions @@ -1282,17 +1282,6 @@ Returns T if the object is in the checked state; nil otherwise. @end deffn -@deffn GenericFunction clear-selection self -Sets the selection status of @code{self} (or @ref{item}s within -@var{self}) to the @samp{unselected} state. -@end deffn - -@deffn GenericFunction clear-selection-span self @ref{span} -Sets the selection status of @ref{item}s within @var{self}, whose -zero-based indices lie within @var{span}, to the @samp{unselected} -state. -@end deffn - @deffn GenericFunction client-size self Returns a size object that describes the region of the object that can be drawn within or can display data. @@ -1618,10 +1607,31 @@ decorations are modified appropriately. @end deffn +@deffn GenericFunction select-all self flag +Sets the entire content of @code{self} to the selected state if +@var{flag} is not @sc{nil} or to the unselected state if @sc{nil}. +@end deffn + +@anchor{select-items} +@deffn GenericFunction select-items self indices flag +Sets the @ref{item}s of @var{self}, each identified by a zero-based +index from the @var{indices} @sc{list}, to the selected state if +@var{flag} is not @sc{nil} or to the unselected state if @sc{nil}. +This is the function to use when not all of the items in question +are contiguous. +@end deffn + +@anchor{select-span} +@deffn GenericFunction select-span self span +Sets the @ref{item}s of @var{self} that lie within @var{span} to +the selected state. An existing selection's extent is modified +to match the new @var{span}. +@end deffn + @deffn GenericFunction selection-span self => @ref{span} -Returns a span object describing the start and end of the selection -within @var{self}. If there is no selection, this function returns -@sc{nil}. +Returns a span object describing the @var{start} and @var{end} of the +selection within @var{self}. If there is no selection, this function +returns @sc{nil}. @end deffn @anchor{show} @@ -1701,30 +1711,37 @@ @end deffn @end html +@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} +is executing will be queued so that when the lock is lifted +@var{widget} will be repainted. +@end defmac + @anchor{with-file-dialog} -@deffn Macro with-file-dialog (owner style paths &key default-extension filters initial-directory initial-filename text) &body body +@defmac with-file-dialog (owner style paths &key default-extension filters initial-directory initial-filename text) &body body This macro wraps the instantiation of a standard file open/save dialog -and the subsequent retrieval of the user's file selections (supplied to @code{body} -via @code{paths}). @xref{file-dialog}. -@end deffn +and the subsequent retrieval of the user's file selections (supplied to @var{body} +via @var{paths}). @xref{file-dialog}. +@end defmac @anchor{with-font-dialog} -@deffn Macro with-font-dialog (owner style font color &key gc initial-color initial-font) &body body +@defmac with-font-dialog (owner style font color &key gc initial-color initial-font) &body body This macro wraps the instantiation of a standard font dialog and binds -@code{font} to a font object, and @code{color} to a @ref{color} object, +@var{font} to a font object, and @var{color} to a @ref{color} object, corresponding to the attributes selected by the user. If the user cancels -the dialog, @code{font} will be @sc{nil}. In addition, @code{color} will also +the dialog, @var{font} will be @sc{nil}. In addition, @var{color} will also be @sc{nil} if the dialog was created with the @code{:no-effects} style keyword. @xref{font-dialog}. -@end deffn +@end defmac @anchor{with-graphics-context} -@deffn Macro with-graphics-context (gc &optional thing) &body body +@defmac with-graphics-context (gc &optional thing) &body body This macro manages a @ref{graphics-context} representing the underlying -device context of @code{thing}, which can be a @ref{widget} or an -@ref{image}. If @code{thing} is not specified, then the macro creates +device context of @var{thing}, which can be a @ref{widget} or an +@ref{image}. If @var{thing} is not specified, then the macro creates a graphics-context compatible with the @ref{display}. -@end deffn +@end defmac @node layout functions Modified: trunk/docs/manual/miscellaneous.texinfo ============================================================================== --- trunk/docs/manual/miscellaneous.texinfo (original) +++ trunk/docs/manual/miscellaneous.texinfo Thu Jul 13 02:38:01 2006 @@ -20,8 +20,8 @@ This chapter documents terminology conventions observed in Graphic-Forms. These conventions should be interpreted with the -traditional Common Lisp conventions in mind (such as -@url{http://www.cliki.net/Naming%20conventions}). +traditional Common Lisp conventions in mind (some of which are +documented here: @url{http://www.cliki.net/Naming%20conventions}). @table @option @@ -29,6 +29,41 @@ For clearer identification of accessors, Graphic-Forms uses the suffix @samp{-of} whenever possible. +@item @samp{check} versus @samp{select} +Admittedly, these two concepts are similar. They can be used as verbs +and they both describe a state of being (@samp{checked} and +@samp{selected}). Yet they need to remain separate due to the fact +that certain @ref{widget}s can exist in both states simultaneously, +like a tri-state @ref{button}, or a table or tree whose items are +checkboxes. The choice of which best describes an action or state +amounts to a judgement call. In Graphic-Forms, the author chooses to +use @samp{select} when a user gesture causes a widget to issue its +primary notification event, such as a menu item or button being +clicked. Hence, the verb @samp{select} aligns with the +@ref{event-select} function.@footnote{This topic gets muddier when +edit controls come into the picture. Text in an edit control is +selected despite there being no notification event; yet there is a +notification (event-modify) then the user types text. I'm choosing to +live with this inconsistency, partly because otherwise my +categorization scheme seems to work well; and one can refer to the act +of retrieving edit control selection, confident that developers will +know this means obtaining highlighted text.} And so the +@samp{selection} state is associated with highlighting of an +@ref{item}. Graphic-Forms uses @samp{check} to identify an operation +that flags or annotates a widget; the @samp{checked} state means being +annotated. + +@c @item @samp{clear} versus @samp{delete} +@c There is a distinction between @samp{clear} and @samp{delete} which +@c hinges on the difference between the primary content of a @ref{widget} +@c and secondary state information. An example of primary content is text +@c within an @ref{edit} @ref{control}. An example of secondary state +@c information (relevant to this topic at least) is the @ref{span} of +@c selected text in an edit control. With that in mind, Graphic-Forms +@c functions @samp{delete} content but @samp{clear} secondary state. This +@c choice aligns with the semantics of @sc{CL:delete}, including the +@c notion of that function being a destructive operation. + @item function and method names Functions and methods should be named using a verb to suggest action. It may be tempting (especially for former Java programmers) to @@ -39,25 +74,14 @@ functions, the author suggests @samp{available-p}, such as @ref{undo-available-p}. -@item @samp{clear} versus @samp{delete} -Related to the @samp{function and method names} issues, there is -a distinction between @samp{clear} and @samp{delete} which hinges on -the difference between the primary content of a @ref{widget} and -secondary state information. An example of primary content is text -within an @ref{edit} @ref{control}. An example of secondary state -information (relevant to this topic at least) is the @ref{span} of -selected text in an edit control. With that in mind, Graphic-Forms -functions @samp{delete} content but @samp{clear} secondary state. This -choice is intended in part to align with the semantics of -@sc{CL:delete}, including the notion of that function being a -destructive operation. - @item macro names Macros should be named consistent with established Common Lisp practice, with an exception being allowed for convenience wrappers -around structure accessors (see @ref{location}). Otherwise, the -temptation to define an unorthodox macro name is a symptom that maybe -the code in question should not be a macro in the first place. +around structure accessors (see for example +@ref{location}). Otherwise, the temptation to define an unorthodox +macro name is a symptom that maybe the code in question should not be +a macro in the first place. The rule of thumb is: if something can +be a function, then let it be a function; in general, think carefully +before creating a new macro. @end table - Modified: trunk/src/demos/textedit/textedit-window.lisp ============================================================================== --- trunk/src/demos/textedit/textedit-window.lisp (original) +++ trunk/src/demos/textedit/textedit-window.lisp Thu Jul 13 02:38:01 2006 @@ -96,7 +96,11 @@ (gfw:enable (elt items 2) text-sel) (gfw:enable (elt items 3) text-sel) (gfw:enable (elt items 4) (gfw:text-for-pasting-p *textedit-control*)) - (gfw:enable (elt items 5) text-sel))) + (gfw:enable (elt items 5) text-sel) + (gfw:enable (elt items 12) (or (null text-sel) + (> (gfs:span-start text-sel) 0) + (< (gfs:span-end text-sel) + (length (gfw:text *textedit-control*))))))) (defun textedit-edit-copy (disp item) (declare (ignore disp item)) @@ -114,6 +118,10 @@ (declare (ignore disp item)) (gfw:paste-text *textedit-control*)) +(defun textedit-edit-selall (disp item) + (declare (ignore disp item)) + (gfw:select-all *textedit-control* t)) + (defun textedit-edit-undo (disp item) (declare (ignore disp item))) @@ -234,7 +242,7 @@ (:item "&Replace..." :disabled) (:item "&Go To...") (:item "" :separator) - (:item "Select &All"))) + (:item "Select &All" :callback #'textedit-edit-selall))) (:item "F&ormat" :submenu ((:item "&Font..." :callback #'textedit-font))) (:item "&Help" Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Thu Jul 13 02:38:01 2006 @@ -465,6 +465,7 @@ #:scroll #:select #:select-all + #:select-items #:selected-p #:selection-count #:selection-index @@ -502,6 +503,7 @@ #:vertical-scrollbar #:visible-item-count #:visible-p + #:with-drawing-disabled #:with-file-dialog #:with-font-dialog #:with-graphics-context Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Thu Jul 13 02:38:01 2006 @@ -497,6 +497,11 @@ (fu-load UINT)) (defcfun + ("LockWindowUpdate" lock-window-update) + BOOL + (hwnd HANDLE)) + +(defcfun ("MapVirtualKeyA" map-virtual-key) UINT (code UINT) Modified: trunk/src/uitoolkit/widgets/edit.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/edit.lisp (original) +++ trunk/src/uitoolkit/widgets/edit.lisp Thu Jul 13 02:38:01 2006 @@ -130,6 +130,17 @@ (* +vertical-edit-text-margin+ 2)))) size)) +(defmethod select-all ((self edit) flag) + (if flag + (gfs::send-message (gfs:handle self) gfs::+em-setsel+ 0 (length (text self))) + (gfs::send-message (gfs:handle self) gfs::+em-setsel+ 0 0))) + +(defmethod select-span ((self edit) (span gfs:span)) + (with-drawing-disabled (self) + (let ((hwnd (gfs:handle self))) + (gfs::send-message hwnd gfs::+em-setsel+ 1 1) + (gfs::send-message hwnd gfs::+em-setsel+ (gfs:span-start span) (gfs:span-end span))))) + (defmethod selection-span ((self edit)) (cffi:with-foreign-object (start-ptr :unsigned-long) (cffi:with-foreign-object (end-ptr :unsigned-long) Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Thu Jul 13 02:38:01 2006 @@ -84,12 +84,6 @@ (defgeneric checked-p (self) (:documentation "Returns T if the object is in the checked state; nil otherwise.")) -(defgeneric clear-selection (self) - (:documentation "The set of selected items in self is made empty.")) - -(defgeneric clear-selection-span (self span) - (:documentation "Sets a subset of self's current selection to the unselected state.")) - (defgeneric client-size (self) (:documentation "Returns a size object that describes the region of the object that can be drawn within or can display data.")) @@ -303,11 +297,14 @@ (defgeneric scroll (self dest-pnt src-rect children-too) (:documentation "Scrolls a rectangular region (optionally including children) by copying the source area, then causing the uncovered area of the source to be marked as needing repainting.")) -(defgeneric select (self flag) - (:documentation "Set this object into (or take it out of) the selected state.")) - (defgeneric select-all (self flag) - (:documentation "Set all items of this object into (or take them out of) the selected state.")) + (:documentation "Set all items of this object into (or out of) the selected state.")) + +(defgeneric select-items (self indices flag) + (:documentation "Set items of self, each identified by a zero-based index, into (or out of) the selected state.")) + +(defgeneric select-span (self span) + (:documentation "Set items of self that lie within span into the selected state.")) (defgeneric selected-p (self) (:documentation "Returns T if the object is in the selected state; nil otherwise.")) Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Thu Jul 13 02:38:01 2006 @@ -50,7 +50,16 @@ (unwind-protect (progn ,@body) - (gfs:dispose ,gc))))) + (gfs:dispose ,gc)))) + + (defmacro with-drawing-disabled ((widget) &body body) + `(unwind-protect + (progn + (unless (gfs:disposed-p ,widget) + (error 'gfs:disposed-error)) + (gfs::lock-window-update (gfs:handle ,widget)) + ,@body) + (gfs::lock-window-update (cffi:null-pointer))))) (defun translate-and-dispatch (msg-ptr) (gfs::translate-message msg-ptr) Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Thu Jul 13 02:38:01 2006 @@ -133,15 +133,6 @@ (declare (ignore self)) nil) -(defmethod clear-selection :before ((self widget)) - (if (gfs:disposed-p self) - (error 'gfs:disposed-error))) - -(defmethod clear-selection-span :before ((self widget) span) - (declare (ignore span)) - (if (gfs:disposed-p self) - (error 'gfs:disposed-error))) - (defmethod client-size :before ((self widget)) (if (gfs:disposed-p self) (error 'gfs:disposed-error))) @@ -296,7 +287,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 "dispatcher: ~a~%" (dispatcher self)))) (defmethod redo-available-p :before ((self widget)) (if (gfs:disposed-p self) @@ -321,12 +312,31 @@ (defmethod resizable-p ((self widget)) nil) +(defmethod select :before ((self widget) flag) + (declare (ignore flag)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + +(defmethod select-all :before ((self widget) flag) + (declare (ignore flag)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + +(defmethod select-items :before ((self widget) items flag) + (declare (ignore items flag)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + +(defmethod select-span :before ((self widget) span) + (declare (ignore span)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + (defmethod selected-p :before ((self widget)) (if (gfs:disposed-p self) (error 'gfs:disposed-error))) (defmethod selected-p ((self widget)) - (declare (ignore self)) nil) (defmethod selection-span :before ((self widget))

1 0

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

11 Jul '06

Author: junrue Date: Tue Jul 11 16:33:21 2006 New Revision: 192 Modified: trunk/docs/manual/api.texinfo trunk/docs/manual/miscellaneous.texinfo trunk/src/demos/textedit/textedit-window.lisp trunk/src/packages.lisp trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/uitoolkit/widgets/edit.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/menu-item.lisp trunk/src/uitoolkit/widgets/menu.lisp trunk/src/uitoolkit/widgets/thread-context.lisp trunk/src/uitoolkit/widgets/timer.lisp trunk/src/uitoolkit/widgets/top-level.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp trunk/src/uitoolkit/widgets/widget-with-items.lisp trunk/src/uitoolkit/widgets/widget.lisp trunk/src/uitoolkit/widgets/window.lisp Log: cleanup of clear vs. delete terminology, and got rid of remove-* Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Tue Jul 11 16:33:21 2006 @@ -127,6 +127,7 @@ @sc{nil} otherwise. @end defun +@anchor{location} @deffn Macro location rect This macro returns the @var{location} slot of a @ref{rectangle}. @end deffn @@ -1281,24 +1282,15 @@ Returns T if the object is in the checked state; nil otherwise. @end deffn -@deffn GenericFunction clear-all self -Clears all content from @code{self}. -@end deffn - -@deffn GenericFunction clear-item self index -Clears the @ref{item} at the zero-based @var{index}. -@end deffn - @deffn GenericFunction clear-selection self -Sets the selection status of @code{self} to @samp{not selected} or -@samp{empty}. For a @ref{control} with a text field component, -such as an @ref{edit} control, this function deletes selected -text. +Sets the selection status of @code{self} (or @ref{item}s within +@var{self}) to the @samp{unselected} state. @end deffn -@deffn GenericFunction clear-span self @ref{span} -Clears the items from @var{self} whose zero-based indices lie within -the specified @var{span}. +@deffn GenericFunction clear-selection-span self @ref{span} +Sets the selection status of @ref{item}s within @var{self}, whose +zero-based indices lie within @var{span}, to the @samp{unselected} +state. @end deffn @deffn GenericFunction client-size self @@ -1351,6 +1343,26 @@ presses @sc{enter}. @end deffn +@deffn GenericFunction delete-all self +Removes all content from @code{self}. +@end deffn + +@deffn GenericFunction delete-item self index +Removes the @ref{item} at the zero-based @var{index}. +@end deffn + +@deffn GenericFunction delete-item-span self @ref{span} +Removes the items from @var{self} whose zero-based indices lie within +the specified @var{span}. +@end deffn + +@deffn GenericFunction delete-selection self +Removes the subset of items from @var{self} that are in the +@samp{selected} state. For a @ref{control} with a text field +component, such as an @ref{edit} control, this function deletes +selected text. +@end deffn + @deffn GenericFunction display-to-object self pnt Return a point that is the result of transforming the specified point from display-relative coordinates to this object's coordinate system. @@ -1660,6 +1672,7 @@ other cases there is no text component at all. @end deffn +@anchor{undo-available-p} @deffn GenericFunction undo-available-p self => boolean Returns T if @code{self} has @sc{undo} capability and has an operation that can be undone; @sc{nil} otherwise. Modified: trunk/docs/manual/miscellaneous.texinfo ============================================================================== --- trunk/docs/manual/miscellaneous.texinfo (original) +++ trunk/docs/manual/miscellaneous.texinfo Tue Jul 11 16:33:21 2006 @@ -10,4 +10,54 @@ @node Miscellaneous Topics @chapter Miscellaneous Topics -@strong{TBD} +@menu +* terminology:: Some notes about terminology conventions. +@end menu + + +@node terminology +@section terminology + +This chapter documents terminology conventions observed in +Graphic-Forms. These conventions should be interpreted with the +traditional Common Lisp conventions in mind (such as +@url{http://www.cliki.net/Naming%20conventions}). + +@table @option + +@item accessor names +For clearer identification of accessors, Graphic-Forms +uses the suffix @samp{-of} whenever possible. + +@item function and method names +Functions and methods should be named using a verb to suggest +action. It may be tempting (especially for former Java programmers) to +use the Java getter/setter naming conventions for accessor-like +functions, but the author prefers @samp{obtain} rather than +@samp{get}, and he prefers @sc{setf}'able places which therefore can +have @sc{setf} functions defined for them. For status querying +functions, the author suggests @samp{available-p}, such as +@ref{undo-available-p}. + +@item @samp{clear} versus @samp{delete} +Related to the @samp{function and method names} issues, there is +a distinction between @samp{clear} and @samp{delete} which hinges on +the difference between the primary content of a @ref{widget} and +secondary state information. An example of primary content is text +within an @ref{edit} @ref{control}. An example of secondary state +information (relevant to this topic at least) is the @ref{span} of +selected text in an edit control. With that in mind, Graphic-Forms +functions @samp{delete} content but @samp{clear} secondary state. This +choice is intended in part to align with the semantics of +@sc{CL:delete}, including the notion of that function being a +destructive operation. + +@item macro names +Macros should be named consistent with established Common Lisp +practice, with an exception being allowed for convenience wrappers +around structure accessors (see @ref{location}). Otherwise, the +temptation to define an unorthodox macro name is a symptom that maybe +the code in question should not be a macro in the first place. + +@end table + Modified: trunk/src/demos/textedit/textedit-window.lisp ============================================================================== --- trunk/src/demos/textedit/textedit-window.lisp (original) +++ trunk/src/demos/textedit/textedit-window.lisp Tue Jul 11 16:33:21 2006 @@ -108,7 +108,7 @@ (defun textedit-edit-delete (disp item) (declare (ignore disp item)) - (gfw:clear-selection *textedit-control*)) + (gfw:delete-selection *textedit-control*)) (defun textedit-edit-paste (disp item) (declare (ignore disp item)) Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Tue Jul 11 16:33:21 2006 @@ -331,10 +331,8 @@ #:check #:check-all #:checked-p - #:clear-all - #:clear-item #:clear-selection - #:clear-span + #:clear-selection-span #:client-size #:close-obj #:code @@ -353,6 +351,10 @@ #:default-widget #:defmenu #:delay-of + #:delete-all + #:delete-item + #:delete-selection + #:delete-span #:disabled-image #:dispatcher #:display-to-object @@ -455,9 +457,6 @@ #:redraw #:redrawing-p #:release-mouse - #:remove-all - #:remove-item - #:remove-span #:reparentable-p #:replace-selection #:resizable-p Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Tue Jul 11 16:33:21 2006 @@ -169,7 +169,7 @@ :initform nil))) (defmethod gfw:event-activate ((d child-menu-dispatcher) menu) - (gfw:clear-all menu) + (gfw:delete-all menu) (gfw:mapchildren *layout-tester-win* (lambda (parent child) (declare (ignore parent)) @@ -336,7 +336,7 @@ (defun flow-mod-callback (disp menu) (declare (ignore disp)) - (gfw:clear-all menu) + (gfw:delete-all menu) (let ((it nil) (margin-menu (gfw:defmenu ((:item "Left" :callback #'enable-left-flow-margin-items Modified: trunk/src/uitoolkit/widgets/edit.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/edit.lisp (original) +++ trunk/src/uitoolkit/widgets/edit.lisp Tue Jul 11 16:33:21 2006 @@ -48,9 +48,6 @@ (let ((bits (gfs::get-window-long (gfs:handle self) gfs::+gwl-style+))) (= (logand bits gfs::+es-autovscroll+) gfs::+es-autovscroll+))) -(defmethod clear-selection ((self edit)) - (gfs::send-message (gfs:handle self) gfs::+wm-clear+ 0 0)) - (defmethod compute-style-flags ((self edit) &rest extra-data) (declare (ignore extra-data)) (let ((std-flags (logior +default-child-style+ gfs::+ws-tabstop+)) @@ -83,6 +80,9 @@ (defmethod cut-text ((self edit)) (gfs::send-message (gfs:handle self) gfs::+wm-cut+ 0 0)) +(defmethod delete-selection ((self edit)) + (gfs::send-message (gfs:handle self) gfs::+wm-clear+ 0 0)) + (defmethod enable-scrollbars ((self edit) horizontal vertical) (let ((bits (gfs::get-window-long (gfs:handle self) gfs::+gwl-style+))) (if horizontal Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Tue Jul 11 16:33:21 2006 @@ -211,7 +211,7 @@ (defmethod process-message (hwnd (msg (eql gfs::+wm-destroy+)) wparam lparam) (declare (ignore wparam lparam)) - (remove-widget (thread-context) hwnd) + (delete-widget (thread-context) hwnd) 0) (defmethod process-message (hwnd (msg (eql gfs::+wm-char+)) wparam lparam) @@ -454,7 +454,7 @@ (defmethod process-subclass-message (hwnd (msg (eql gfs::+wm-destroy+)) wparam lparam) (declare (ignore wparam lparam)) - (remove-widget (thread-context) hwnd) + (delete-widget (thread-context) hwnd) (call-next-method)) ;;; Modified: trunk/src/uitoolkit/widgets/menu-item.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu-item.lisp (original) +++ trunk/src/uitoolkit/widgets/menu-item.lisp Tue Jul 11 16:33:21 2006 @@ -196,7 +196,7 @@ (defmethod gfs:dispose ((it menu-item)) (setf (dispatcher it) nil) - (remove-menuitem (thread-context) it) + (delete-menuitem (thread-context) it) (let ((id (item-id it)) (owner (owner it))) (unless (null owner) Modified: trunk/src/uitoolkit/widgets/menu.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu.lisp (original) +++ trunk/src/uitoolkit/widgets/menu.lisp Tue Jul 11 16:33:21 2006 @@ -142,13 +142,13 @@ (defun menu-cleanup-callback (menu item) (let ((tc (thread-context))) - (remove-widget tc (gfs:handle menu)) - (remove-menuitem tc item))) + (delete-widget tc (gfs:handle menu)) + (delete-menuitem tc item))) (defmethod gfs:dispose ((m menu)) (visit-menu-tree m #'menu-cleanup-callback) (let ((hwnd (gfs:handle m))) - (remove-widget (thread-context) hwnd) + (delete-widget (thread-context) hwnd) (if (not (gfs:null-handle-p hwnd)) (if (zerop (gfs::destroy-menu hwnd)) (error 'gfs:win32-error :detail "destroy-menu failed")))) Modified: trunk/src/uitoolkit/widgets/thread-context.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/thread-context.lisp (original) +++ trunk/src/uitoolkit/widgets/thread-context.lisp Tue Jul 11 16:33:21 2006 @@ -133,7 +133,7 @@ "Add the specified widget to the widget table using its native handle as the key." (setf (gethash (cffi:pointer-address (gfs:handle w)) (slot-value tc 'widgets-by-hwnd)) w)) -(defmethod remove-widget ((tc thread-context) hwnd) +(defmethod delete-widget ((tc thread-context) hwnd) "Remove the widget object corresponding to the specified native window handle." (when (not (slot-value tc 'wip)) (remhash (cffi:pointer-address hwnd) (slot-value tc 'widgets-by-hwnd)))) @@ -154,7 +154,7 @@ (if (find :keyboard-navigation (style-of widget)) (setf (kbdnav-widgets tc) (push widget (kbdnav-widgets tc))))) -(defmethod remove-kbdnav-widget ((tc thread-context) (widget widget)) +(defmethod delete-kbdnav-widget ((tc thread-context) (widget widget)) (setf (kbdnav-widgets tc) (remove-if (lambda (hwnd) (cffi:pointer-eq (gfs:handle widget) hwnd)) (kbdnav-widgets tc) @@ -170,7 +170,7 @@ (setf widget (find-if (lambda (w) (/= (gfs::is-dialog-message (gfs:handle w) msg-ptr))) (rest widgets))) (when (and widget (/= (gfs::is-dialog-message (gfs:handle widget) msg-ptr) 0)) - (let ((tmp (remove-kbdnav-widget tc widget))) + (let ((tmp (delete-kbdnav-widget tc widget))) (setf (kbdnav-widgets tc) (push widget tmp))) (return-from intercept-kbdnav-message widget)))) nil) @@ -183,7 +183,7 @@ "Stores a menu item using its id as the key." (setf (gethash (item-id it) (slot-value tc 'menuitems-by-id)) it)) -(defmethod remove-menuitem ((tc thread-context) (it menu-item)) +(defmethod delete-menuitem ((tc thread-context) (it menu-item)) "Removes the menu item using its id as the key." (maphash #'(lambda (k v) @@ -206,7 +206,7 @@ "Stores a timer using its id as the key." (setf (gethash (id-of timer) (slot-value tc 'timers-by-id)) timer)) -(defmethod remove-timer ((tc thread-context) (timer timer)) +(defmethod delete-timer ((tc thread-context) (timer timer)) "Removes the timer using its id as the key." (maphash #'(lambda (k v) Modified: trunk/src/uitoolkit/widgets/timer.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/timer.lisp (original) +++ trunk/src/uitoolkit/widgets/timer.lisp Tue Jul 11 16:33:21 2006 @@ -78,7 +78,7 @@ (defmethod gfs:dispose ((self timer)) (let ((tc (thread-context))) - (remove-timer tc self) + (delete-timer tc self) (gfs::kill-timer (utility-hwnd tc) (id-of self)))) (defmethod initialize-instance :after ((self timer) &key) Modified: trunk/src/uitoolkit/widgets/top-level.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/top-level.lisp (original) +++ trunk/src/uitoolkit/widgets/top-level.lisp Tue Jul 11 16:33:21 2006 @@ -130,7 +130,7 @@ (let ((m (menu-bar win))) (unless (null m) (visit-menu-tree m #'menu-cleanup-callback) - (remove-widget (thread-context) (gfs:handle m)))) + (delete-widget (thread-context) (gfs:handle m)))) (call-next-method)) (defmethod initialize-instance :after ((win top-level) &key owner text &allow-other-keys) Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Tue Jul 11 16:33:21 2006 @@ -84,17 +84,11 @@ (defgeneric checked-p (self) (:documentation "Returns T if the object is in the checked state; nil otherwise.")) -(defgeneric clear-all (self) - (:documentation "Clears all content from self.")) - -(defgeneric clear-item (self index) - (:documentation "Clears the item at the zero-based index.")) - (defgeneric clear-selection (self) - (:documentation "Sets the object's selection status to empty or not selected.")) + (:documentation "The set of selected items in self is made empty.")) -(defgeneric clear-span (self sp) - (:documentation "Clears the items whose zero-based indices lie within the specified span.")) +(defgeneric clear-selection-span (self span) + (:documentation "Sets a subset of self's current selection to the unselected state.")) (defgeneric client-size (self) (:documentation "Returns a size object that describes the region of the object that can be drawn within or can display data.")) @@ -132,6 +126,18 @@ (defgeneric default-widget (self) (:documentation "Returns the child widget or item that has the default emphasis.")) +(defgeneric delete-all (self) + (:documentation "Removes all content from the object.")) + +(defgeneric delete-item (self index) + (:documentation "Removes the item at the zero-based index from the object.")) + +(defgeneric delete-item-span (self span) + (:documentation "Removes the sequence of items represented by the specified span object.")) + +(defgeneric delete-selection (self) + (:documentation "Removes items from self that are in the selected state.")) + (defgeneric disabled-image (self) (:documentation "Returns the image used to render this item with a disabled look.")) @@ -282,15 +288,6 @@ (defgeneric redrawing-p (self) (:documentation "Returns T if the object is set to allow processing of paint events.")) -(defgeneric remove-all (self) - (:documentation "Removes all items from the object.")) - -(defgeneric remove-item (self index) - (:documentation "Removes the item at the zero-based index from the object.")) - -(defgeneric remove-span (self sp) - (:documentation "Removes the sequence of items represented by the specified span object.")) - (defgeneric reparentable-p (self) (:documentation "Returns T if the window system allows this object to be reparented; nil otherwise.")) 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 Tue Jul 11 16:33:21 2006 @@ -38,17 +38,17 @@ (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod clear-all ((self widget-with-items)) +(defmethod delete-all ((self widget-with-items)) (let ((count (length (items self)))) (unless (zerop count) - (clear-span self (gfs:make-span :start 0 :end (1- count)))))) + (delete-item-span self (gfs:make-span :start 0 :end (1- count)))))) -(defmethod clear-item :before ((self widget-with-items) index) +(defmethod delete-item :before ((self widget-with-items) index) (declare (ignore index)) (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod clear-item ((self widget-with-items) index) +(defmethod delete-item ((self widget-with-items) index) (let* ((items (items self)) (it (elt items index))) (delete it (items self) :test #'items-equal-p) @@ -56,14 +56,14 @@ (error 'gfs:disposed-error)) (gfs:dispose it))) -(defmethod clear-span :before ((self widget-with-items) (sp gfs:span)) +(defmethod delete-item-span :before ((self widget-with-items) (sp gfs:span)) (declare (ignore sp)) (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod clear-span ((self widget-with-items) (sp gfs:span)) +(defmethod delete-item-span ((self widget-with-items) (sp gfs:span)) (dotimes (i (1+ (- (gfs:span-end sp) (gfs:span-start sp)))) - (clear-item self (gfs:span-start sp)))) + (delete-item self (gfs:span-start sp)))) (defmethod item-index :before ((self widget-with-items) (it item)) (declare (ignore it)) Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Tue Jul 11 16:33:21 2006 @@ -133,11 +133,12 @@ (declare (ignore self)) nil) -(defmethod clear-all :before ((self widget)) +(defmethod clear-selection :before ((self widget)) (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod clear-selection :before ((self widget)) +(defmethod clear-selection-span :before ((self widget) span) + (declare (ignore span)) (if (gfs:disposed-p self) (error 'gfs:disposed-error))) @@ -167,6 +168,24 @@ (if (gfs:disposed-p self) (error 'gfs:disposed-error))) +(defmethod delete-all :before ((self widget)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + +(defmethod delete-item :before ((self widget) index) + (declare (ignore index)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + +(defmethod delete-item-span :before ((self widget) span) + (declare (ignore span)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + +(defmethod delete-selection :before ((self widget)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + (defmethod gfs:dispose ((self widget)) (unless (null (dispatcher self)) (event-dispose (dispatcher self) self)) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Tue Jul 11 16:33:21 2006 @@ -166,7 +166,7 @@ new-size)) (defmethod gfs:dispose ((self window)) - (remove-kbdnav-widget (thread-context) self) + (delete-kbdnav-widget (thread-context) self) (call-next-method)) (defmethod enable-layout :before ((win window) flag)

1 0

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

11 Jul '06

Author: junrue Date: Tue Jul 11 01:24:41 2006 New Revision: 191 Modified: trunk/docs/manual/api.texinfo trunk/src/demos/textedit/textedit-window.lisp trunk/src/packages.lisp trunk/src/uitoolkit/system/datastructs.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/system/user32.lisp trunk/src/uitoolkit/widgets/edit.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp trunk/src/uitoolkit/widgets/widget-with-items.lisp trunk/src/uitoolkit/widgets/widget.lisp Log: defined and implemented sufficient new methods to implement edit control cut/copy/paste/delete functionality for a window Edit menu; full-blown general clipboard support is still down the road a bit Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Tue Jul 11 01:24:41 2006 @@ -117,13 +117,18 @@ @deffn GenericFunction disposed-p self Returns T if @ref{dispose} has been called on @var{self} and the -object has not since been re-initialized; returns nil otherwise. -This function also returns T if @var{self} has been instantiated -but secondary initialization code has not yet executed. +object has not since been re-initialized; returns @sc{nil} otherwise. +This function also returns T if @var{self} has been instantiated but +secondary initialization code has not yet executed. @end deffn +@defun empty-span-p span +Returns T if the @var{start} and @var{end} of @code{span} are the same; +@sc{nil} otherwise. +@end defun + @deffn Macro location rect -This macro returns the @code{location} slot of a @ref{rectangle}. +This macro returns the @var{location} slot of a @ref{rectangle}. @end deffn @deffn Function make-point :x :y :z @@ -1276,12 +1281,24 @@ Returns T if the object is in the checked state; nil otherwise. @end deffn +@deffn GenericFunction clear-all self +Clears all content from @code{self}. +@end deffn + @deffn GenericFunction clear-item self index -Clears the item at the zero-based index. +Clears the @ref{item} at the zero-based @var{index}. +@end deffn + +@deffn GenericFunction clear-selection self +Sets the selection status of @code{self} to @samp{not selected} or +@samp{empty}. For a @ref{control} with a text field component, +such as an @ref{edit} control, this function deletes selected +text. @end deffn -@deffn GenericFunction clear-span self sp -Clears the items whose zero-based indices lie within the specified span. +@deffn GenericFunction clear-span self @ref{span} +Clears the items from @var{self} whose zero-based indices lie within +the specified @var{span}. @end deffn @deffn GenericFunction client-size self @@ -1300,6 +1317,32 @@ enclose the specified desired client area and this object's trim. @end deffn +@anchor{copy-text} +@deffn GenericFunction copy-text self +This function is a shortcut for a common clipboard transfer operation, +namely the transfer of text from @code{self} to the system clipboard. +The existing content of @code{self} remains in place. Some @ref{control}s +like the @ref{edit} control have built-in clipboard functionality, and +in such cases, the implementation of this function delegates directly. +See @ref{cut-text}, @ref{paste-text}, and @ref{text-for-pasting-p}.@*@* +@strong{Note:} an upcoming release will include more general +infrastructure for clipboard operations. +@end deffn + +@anchor{cut-text} +@deffn GenericFunction cut-text self +This function is a shortcut for a common clipboard transfer operation, +namely the transfer of text from @code{self} to the system clipboard +and removal of content from @code{self}. Some @ref{control}s like the +@ref{edit} control have built-in clipboard functionality, and in such +cases, the implementation of this function delegates directly. For +other @ref{widget}s, this operation is a wrapper around a copy/delete +sequence. See @ref{copy-text}, @ref{paste-text}, and +@ref{text-for-pasting-p}.@*@* +@strong{Note:} an upcoming release will +include more general infrastructure for clipboard operations. +@end deffn + @deffn GenericFunction default-widget self Returns the default @ref{widget} set for a @ref{dialog}, or @sc{nil} if none has been set. If @sc{nil} is passed to the corresponding @@ -1509,6 +1552,19 @@ @end quotation @end deffn +@anchor{paste-text} +@deffn GenericFunction paste-text self +This function is a shortcut for a common clipboard transfer operation, +namely the transfer of text from the system clipboard to @code{self}. +Depending on the current selection within @code{self}, the text either +gets inserted or existing content is replaced. Some @ref{control}s like the +@ref{edit} control have built-in clipboard functionality, and in such +cases, the implementation of this function delegates directly. See +@ref{copy-text}, @ref{cut-text}, and @ref{text-for-pasting-p}.@*@* +@strong{Note:} an upcoming release will include more +general infrastructure for clipboard operations. +@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}; @@ -1550,6 +1606,12 @@ decorations are modified appropriately. @end deffn +@deffn GenericFunction selection-span self => @ref{span} +Returns a span object describing the start and end of the selection +within @var{self}. If there is no selection, this function returns +@sc{nil}. +@end deffn + @anchor{show} @deffn GenericFunction show self flag Causes the object to be visible or hidden on the screen, but not @@ -1579,6 +1641,16 @@ the custom control will be managed by a @ref{layout-manager}. @end deffn +@anchor{text-for-pasting-p} +@deffn GenericFunction text-for-pasting-p self +This function is a shortcut means of checking the clipboard for existence +of data of a specific type (text). This status information is typically +used to enable or disable a @samp{Paste} menu item. See @ref{copy-text}, +@ref{cut-text}, and @ref{paste-text}.@*@* +@strong{Note:} an upcoming release will include more general +infrastructure for clipboard operations. +@end deffn + @anchor{text-modified-p} @deffn GenericFunction text-modified-p self Returns T if the text component of @code{self} has been modified by Modified: trunk/src/demos/textedit/textedit-window.lisp ============================================================================== --- trunk/src/demos/textedit/textedit-window.lisp (original) +++ trunk/src/demos/textedit/textedit-window.lisp Tue Jul 11 01:24:41 2006 @@ -90,8 +90,32 @@ (declare (ignore disp)) (unless *textedit-control* (return-from manage-textedit-edit-menu nil)) - (let ((items (gfw:items menu))) - (gfw:enable (elt items 0) (gfw:undo-available-p *textedit-control*)))) + (let ((items (gfw:items menu)) + (text-sel (gfw:selection-span *textedit-control*))) + (gfw:enable (elt items 0) (gfw:undo-available-p *textedit-control*)) + (gfw:enable (elt items 2) text-sel) + (gfw:enable (elt items 3) text-sel) + (gfw:enable (elt items 4) (gfw:text-for-pasting-p *textedit-control*)) + (gfw:enable (elt items 5) text-sel))) + +(defun textedit-edit-copy (disp item) + (declare (ignore disp item)) + (gfw:copy-text *textedit-control*)) + +(defun textedit-edit-cut (disp item) + (declare (ignore disp item)) + (gfw:cut-text *textedit-control*)) + +(defun textedit-edit-delete (disp item) + (declare (ignore disp item)) + (gfw:clear-selection *textedit-control*)) + +(defun textedit-edit-paste (disp item) + (declare (ignore disp item)) + (gfw:paste-text *textedit-control*)) + +(defun textedit-edit-undo (disp item) + (declare (ignore disp item))) (defun textedit-font (disp item) (declare (ignore disp item)) Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Tue Jul 11 01:24:41 2006 @@ -65,6 +65,7 @@ #:detail #:dispose #:disposed-p + #:empty-span-p #:equal-size-p #:flatten #:handle @@ -343,11 +344,11 @@ #:column-order #:columns #:compute-outer-size - #:copy #:copy-area + #:copy-text + #:cut-text #:current-font #:cursor - #:cut #:default-message-filter #:default-widget #:defmenu @@ -447,7 +448,7 @@ #:pack #:page-increment #:parent - #:paste + #:paste-text #:peer #:preferred-size #:primary-p @@ -485,6 +486,7 @@ #:sub-menu #:text #:text-baseline + #:text-for-pasting-p #:text-height #:text-limit #:text-modified-p Modified: trunk/src/uitoolkit/system/datastructs.lisp ============================================================================== --- trunk/src/uitoolkit/system/datastructs.lisp (original) +++ trunk/src/uitoolkit/system/datastructs.lisp Tue Jul 11 01:24:41 2006 @@ -47,6 +47,9 @@ (defmacro size (rect) `(rectangle-size ,rect)) +(defun empty-span-p (span) + (= (span-start span) (span-end span))) + (defun equal-size-p (size1 size2) (and (= (size-width size1) (size-width size2)) (= (size-height size1) (size-height size2)))) Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Tue Jul 11 01:24:41 2006 @@ -142,6 +142,30 @@ (defconstant +cderr-nohook+ #x000B) (defconstant +cderr-registermsgfail+ #x000C) +;;; +;;; clipboard-related constants +;;; +(defconstant +cf-text+ 1) +(defconstant +cf-bitmap+ 2) +(defconstant +cf-metafilepict+ 3) +(defconstant +cf-sylk+ 4) +(defconstant +cf-dif+ 5) +(defconstant +cf-tiff+ 6) +(defconstant +cf-oemtext+ 7) +(defconstant +cf-dib+ 8) +(defconstant +cf-palette+ 9) +(defconstant +cf-pendata+ 10) +(defconstant +cf-riff+ 11) +(defconstant +cf-wave+ 12) +(defconstant +cf-unicodetext+ 13) +(defconstant +cf-enhmetafile+ 14) +(defconstant +cf-hdrop+ 15) +(defconstant +cf-locale+ 16) +(defconstant +cf-dibv5+ 17) + +;;; +;;; font-related constants +;;; (defconstant +cf-screenfonts+ #x00000001) (defconstant +cf-printerfonts+ #x00000002) (defconstant +cf-both+ #x00000003) @@ -985,6 +1009,29 @@ (defconstant +wm-mousehover+ #x02A1) (defconstant +wm-ncmouseleave+ #x02A2) (defconstant +wm-mouseleave+ #x02A3) +(defconstant +wm-cut+ #x0300) +(defconstant +wm-copy+ #x0301) +(defconstant +wm-paste+ #x0302) +(defconstant +wm-clear+ #x0303) +(defconstant +wm-undo+ #x0304) +(defconstant +wm-renderformat+ #x0305) +(defconstant +wm-renderallformats+ #x0306) +(defconstant +wm-destroyclipboard+ #x0307) +(defconstant +wm-drawclipboard+ #x0308) +(defconstant +wm-paintclipboard+ #x0309) +(defconstant +wm-vscrollclipboard+ #x030A) +(defconstant +wm-sizeclipboard+ #x030B) +(defconstant +wm-askcbformatname+ #x030C) +(defconstant +wm-changecbchain+ #x030D) +(defconstant +wm-hscrollclipboard+ #x030E) +(defconstant +wm-querynewpalette+ #x030F) +(defconstant +wm-paletteischanging+ #x0310) +(defconstant +wm-palettechanged+ #x0311) +(defconstant +wm-hotkey+ #x0312) +(defconstant +wm-print+ #x0317) +(defconstant +wm-printclient+ #x0318) +(defconstant +wm-appcommand+ #x0319) +(defconstant +wm-themechanged+ #x031A) (defconstant +wm-user-base+ #x0400) (defconstant +wm-app-base+ #x8000) Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Tue Jul 11 01:24:41 2006 @@ -454,6 +454,11 @@ (erase BOOL)) (defcfun + ("IsClipboardFormatAvailable" is-clipboard-format-available) + BOOL + (format UINT)) + +(defcfun ("IsDialogMessageA" is-dialog-message) BOOL (hwnd HANDLE) Modified: trunk/src/uitoolkit/widgets/edit.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/edit.lisp (original) +++ trunk/src/uitoolkit/widgets/edit.lisp Tue Jul 11 01:24:41 2006 @@ -48,6 +48,9 @@ (let ((bits (gfs::get-window-long (gfs:handle self) gfs::+gwl-style+))) (= (logand bits gfs::+es-autovscroll+) gfs::+es-autovscroll+))) +(defmethod clear-selection ((self edit)) + (gfs::send-message (gfs:handle self) gfs::+wm-clear+ 0 0)) + (defmethod compute-style-flags ((self edit) &rest extra-data) (declare (ignore extra-data)) (let ((std-flags (logior +default-child-style+ gfs::+ws-tabstop+)) @@ -74,6 +77,12 @@ (setf std-flags (logior std-flags gfs::+es-autohscroll+))) (values std-flags (if (find :no-border style) 0 gfs::+ws-ex-clientedge+)))) +(defmethod copy-text ((self edit)) + (gfs::send-message (gfs:handle self) gfs::+wm-copy+ 0 0)) + +(defmethod cut-text ((self edit)) + (gfs::send-message (gfs:handle self) gfs::+wm-cut+ 0 0)) + (defmethod enable-scrollbars ((self edit) horizontal vertical) (let ((bits (gfs::get-window-long (gfs:handle self) gfs::+gwl-style+))) (if horizontal @@ -102,6 +111,9 @@ (error 'gfs:disposed-error)) (gfs::send-message (gfs:handle self) gfs::+em-getlinecount+ 0 0)) +(defmethod paste-text ((self edit)) + (gfs::send-message (gfs:handle self) gfs::+wm-paste+ 0 0)) + (defmethod preferred-size ((self edit) width-hint height-hint) (let ((text-size (widget-text-size self (logior gfs::+dt-editcontrol+ gfs::+dt-noprefix+))) (size (gfs:make-size)) @@ -118,6 +130,17 @@ (* +vertical-edit-text-margin+ 2)))) size)) +(defmethod selection-span ((self edit)) + (cffi:with-foreign-object (start-ptr :unsigned-long) + (cffi:with-foreign-object (end-ptr :unsigned-long) + (gfs::send-message (gfs:handle self) + gfs::+em-getsel+ + (cffi:pointer-address start-ptr) + (cffi:pointer-address end-ptr)) + (let ((start (cffi:mem-ref start-ptr :unsigned-long)) + (end (cffi:mem-ref end-ptr :unsigned-long))) + (if (= start end) nil (gfs:make-span :start start :end end)))))) + (defmethod text ((self edit)) (get-widget-text self)) @@ -127,6 +150,9 @@ (defmethod text-baseline ((self edit)) (widget-text-baseline self +vertical-edit-text-margin+)) +(defmethod text-for-pasting-p ((self edit)) + (/= (gfs::is-clipboard-format-available gfs::+cf-text+) 0)) + (defmethod text-modified-p ((self edit)) (/= (gfs::send-message (gfs:handle self) gfs::+em-getmodify+ 0 0) 0)) Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Tue Jul 11 01:24:41 2006 @@ -84,6 +84,9 @@ (defgeneric checked-p (self) (:documentation "Returns T if the object is in the checked state; nil otherwise.")) +(defgeneric clear-all (self) + (:documentation "Clears all content from self.")) + (defgeneric clear-item (self index) (:documentation "Clears the item at the zero-based index.")) @@ -117,14 +120,14 @@ (defgeneric compute-outer-size (self desired-client-size) (:documentation "Return a size object describing the dimensions of the area required to enclose the specified desired client area and this object's trim.")) -(defgeneric copy (self) - (:documentation "Copies the current selection to the clipboard.")) +(defgeneric copy-text (self) + (:documentation "Copies the current text selection to the clipboard.")) (defgeneric cursor (self) (:documentation "Returns the cursor object associated with this object.")) -(defgeneric cut (self) - (:documentation "Copies the current selection to the clipboard and removes it from the object.")) +(defgeneric cut-text (self) + (:documentation "Copies the current text selection to the clipboard and removes it from self.")) (defgeneric default-widget (self) (:documentation "Returns the child widget or item that has the default emphasis.")) @@ -261,8 +264,8 @@ (defgeneric parent (self) (:documentation "Returns the object's parent.")) -(defgeneric paste (self) - (:documentation "Copies content from the clipboard into the object.")) +(defgeneric paste-text (self) + (:documentation "Copies text from the clipboard into self")) (defgeneric peer (self) (:documentation "Returns the visual object associated with this object (not the underlying window system handle).")) @@ -322,7 +325,7 @@ (:documentation "Returns a list of zero-based indices identifying the selected items within this object.")) (defgeneric selection-span (self) - (:documentation "Returns a span object describing the start and end indices of the object selection.")) + (:documentation "Returns a span object describing the start and end indices of the selection within self.")) (defgeneric show (self flag) (:documentation "Causes the object to be visible or hidden on the screen, but not necessarily top-most in the display z-order.")) @@ -354,6 +357,9 @@ (defgeneric text-baseline (self) (:documentation "Returns the y coordinate of the object's text component, if any.")) +(defgeneric text-for-pasting-p (self) + (:documentation "Returns T if the clipboard has data in text format; nil otherwise.")) + (defgeneric text-height (self) (:documentation "Returns the height of the object's text field.")) Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Tue Jul 11 01:24:41 2006 @@ -91,11 +91,6 @@ (gfg::destroy-magick) (gfs::post-quit-message exit-code)) -(defun clear-all (w) - (let ((count (length (items w)))) - (unless (zerop count) - (gfw:clear-span w (gfs:make-span :start 0 :end (1- count)))))) - (defun initialize-comctl-classes (icc-flags) (cffi:with-foreign-object (ic-ptr 'gfs::initcommoncontrolsex) (cffi:with-foreign-slots ((gfs::size gfs::icc) ic-ptr gfs::initcommoncontrolsex) 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 Tue Jul 11 01:24:41 2006 @@ -33,40 +33,45 @@ (in-package :graphic-forms.uitoolkit.widgets) -(defmethod append-item :before ((w widget-with-items) text (image gfg:image) (disp event-dispatcher) &optional checked disabled) +(defmethod append-item :before ((self widget-with-items) text (image gfg:image) (disp event-dispatcher) &optional checked disabled) (declare (ignore text image disp checked disabled)) - (if (gfs:disposed-p w) + (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod clear-item :before ((w widget-with-items) index) +(defmethod clear-all ((self widget-with-items)) + (let ((count (length (items self)))) + (unless (zerop count) + (clear-span self (gfs:make-span :start 0 :end (1- count)))))) + +(defmethod clear-item :before ((self widget-with-items) index) (declare (ignore index)) - (if (gfs:disposed-p w) + (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod clear-item ((w widget-with-items) index) - (let* ((items (items w)) +(defmethod clear-item ((self widget-with-items) index) + (let* ((items (items self)) (it (elt items index))) - (delete it (items w) :test #'items-equal-p) + (delete it (items self) :test #'items-equal-p) (if (gfs:disposed-p it) (error 'gfs:disposed-error)) (gfs:dispose it))) -(defmethod clear-span :before ((w widget-with-items) (sp gfs:span)) +(defmethod clear-span :before ((self widget-with-items) (sp gfs:span)) (declare (ignore sp)) - (if (gfs:disposed-p w) + (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod clear-span ((w widget-with-items) (sp gfs:span)) +(defmethod clear-span ((self widget-with-items) (sp gfs:span)) (dotimes (i (1+ (- (gfs:span-end sp) (gfs:span-start sp)))) - (clear-item w (gfs:span-start sp)))) + (clear-item self (gfs:span-start sp)))) -(defmethod item-index :before ((w widget-with-items) (it item)) +(defmethod item-index :before ((self widget-with-items) (it item)) (declare (ignore it)) - (if (gfs:disposed-p w) + (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod item-index ((w widget-with-items) (it item)) - (let ((pos (position it (items w) :test #'items-equal-p))) +(defmethod item-index ((self widget-with-items) (it item)) + (let ((pos (position it (items self) :test #'items-equal-p))) (if (null pos) (return-from item-index 0)) 0)) Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Tue Jul 11 01:24:41 2006 @@ -125,19 +125,27 @@ (defmethod center-on-parent ((self widget)) (center-object (parent self) self)) -(defmethod checked-p :before ((w widget)) - (if (gfs:disposed-p w) +(defmethod checked-p :before ((self widget)) + (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod checked-p ((w widget)) - (declare (ignore w)) +(defmethod checked-p ((self widget)) + (declare (ignore self)) nil) -(defmethod client-size :before ((w widget)) - (if (gfs:disposed-p w) +(defmethod clear-all :before ((self widget)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + +(defmethod clear-selection :before ((self widget)) + (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod client-size ((w widget)) +(defmethod client-size :before ((self widget)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + +(defmethod client-size ((self widget)) (cffi:with-foreign-object (wi-ptr 'gfs::windowinfo) (cffi:with-foreign-slots ((gfs::cbsize gfs::clientleft @@ -146,19 +154,27 @@ gfs::clientbottom) wi-ptr gfs::windowinfo) (setf gfs::cbsize (cffi::foreign-type-size 'gfs::windowinfo)) - (when (zerop (gfs::get-window-info (gfs:handle w) wi-ptr)) + (when (zerop (gfs::get-window-info (gfs:handle self) wi-ptr)) (error 'gfs:win32-error :detail "get-window-info failed")) (gfs:make-size :width (- gfs::clientright gfs::clientleft) :height (- gfs::clientbottom gfs::clienttop))))) -(defmethod gfs:dispose ((w widget)) - (unless (null (dispatcher w)) - (event-dispose (dispatcher w) w)) - (let ((hwnd (gfs:handle w))) +(defmethod copy-text :before ((self widget)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + +(defmethod cut-text :before ((self widget)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + +(defmethod gfs:dispose ((self widget)) + (unless (null (dispatcher self)) + (event-dispose (dispatcher self) self)) + (let ((hwnd (gfs:handle self))) (if (not (gfs:null-handle-p hwnd)) (if (zerop (gfs::destroy-window hwnd)) (error 'gfs:win32-error :detail "destroy-window failed")))) - (setf (slot-value w 'gfs:handle) nil)) + (setf (slot-value self 'gfs:handle) nil)) (defmethod enable :before ((self widget) flag) (declare (ignore flag)) @@ -254,6 +270,10 @@ (error 'gfs:toolkit-error :detail "no widget for hwnd"))) widget)) +(defmethod paste-text :before ((self widget)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + (defmethod print-object ((self widget) stream) (print-unreadable-object (self stream :type t) (format stream "handle: ~x " (gfs:handle self)) @@ -290,6 +310,10 @@ (declare (ignore self)) nil) +(defmethod selection-span :before ((self widget)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + (defmethod size :before ((self widget)) (if (gfs:disposed-p self) (error 'gfs:disposed-error))) @@ -326,6 +350,13 @@ (if (gfs:disposed-p self) (error 'gfs:disposed-error))) +(defmethod text-for-pasting-p :before ((self widget)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + +(defmethod text-for-pasting-p ((self widget)) + nil) + (defmethod (setf text-modified-p) :before (flag (self widget)) (declare (ignore flag)) (if (gfs:disposed-p self)

1 0

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

10 Jul '06

Author: junrue Date: Mon Jul 10 17:26:44 2006 New Revision: 190 Modified: trunk/docs/manual/api.texinfo trunk/src/demos/textedit/textedit-window.lisp trunk/src/packages.lisp trunk/src/uitoolkit/widgets/edit.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp trunk/src/uitoolkit/widgets/widget.lisp Log: defined widget functions for querying undo and redo state, and implemented them for edit controls Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Mon Jul 10 17:26:44 2006 @@ -1525,6 +1525,11 @@ display; nil otherwise. @end deffn +@deffn GenericFunction redo-available-p self => boolean +Returns T if @code{self} has @sc{redo} capability and has an +operation that can be redone; @sc{nil} otherwise. +@end deffn + @deffn GenericFunction redraw self Causes the entire bounds of the object to be marked as needing to be redrawn @end deffn @@ -1583,6 +1588,11 @@ other cases there is no text component at all. @end deffn +@deffn GenericFunction undo-available-p self => boolean +Returns T if @code{self} has @sc{undo} capability and has an +operation that can be undone; @sc{nil} otherwise. +@end deffn + @deffn GenericFunction update self Forces all outstanding paint requests for the object to be processed before this function returns. Modified: trunk/src/demos/textedit/textedit-window.lisp ============================================================================== --- trunk/src/demos/textedit/textedit-window.lisp (original) +++ trunk/src/demos/textedit/textedit-window.lisp Mon Jul 10 17:26:44 2006 @@ -86,6 +86,13 @@ (setf *textedit-win* nil) (gfw:shutdown 0)) +(defun manage-textedit-edit-menu (disp menu) + (declare (ignore disp)) + (unless *textedit-control* + (return-from manage-textedit-edit-menu nil)) + (let ((items (gfw:items menu))) + (gfw:enable (elt items 0) (gfw:undo-available-p *textedit-control*)))) + (defun textedit-font (disp item) (declare (ignore disp item)) (gfw:with-graphics-context (gc *textedit-control*) @@ -175,7 +182,7 @@ (cells:defobserver file-path ((self textedit-document)) (if *textedit-win* - (setf (gfw:text *textedit-win*) (format nil "~s - GraphicForms TextEdit" (file-path self))) + (setf (gfw:text *textedit-win*) (format nil "~a - GraphicForms TextEdit" (file-path self))) (setf (gfw:text *textedit-win*) "new file - GraphicForms TextEdit"))) (defun textedit-startup () @@ -186,21 +193,21 @@ (let ((menubar (gfw:defmenu ((:item "&File" :callback #'manage-textedit-file-menu :submenu ((:item "&New" :callback #'textedit-file-new) (:item "&Open..." :callback #'textedit-file-open) - (:item "&Save" :callback #'textedit-file-save :disabled) + (:item "&Save" :callback #'textedit-file-save :disabled) (:item "Save &As..." :callback #'textedit-file-save-as) (:item "" :separator) (:item "E&xit" :callback #'textedit-file-quit))) - (:item "&Edit" - :submenu ((:item "&Undo") + (:item "&Edit" :callback #'manage-textedit-edit-menu + :submenu ((:item "&Undo" :callback #'textedit-edit-undo :disabled) (:item "" :separator) - (:item "Cu&t") - (:item "&Copy") - (:item "&Paste") - (:item "De&lete") + (:item "Cu&t" :callback #'textedit-edit-cut :disabled) + (:item "&Copy" :callback #'textedit-edit-copy :disabled) + (:item "&Paste" :callback #'textedit-edit-paste :disabled) + (:item "De&lete" :callback #'textedit-edit-delete :disabled) (:item "" :separator) (:item "&Find...") - (:item "Find &Next") - (:item "&Replace...") + (:item "Find &Next" :disabled) + (:item "&Replace..." :disabled) (:item "&Go To...") (:item "" :separator) (:item "Select &All"))) Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Mon Jul 10 17:26:44 2006 @@ -496,6 +496,7 @@ #:traverse #:traverse-order #:trim-sizes + #:undo-available-p #:update #:vertical-scrollbar #:visible-item-count Modified: trunk/src/uitoolkit/widgets/edit.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/edit.lisp (original) +++ trunk/src/uitoolkit/widgets/edit.lisp Mon Jul 10 17:26:44 2006 @@ -132,3 +132,6 @@ (defmethod (setf text-modified-p) (flag (self edit)) (gfs::send-message (gfs:handle self) gfs::+em-setmodify+ (if flag 1 0) 0)) + +(defmethod undo-available-p ((self edit)) + (/= (gfs::send-message (gfs:handle self) gfs::+em-canundo+ 0 0) 0)) Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Mon Jul 10 17:26:44 2006 @@ -270,6 +270,9 @@ (defgeneric preferred-size (self width-hint height-hint) (:documentation "Returns a size object representing the object's 'preferred' size.")) +(defgeneric redo-available-p (self) + (:documentation "Returns T if self can redo an operation; nil otherwise.")) + (defgeneric redraw (self) (:documentation "Causes the entire bounds of the object to be marked as needing to be redrawn")) @@ -375,6 +378,9 @@ (defgeneric traverse-order (self) (:documentation "Returns a list of this object's layout-managed children in the order in which tab traversal would visit them.")) +(defgeneric undo-available-p (self) + (:documentation "Returns T if self can undo an operation; nil otherwise.")) + (defgeneric update (self) (:documentation "Forces all outstanding paint requests for the object to be processed before this function returns.")) Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Mon Jul 10 17:26:44 2006 @@ -259,6 +259,13 @@ (format stream "handle: ~x " (gfs:handle self)) (format stream "dispatcher: ~a " (dispatcher self)))) +(defmethod redo-available-p :before ((self widget)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + +(defmethod redo-available-p ((self widget)) + nil) + (defmethod redraw :before ((self widget)) (if (gfs:disposed-p self) (error 'gfs:disposed-error))) @@ -328,6 +335,13 @@ (if (gfs:disposed-p self) (error 'gfs:disposed-error))) +(defmethod undo-available-p :before ((self widget)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + +(defmethod undo-available-p ((self widget)) + nil) + (defmethod update :before ((w widget)) (if (gfs:disposed-p w) (error 'gfs:disposed-error)))

1 0

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

09 Jul '06

Author: junrue Date: Sun Jul 9 16:38:15 2006 New Revision: 189 Modified: trunk/docs/manual/api.texinfo trunk/docs/manual/reference.texinfo trunk/src/uitoolkit/widgets/control.lisp trunk/src/uitoolkit/widgets/event-source.lisp trunk/src/uitoolkit/widgets/menu-item.lisp trunk/src/uitoolkit/widgets/menu-language.lisp trunk/src/uitoolkit/widgets/menu.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp Log: abstracted :callback setup somewhat for controls; added related documentation Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Sun Jul 9 16:38:15 2006 @@ -178,12 +178,22 @@ classes. @anchor{button} -@deftp Class button -This @ref{control} class represents selectable controls that invoke -the @ref{event-select} method defined for an @ref{event-dispatcher} -associated with the @code{button}. +@deftp Class button callback-event-name +This @ref{control} class represents selectable controls that generate +an event when clicked. +@table @var +@item callback-event-name +This is an (@code{:allocation :class}) slot that holds a symbol +identifying an event function (e.g., @ref{event-select}). See +@ref{event-source} for more details on this slot. +@end table +@deffn Initarg :callback +The @sc{function} value supplied via this initarg will be +used as the implementation of @ref{event-select} in an +@ref{event-dispatcher} configured for the @code{button}. +@end deffn @deffn Initarg :image -Supplies an image to be used as the @code{button} label. +Supplies an image to be used as the @code{button}'s label. @end deffn @deffn Initarg :style @table @code @@ -229,7 +239,43 @@ @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 -@ref{widget}. +@ref{widget}.@*@* +@strong{Note:} application code should not manipulate @code{control} slots +directly, unless defining a new @code{control} type as an extension to +Graphic-Forms. +@table @var +@item brush-color +If set, this @ref{color} object is used as the @code{control}'s background color +when the @code{control} needs to be redrawn. +@item brush-handle +This is a native handle for a Win32 @sc{brush} that is used when customizing +the @code{control}'s background color. +@item font +This is a @ref{font} object for customizing the text of a @code{control}. +@item pixel-point +This is a @ref{point} object specifying a pixel in an @ref{image} +associated with a @code{control}, for the purpose of determining what +color to use for transparency. +@item maximum-size +This is a @ref{size} object that places a maximum constraint on the +size that a @ref{layout-manager} may set for the @code{control}. It +may be @sc{nil} if no such constraint has been set. +@item minimum-size +This is a @ref{size} object that places a minimum constraint on the +size that a @ref{layout-manager} may set for the @code{control}. It +may be @sc{nil} if no such constraint has been set. +@item text-color +If set, this color object is used as the @code{control}'s foreground text +color when the @code{control} needs to be redrawn. +@end table +@deffn Initarg :callback +This initarg associates a @sc{function} with an @ref{event-dispatcher} +subclass that is generated behind the scenes and then instantiated to +serve as the @code{control}'s event dispatcher. Each @code{control} +subclass specifies the particular event function (e.g., @ref{event-select}) +that this callback will implement; see the documentation for specific +@code{control} subclasses for more information on this initarg. +@end deffn @end deftp @anchor{dialog} @@ -281,13 +327,24 @@ @end deftp @anchor{edit} -@deftp Class edit +@deftp Class edit callback-event-name This subclass of @ref{control} represents a rectangular area that permits the user to enter and edit text. The @ref{event-focus-gain} and @ref{event-focus-loss} methods of each @code{edit control}'s @ref{event-dispatcher} are invoked when focus is given or taken away. The @ref{event-modify} method is invoked when the user edits content. +@table @var +@item callback-event-name +This is an (@code{:allocation :class}) slot that holds a symbol +identifying an event function (e.g., @ref{event-modify}). See +@ref{event-source} for more details on this slot. +@end table +@deffn Initarg :callback +The @sc{function} value supplied via this initarg will be +used as the implementation of @ref{event-modify} in an +@ref{event-dispatcher} configured for the @code{edit control}. +@end deffn @deffn Initarg :style @table @code @item :auto-hscroll @@ -346,15 +403,33 @@ behalf of @ref{widget}s. Applications define subclasses of @code{event-dispatcher} and implement one or more of the @ref{event functions} specializing on each such application-defined subclass in -order to implement desired behavior. +order to implement desired behavior. @xref{event-source}. @end deftp @anchor{event-source} -@deftp Class event-source dispatcher +@deftp Class event-source callback-event-name dispatcher This is the base class for user interface objects that generate -events. It derives from @ref{native-object}. The @code{dispatcher} -slot holds an instance of @ref{event-dispatcher} that is responsible -for processing events on behalf of an @code{event-source}. +events@footnote{Actually, events are generated by underlying +native window objects, which are represented in the class hierarchy by +the event-source class}. It derives from @ref{native-object}. +@table @var +@item callback-event-name +This is an (@code{:allocation :class}) slot that holds a symbol +identifying an event function (e.g., @ref{event-select}), to be +supplied along with a function pointer in calls to the internal +@code{define-dispatcher} function. The purpose of this is to +facilitate implementation of shortcuts for defining dispatchers where +definition of a primary event function is sufficient, as is the case +when a @ref{control} class wants to support a @code{:callback} +initarg. The choice of event function is determined by each subclass, +hence this slot is shadowed by each such subclass. Application code +typically is not concerned with this slot, except when an application +defines new kinds of event sources. +@item dispatcher +This slot holds a reference to an instance of @ref{event-dispatcher}, +which has responsibility for handling events on behalf of the event +source object. +@end table @deffn Initarg :callbacks The @code{:callbacks} initarg value specifies an association list where the @code{CAR} of each entry is the symbol of an @code{event-*} @@ -362,10 +437,6 @@ pointer. As such, this constitutes a specification for a new @ref{event-dispatcher} class and associated methods. @end deffn -@deffn Initarg :dispatcher -@end deffn -@deffn Accessor dispatcher -@end deffn @end deftp @anchor{file-dialog} @@ -634,13 +705,13 @@ @end deftp @deftp Class menu-item -A subclass of @ref{item} representing a menu item. +A subclass of @ref{item} representing a @ref{menu} item. @end deftp @anchor{panel} @deftp Class panel Base class for @ref{window}s that are children of @ref{top-level} -@ref{window}s (or other panels). +windows, @ref{dialog}s, or other @code{panel}s. @end deftp @anchor{root-window} @@ -666,7 +737,7 @@ @end deftp @anchor{timer} -@deftp Class timer +@deftp Class timer id initial-delay delay A timer is a non-windowed object that generates events at a regular (adjustable) frequency. Applications handle timer events by implementing the @ref{event-timer} generic function. This class Modified: trunk/docs/manual/reference.texinfo ============================================================================== --- trunk/docs/manual/reference.texinfo (original) +++ trunk/docs/manual/reference.texinfo Sun Jul 9 16:38:15 2006 @@ -149,6 +149,8 @@ @end copying @c %**end of header +@footnotestyle end + @titlepage @title Graphic-Forms Programming Reference @c @subtitle Version 0.5 Modified: trunk/src/uitoolkit/widgets/control.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/control.lisp (original) +++ trunk/src/uitoolkit/widgets/control.lisp Sun Jul 9 16:38:15 2006 @@ -148,11 +148,11 @@ (defmethod give-focus ((self control)) (gfs::set-focus (gfs:handle self))) -(defmethod initialize-instance :after ((self control) &key callback callbacks disp parent &allow-other-keys) +(defmethod initialize-instance :after ((self control) &key callback callbacks dispatcher parent &allow-other-keys) (if (gfs:disposed-p parent) (error 'gfs:disposed-error)) - (unless (or disp callbacks (not (functionp callback))) - (let ((class (define-dispatcher `((event-select . ,callback))))) + (unless (or dispatcher callbacks (not (functionp callback))) + (let ((class (define-dispatcher (class-name (class-of self)) callback))) (setf (dispatcher self) (make-instance (class-name class)))))) (defmethod (setf maximum-size) :after (max-size (self control)) Modified: trunk/src/uitoolkit/widgets/event-source.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event-source.lisp (original) +++ trunk/src/uitoolkit/widgets/event-source.lisp Sun Jul 9 16:38:15 2006 @@ -35,6 +35,7 @@ (defconstant +callback-info+ '((gfw:event-activate . (gfw:event-source)) (gfw:event-arm . (gfw:event-source)) + (gfw:event-modify . (gfw:event-source)) (gfw:event-select . (gfw:event-source)))) (defun make-specializer-list (disp-class arg-info) @@ -42,10 +43,10 @@ (push disp-class tmp) tmp)) -(defun define-dispatcher (callbacks) - (let* ((*print-gensym* nil) - (class (clos:ensure-class (gentemp "EDCLASS" :gfgen) - :direct-superclasses '(event-dispatcher)))) +(defun define-dispatcher-for-callbacks (callbacks) + (let ((*print-gensym* nil) + (class (clos:ensure-class (gentemp "EDCLASS" :gfgen) + :direct-superclasses '(event-dispatcher)))) (loop for pair in callbacks do (let* ((method-sym (car pair)) (fn (cdr pair)) @@ -65,13 +66,17 @@ :specializers (make-specializer-list class arg-info)))) class)) +(defun define-dispatcher (classname callback) + (let ((proto (c2mop:class-prototype (find-class classname)))) + (define-dispatcher-for-callbacks `((,(callback-event-name-of proto) . ,callback))))) + ;;; ;;; methods ;;; -(defmethod initialize-instance :after ((self event-source) &key callbacks disp &allow-other-keys) - (unless (or disp (null callbacks)) - (let ((class (define-dispatcher callbacks))) +(defmethod initialize-instance :after ((self event-source) &key callbacks dispatcher &allow-other-keys) + (unless (or dispatcher (null callbacks)) + (let ((class (define-dispatcher-for-callbacks callbacks))) (setf (dispatcher self) (make-instance (class-name class)))))) (defmethod owner :before ((self event-source)) Modified: trunk/src/uitoolkit/widgets/menu-item.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu-item.lisp (original) +++ trunk/src/uitoolkit/widgets/menu-item.lisp Sun Jul 9 16:38:15 2006 @@ -172,7 +172,7 @@ ((null disp) (setf item (make-instance 'menu-item :handle hmenu))) ((functionp disp) - (setf item (make-instance 'menu-item :handle hmenu :callbacks `((gfw:event-select . ,disp))))) + (setf item (make-instance 'menu-item :handle hmenu :callback disp))) ((typep disp 'gfw:event-dispatcher) (setf item (make-instance 'menu-item :handle hmenu :dispatcher disp))) (t @@ -220,6 +220,12 @@ gfs::+mfs-enabled+) gfs::+mfs-enabled+)) +(defmethod initialize-instance :after ((self menu-item) &key callback &allow-other-keys) + (when callback + (unless (typep callback 'function) + (error 'gfs:toolkit-error :detail ":callback value must be a function")) + (setf (dispatcher self) (make-instance (define-dispatcher 'menu-item callback))))) + (defmethod owner ((it menu-item)) (let ((hmenu (gfs:handle it))) (if (gfs:null-handle-p hmenu) Modified: trunk/src/uitoolkit/widgets/menu-language.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu-language.lisp (original) +++ trunk/src/uitoolkit/widgets/menu-language.lisp Sun Jul 9 16:38:15 2006 @@ -150,8 +150,8 @@ (if (null callback) (error 'gfs:toolkit-error :detail "missing callback argument")) (if sub - (setf disp `(make-instance (define-dispatcher `((gfw:event-activate . ,,callback))))) - (setf disp `(make-instance (define-dispatcher `((gfw:event-select . ,,callback))))))) + (setf disp `(make-instance (define-dispatcher 'gfw:menu ,callback))) + (setf disp `(make-instance (define-dispatcher 'gfw:menu-item ,callback))))) (when disp (if sep (error 'gfs:toolkit-error :detail "dispatchers cannot be set for separators")) Modified: trunk/src/uitoolkit/widgets/menu.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu.lisp (original) +++ trunk/src/uitoolkit/widgets/menu.lisp Sun Jul 9 16:38:15 2006 @@ -131,7 +131,7 @@ (cond ((null disp)) ((functionp disp) - (let ((class (define-dispatcher `((event-activate . ,disp))))) + (let ((class (define-dispatcher 'gfw:menu disp))) (setf (dispatcher submenu) (make-instance (class-name class))))) ((typep disp 'gfw:event-dispatcher) (setf (dispatcher submenu) disp)) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Sun Jul 9 16:38:15 2006 @@ -72,14 +72,22 @@ ((dispatcher :accessor dispatcher :initarg :dispatcher - :initform (make-instance 'event-dispatcher))) + :initform (make-instance 'event-dispatcher)) + (callback-event-name + :accessor callback-event-name-of + :initform nil + :allocation :class)) ; subclasses will shadow this slot (:documentation "This is the base class for user interface objects that generate events.")) (defclass item (event-source) ((item-id :accessor item-id :initarg :item-id - :initform 0)) + :initform 0) + (callback-event-name + :accessor callback-event-name-of + :initform 'event-select + :allocation :class)) ; shadowing same slot from event-source (:documentation "The item class is the base class for all non-windowed user interface objects.")) (defclass menu-item (item) () @@ -121,10 +129,18 @@ :initform nil)) (:documentation "The base class for widgets having pre-defined native behavior.")) -(defclass button (control) () +(defclass button (control) + ((callback-event-name + :accessor callback-event-name-of + :initform 'event-select + :allocation :class)) ; shadowing same slot from event-source (:documentation "This class represents selectable controls that issue notifications when clicked.")) -(defclass edit (control) () +(defclass edit (control) + ((callback-event-name + :accessor callback-event-name-of + :initform 'event-modify + :allocation :class)) ; shadowing same slot from event-source (:documentation "This class represents a control in which the user may enter and edit text.")) (defclass label (control) () @@ -146,7 +162,11 @@ :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 menu (widget-with-items) () +(defclass menu (widget-with-items) + ((callback-event-name + :accessor callback-event-name-of + :initform 'event-activate + :allocation :class)) ; shadowing same slot from event-source (:documentation "The menu class represents a container for menu items (and submenus).")) (defclass window (widget layout-managed)

1 0

[graphic-forms-cvs] r188 - in trunk: docs/manual src/demos/textedit src/demos/unblocked src/tests/uitoolkit src/uitoolkit/widgets
by junrue＠common-lisp.net 09 Jul '06

09 Jul '06

Author: junrue Date: Sun Jul 9 12:03:27 2006 New Revision: 188 Modified: trunk/docs/manual/api.texinfo trunk/src/demos/textedit/textedit-window.lisp trunk/src/demos/unblocked/unblocked-window.lisp trunk/src/tests/uitoolkit/drawing-tester.lisp trunk/src/tests/uitoolkit/event-tester.lisp trunk/src/tests/uitoolkit/hello-world.lisp trunk/src/tests/uitoolkit/image-tester.lisp trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/tests/uitoolkit/windlg.lisp trunk/src/uitoolkit/widgets/event-generics.lisp trunk/src/uitoolkit/widgets/event-source.lisp trunk/src/uitoolkit/widgets/event.lisp Log: removed rectangle argument from event-select and generated callbacks Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Sun Jul 9 12:03:27 2006 @@ -1084,7 +1084,7 @@ @end deffn @anchor{event-select} -@deffn GenericFunction event-select dispatcher widget rect +@deffn GenericFunction event-select dispatcher widget Implement this method to handle notification that @var{widget} (or some @ref{item} within @var{widget}) has been clicked on by the user in order to invoke some action. @@ -1092,8 +1092,6 @@ @event-dispatcher-arg @item widget The @ref{widget} (or item) that was selected. -@item rect -The @ref{rectangle} bounding the selection inside @var{widget}. @end table @end deffn Modified: trunk/src/demos/textedit/textedit-window.lisp ============================================================================== --- trunk/src/demos/textedit/textedit-window.lisp (original) +++ trunk/src/demos/textedit/textedit-window.lisp Sun Jul 9 12:03:27 2006 @@ -44,15 +44,15 @@ (declare (ignore disp)) (gfw:enable (elt (gfw:items menu) 2) (gfw:text-modified-p *textedit-control*))) -(defun textedit-file-new (disp item rect) - (declare (ignore disp item rect)) +(defun textedit-file-new (disp item) + (declare (ignore disp item)) (when *textedit-control* (setf (gfw:text *textedit-control*) "") (setf (gfw:text-modified-p *textedit-control*) nil) (setf (file-path *textedit-model*) nil))) -(defun textedit-file-open (disp item rect) - (declare (ignore disp item rect)) +(defun textedit-file-open (disp item) + (declare (ignore disp item)) (gfw:with-file-dialog (*textedit-win* '(:open :add-to-recent :path-must-exist) paths @@ -61,14 +61,14 @@ (load-textedit-doc (first paths)) (setf (file-path *textedit-model*) (namestring (first paths)))))) -(defun textedit-file-save (disp item rect) +(defun textedit-file-save (disp item) (if (file-path *textedit-model*) (save-textedit-doc (file-path *textedit-model*) (gfw:text *textedit-control*)) - (textedit-file-save-as disp item rect)) + (textedit-file-save-as disp item)) (setf (gfw:text-modified-p *textedit-control*) nil)) -(defun textedit-file-save-as (disp item rect) - (declare (ignore disp item rect)) +(defun textedit-file-save-as (disp item) + (declare (ignore disp item)) (gfw:with-file-dialog (*textedit-win* '(:save :add-to-recent) paths @@ -79,15 +79,15 @@ (setf (file-path *textedit-model*) (namestring (first paths))) (setf (gfw:text-modified-p *textedit-control*) nil)))) -(defun textedit-file-quit (disp item rect) - (declare (ignore disp item rect)) +(defun textedit-file-quit (disp item) + (declare (ignore disp item)) (setf *textedit-control* nil) (gfs:dispose *textedit-win*) (setf *textedit-win* nil) (gfw:shutdown 0)) -(defun textedit-font (disp item rect) - (declare (ignore disp item rect)) +(defun textedit-font (disp item) + (declare (ignore disp item)) (gfw:with-graphics-context (gc *textedit-control*) (gfw:with-font-dialog (*textedit-win* '(:no-effects) font color :gc gc :initial-font (gfg:font *textedit-control*)) (if font @@ -102,7 +102,7 @@ (defmethod gfw:event-close ((disp textedit-win-events) window) (declare (ignore window)) - (textedit-file-quit disp nil nil)) + (textedit-file-quit disp nil)) (defclass textedit-about-dialog-events (gfw:event-dispatcher) ()) @@ -110,8 +110,8 @@ (call-next-method) (gfs:dispose dlg)) -(defun about-textedit (disp item rect) - (declare (ignore disp item rect)) +(defun about-textedit (disp item) + (declare (ignore disp item)) (let* ((image (make-instance 'gfg:image :file (merge-pathnames "src/demos/textedit/about.bmp" *textedit-startup-dir*))) (dlg (make-instance 'gfw:dialog :owner *textedit-win* :dispatcher (make-instance 'textedit-about-dialog-events) @@ -152,8 +152,8 @@ :spacing 0 :style '(:vertical :normalize)))) (close-btn (make-instance 'gfw:button - :callback (lambda (disp btn rect) - (declare (ignore disp btn rect)) + :callback (lambda (disp btn) + (declare (ignore disp btn)) (gfs:dispose dlg)) :style '(:cancel-button) :text "Close" Modified: trunk/src/demos/unblocked/unblocked-window.lisp ============================================================================== --- trunk/src/demos/unblocked/unblocked-window.lisp (original) +++ trunk/src/demos/unblocked/unblocked-window.lisp Sun Jul 9 12:03:27 2006 @@ -52,14 +52,14 @@ (defun get-scoreboard-panel () *scoreboard-panel*) -(defun new-unblocked (disp item rect) - (declare (ignore disp item rect)) +(defun new-unblocked (disp item) + (declare (ignore disp item)) (new-game) (update-panel *scoreboard-panel*) (update-panel *tiles-panel*)) -(defun restart-unblocked (disp item rect) - (declare (ignore disp item rect)) +(defun restart-unblocked (disp item) + (declare (ignore disp item)) (restart-game) (update-panel *scoreboard-panel*) (update-panel *tiles-panel*)) @@ -69,8 +69,8 @@ (kind (shape-kind shape))) (and (> size 1) (/= kind 0) (/= kind +max-tile-kinds+)))) -(defun reveal-unblocked (disp item rect) - (declare (ignore disp item rect)) +(defun reveal-unblocked (disp item) + (declare (ignore disp item)) (let ((shape (find-shape (game-tiles) #'accept-shape-p))) (when shape (let ((shape-pnts (shape-tile-points shape)) @@ -80,8 +80,8 @@ (draw-tiles-directly *tiles-panel* shape-pnts +max-tile-kinds+) (gfw:enable timer t))))) -(defun quit-unblocked (disp item rect) - (declare (ignore disp item rect)) +(defun quit-unblocked (disp item) + (declare (ignore disp item)) (setf *scoreboard-panel* nil) (setf *tiles-panel* nil) (gfs:dispose *unblocked-win*) @@ -92,7 +92,7 @@ (defmethod gfw:event-close ((disp unblocked-win-events) window) (declare (ignore window)) - (quit-unblocked disp nil nil)) + (quit-unblocked disp nil)) (defmethod gfw:event-timer ((disp unblocked-win-events) timer) (declare (ignore timer)) @@ -104,8 +104,8 @@ (call-next-method) (gfs:dispose dlg)) -(defun about-unblocked (disp item rect) - (declare (ignore disp item rect)) +(defun about-unblocked (disp item) + (declare (ignore disp item)) (let* ((image (make-instance 'gfg:image :file (merge-pathnames "src/demos/unblocked/about.bmp" *unblocked-startup-dir*))) (dlg (make-instance 'gfw:dialog :owner *unblocked-win* :dispatcher (make-instance 'unblocked-about-dialog-events) @@ -146,8 +146,8 @@ :spacing 0 :style '(:vertical :normalize)))) (close-btn (make-instance 'gfw:button - :callback (lambda (disp btn rect) - (declare (ignore disp btn rect)) + :callback (lambda (disp btn) + (declare (ignore disp btn)) (gfs:dispose dlg)) :style '(:cancel-button) :text "Close" @@ -203,7 +203,7 @@ (setf (gfw:minimum-size *unblocked-win*) size) (setf (gfw:maximum-size *unblocked-win*) size)) - (new-unblocked nil nil nil) + (new-unblocked nil nil) (gfw:show *unblocked-win* t))) (defun unblocked () Modified: trunk/src/tests/uitoolkit/drawing-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/drawing-tester.lisp (original) +++ trunk/src/tests/uitoolkit/drawing-tester.lisp Sun Jul 9 12:03:27 2006 @@ -50,8 +50,8 @@ (setf *last-checked-drawing-item* item) (return))))) -(defun drawing-exit-fn (disp item rect) - (declare (ignore disp item rect)) +(defun drawing-exit-fn (disp item) + (declare (ignore disp item)) (gfs:dispose *drawing-win*) (setf *drawing-win* nil) (gfw:shutdown 0)) @@ -63,7 +63,7 @@ (defmethod gfw:event-close ((self drawing-win-events) window) (declare (ignore window)) - (drawing-exit-fn self nil nil)) + (drawing-exit-fn self nil)) (defmethod gfw:event-paint ((self drawing-win-events) window gc rect) (declare (ignore rect)) @@ -162,8 +162,8 @@ (setf rect (gfs:make-rectangle :location (clone-point rect-pnt) :size rect-size)) (draw-rect-start-end gc rect (clone-point start-pnt) (clone-point end-pnt) delta-x #'gfg:draw-arc nil))) -(defun select-arcs (disp item rect) - (declare (ignore disp rect)) +(defun select-arcs (disp item) + (declare (ignore disp)) (update-drawing-item-check item) (setf (draw-func-of *drawing-dispatcher*) #'draw-arcs) (gfw:redraw *drawing-win*)) @@ -185,8 +185,8 @@ (setf (gfg:pen-style gc) '(:dot :square-endcap)) (gfg:draw-poly-bezier gc (gfs:make-point :x 10 :y 110) poly-pnts)))) -(defun select-beziers (disp item rect) - (declare (ignore disp rect)) +(defun select-beziers (disp item) + (declare (ignore disp)) (update-drawing-item-check item) (setf (draw-func-of *drawing-dispatcher*) #'draw-beziers) (gfw:redraw *drawing-win*)) @@ -202,8 +202,8 @@ (setf rect (gfs:make-rectangle :location (clone-point rect-pnt) :size rect-size)) (draw-rectangular gc rect nil delta-x #'gfg:draw-ellipse nil))) -(defun select-ellipses (disp item rect) - (declare (ignore disp rect)) +(defun select-ellipses (disp item) + (declare (ignore disp)) (update-drawing-item-check item) (setf (draw-func-of *drawing-dispatcher*) #'draw-ellipses) (gfw:redraw *drawing-win*)) @@ -240,8 +240,8 @@ #'gfg:draw-line nil))) -(defun select-lines (disp item rect) - (declare (ignore disp rect)) +(defun select-lines (disp item) + (declare (ignore disp)) (update-drawing-item-check item) (setf (draw-func-of *drawing-dispatcher*) #'draw-lines) (gfw:redraw *drawing-win*)) @@ -264,8 +264,8 @@ (setf rect (gfs:make-rectangle :location (clone-point rect-pnt) :size rect-size)) (draw-rectangular gc rect nil delta-x #'gfg:draw-rectangle nil))) -(defun select-rects (disp item rect) - (declare (ignore disp rect)) +(defun select-rects (disp item) + (declare (ignore disp)) (update-drawing-item-check item) (setf (draw-func-of *drawing-dispatcher*) #'draw-rects) (gfw:redraw *drawing-win*)) @@ -314,8 +314,8 @@ (setf (gfg:foreground-color gc) gfg:*color-red*) (draw-a-string gc pnt "text" "Arial" 12 nil '(:transparent)))) -(defun select-text (disp item rect) - (declare (ignore disp rect)) +(defun select-text (disp item) + (declare (ignore disp)) (update-drawing-item-check item) (setf (draw-func-of *drawing-dispatcher*) #'draw-strings) (gfw:redraw *drawing-win*)) @@ -336,8 +336,8 @@ (setf rect (gfs:make-rectangle :location (clone-point rect-pnt) :size rect-size)) (draw-rect-start-end gc rect (clone-point start-pnt) (clone-point end-pnt) delta-x #'gfg:draw-pie-wedge nil))) -(defun select-wedges (disp item rect) - (declare (ignore disp rect)) +(defun select-wedges (disp item) + (declare (ignore disp)) (update-drawing-item-check item) (setf (draw-func-of *drawing-dispatcher*) #'draw-wedges) (gfw:redraw *drawing-win*)) Modified: trunk/src/tests/uitoolkit/event-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/event-tester.lisp (original) +++ trunk/src/tests/uitoolkit/event-tester.lisp Sun Jul 9 12:03:27 2006 @@ -184,8 +184,8 @@ (defclass event-tester-exit-dispatcher (gfw:event-dispatcher) ()) -(defmethod gfw:event-select ((d event-tester-exit-dispatcher) item rect) - (declare (ignore item rect)) +(defmethod gfw:event-select ((d event-tester-exit-dispatcher) item) + (declare (ignore item)) (exit-event-tester)) (defmethod gfw:event-arm ((d event-tester-exit-dispatcher) item) @@ -194,8 +194,7 @@ (defclass event-tester-echo-dispatcher (gfw:event-dispatcher) ()) -(defmethod gfw:event-select ((d event-tester-echo-dispatcher) item rect) - (declare (ignore rect)) +(defmethod gfw:event-select ((d event-tester-echo-dispatcher) item) (setf *event-tester-text* (text-for-item (gfw:text item) "item selected")) (gfw:redraw *event-tester-window*)) @@ -217,8 +216,8 @@ (let ((item (elt (gfw:items menu) 0))) (setf (gfw:text item) (if *timer* "Sto&p Timer" "&Start Timer")))) -(defun manage-timer (disp item rect) - (declare (ignore disp item rect)) +(defun manage-timer (disp item) + (declare (ignore disp item)) (if *timer* (progn (gfw:enable *timer* nil) Modified: trunk/src/tests/uitoolkit/hello-world.lisp ============================================================================== --- trunk/src/tests/uitoolkit/hello-world.lisp (original) +++ trunk/src/tests/uitoolkit/hello-world.lisp Sun Jul 9 12:03:27 2006 @@ -37,15 +37,15 @@ (defclass hellowin-events (gfw:event-dispatcher) ()) -(defun exit-fn (disp item rect) - (declare (ignore disp item rect)) +(defun exit-fn (disp item) + (declare (ignore disp item)) (gfs:dispose *hello-win*) (setf *hello-win* nil) (gfw:shutdown 0)) (defmethod gfw:event-close ((disp hellowin-events) window) (declare (ignore window)) - (exit-fn disp nil nil)) + (exit-fn disp nil)) (defmethod gfw:event-paint ((disp hellowin-events) window gc rect) (declare (ignore rect)) Modified: trunk/src/tests/uitoolkit/image-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/image-tester.lisp (original) +++ trunk/src/tests/uitoolkit/image-tester.lisp Sun Jul 9 12:03:27 2006 @@ -86,8 +86,8 @@ (incf (gfs:point-x pnt) 20) (gfg:draw-image gc *true-image* pnt)))) -(defun exit-image-fn (disp item rect) - (declare (ignorable disp item rect)) +(defun exit-image-fn (disp item) + (declare (ignorable disp item)) (dispose-images) (gfs:dispose *image-win*) (setf *image-win* nil) Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Sun Jul 9 12:03:27 2006 @@ -58,8 +58,8 @@ (defclass pack-layout-dispatcher (gfw:event-dispatcher) ()) -(defmethod gfw:event-select ((d pack-layout-dispatcher) item rect) - (declare (ignore item rect)) +(defmethod gfw:event-select ((d pack-layout-dispatcher) item) + (declare (ignore item)) (gfw:pack *layout-tester-win*)) (defclass layout-tester-widget-events (gfw:event-dispatcher) @@ -139,8 +139,7 @@ :dispatcher be)))) (incf *widget-counter*))) -(defmethod gfw:event-select ((d layout-tester-widget-events) btn rect) - (declare (ignore rect)) +(defmethod gfw:event-select ((d layout-tester-widget-events) btn) (setf (gfw:text btn) (funcall (toggle-fn d))) (gfw:layout *layout-tester-win*)) @@ -154,8 +153,8 @@ :initarg :subtype :initform :push-button))) -(defmethod gfw:event-select ((d add-child-dispatcher) item rect) - (declare (ignorable item rect)) +(defmethod gfw:event-select ((d add-child-dispatcher) item) + (declare (ignore item)) (add-layout-tester-widget (widget-class d) (subtype d)) (gfw:pack *layout-tester-win*)) @@ -191,8 +190,7 @@ (defclass remove-child-dispatcher (gfw:event-dispatcher) ()) -(defmethod gfw:event-select ((d remove-child-dispatcher) item rect) - (declare (ignore rect)) +(defmethod gfw:event-select ((d remove-child-dispatcher) item) (let ((victim (find-victim (gfw:text item)))) (unless (null victim) (gfs:dispose victim) @@ -200,8 +198,7 @@ (defclass visibility-child-dispatcher (gfw:event-dispatcher) ()) -(defmethod gfw:event-select ((d visibility-child-dispatcher) item rect) - (declare (ignore rect)) +(defmethod gfw:event-select ((d visibility-child-dispatcher) item) (let ((victim (find-victim (gfw:text item)))) (unless (null victim) (gfw:show victim (not (gfw:visible-p victim))) @@ -213,8 +210,8 @@ (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 rect) - (declare (ignorable disp item rect)) +(defun set-flow-horizontal (disp item) + (declare (ignorable disp item)) (let* ((layout (gfw:layout-of *layout-tester-win*)) (style (gfw:style-of layout))) (setf style (remove :vertical style)) @@ -222,8 +219,8 @@ (setf (gfw:style-of layout) style) (gfw:layout *layout-tester-win*))) -(defun set-flow-vertical (disp item rect) - (declare (ignorable disp item rect)) +(defun set-flow-vertical (disp item) + (declare (ignorable disp item)) (let* ((layout (gfw:layout-of *layout-tester-win*)) (style (gfw:style-of layout))) (setf style (remove :horizontal style)) @@ -231,8 +228,8 @@ (setf (gfw:style-of layout) style) (gfw:layout *layout-tester-win*))) -(defun set-flow-layout-normalize (disp item rect) - (declare (ignorable disp item rect)) +(defun set-flow-layout-normalize (disp item) + (declare (ignorable disp item)) (let* ((layout (gfw:layout-of *layout-tester-win*)) (style (gfw:style-of layout))) (if (find :normalize style) @@ -240,8 +237,8 @@ (setf (gfw:style-of layout) (push :normalize style))) (gfw:layout *layout-tester-win*))) -(defun set-flow-layout-wrap (disp item rect) - (declare (ignorable disp item rect)) +(defun set-flow-layout-wrap (disp item) + (declare (ignorable disp item)) (let* ((layout (gfw:layout-of *layout-tester-win*)) (style (gfw:style-of layout))) (if (find :wrap style) @@ -254,8 +251,8 @@ (let ((spacing (gfw:spacing-of (gfw:layout-of *layout-tester-win*)))) (gfw:enable (elt (gfw:items menu) 0) (> spacing 0)))) -(defun decrease-flow-spacing (disp item rect) - (declare (ignore disp item rect)) +(defun decrease-flow-spacing (disp item) + (declare (ignore disp item)) (let* ((layout (gfw:layout-of *layout-tester-win*)) (spacing (gfw:spacing-of layout))) (unless (zerop spacing) @@ -263,76 +260,76 @@ (setf (gfw:spacing-of layout) spacing) (gfw:layout *layout-tester-win*)))) -(defun increase-flow-spacing (disp item rect) - (declare (ignore disp item rect)) +(defun increase-flow-spacing (disp item) + (declare (ignore disp item)) (let ((layout (gfw:layout-of *layout-tester-win*))) (incf (gfw:spacing-of layout) +spacing-delta+) (gfw:layout *layout-tester-win*))) -(defun enable-left-flow-margin-items (disp menu rect) - (declare (ignore disp rect)) +(defun enable-left-flow-margin-items (disp menu) + (declare (ignore disp)) (let ((layout (gfw:layout-of *layout-tester-win*))) (gfw:enable (elt (gfw:items menu) 0) (> (gfw:left-margin-of layout) 0)))) -(defun enable-top-flow-margin-items (disp menu rect) - (declare (ignore disp rect)) +(defun enable-top-flow-margin-items (disp menu) + (declare (ignore disp)) (let ((layout (gfw:layout-of *layout-tester-win*))) (gfw:enable (elt (gfw:items menu) 0) (> (gfw:top-margin-of layout) 0)))) -(defun enable-right-flow-margin-items (disp menu rect) - (declare (ignore disp rect)) +(defun enable-right-flow-margin-items (disp menu) + (declare (ignore disp)) (let ((layout (gfw:layout-of *layout-tester-win*))) (gfw:enable (elt (gfw:items menu) 0) (> (gfw:right-margin-of layout) 0)))) -(defun enable-bottom-flow-margin-items (disp menu rect) - (declare (ignore disp rect)) +(defun enable-bottom-flow-margin-items (disp menu) + (declare (ignore disp)) (let ((layout (gfw:layout-of *layout-tester-win*))) (gfw:enable (elt (gfw:items menu) 0) (> (gfw:bottom-margin-of layout) 0)))) -(defun inc-left-flow-margin (disp item rect) - (declare (ignore disp item rect)) +(defun inc-left-flow-margin (disp item) + (declare (ignore disp item)) (let ((layout (gfw:layout-of *layout-tester-win*))) (incf (gfw:left-margin-of layout) +margin-delta+) (gfw:layout *layout-tester-win*))) -(defun inc-top-flow-margin (disp item rect) - (declare (ignore disp item rect)) +(defun inc-top-flow-margin (disp item) + (declare (ignore disp item)) (let ((layout (gfw:layout-of *layout-tester-win*))) (incf (gfw:top-margin-of layout) +margin-delta+) (gfw:layout *layout-tester-win*))) -(defun inc-right-flow-margin (disp item rect) - (declare (ignore disp item rect)) +(defun inc-right-flow-margin (disp item) + (declare (ignore disp item)) (let ((layout (gfw:layout-of *layout-tester-win*))) (incf (gfw:right-margin-of layout) +margin-delta+) (gfw:layout *layout-tester-win*))) -(defun inc-bottom-flow-margin (disp item rect) - (declare (ignore disp item rect)) +(defun inc-bottom-flow-margin (disp item) + (declare (ignore disp item)) (let ((layout (gfw:layout-of *layout-tester-win*))) (incf (gfw:bottom-margin-of layout) +margin-delta+) (gfw:layout *layout-tester-win*))) -(defun dec-left-flow-margin (disp item rect) - (declare (ignore disp item rect)) +(defun dec-left-flow-margin (disp item) + (declare (ignore disp item)) (let ((layout (gfw:layout-of *layout-tester-win*))) (decf (gfw:left-margin-of layout) +margin-delta+) (gfw:layout *layout-tester-win*))) -(defun dec-top-flow-margin (disp item rect) - (declare (ignore disp item rect)) +(defun dec-top-flow-margin (disp item) + (declare (ignore disp item)) (let ((layout (gfw:layout-of *layout-tester-win*))) (decf (gfw:top-margin-of layout) +margin-delta+) (gfw:layout *layout-tester-win*))) -(defun dec-right-flow-margin (disp item rect) - (declare (ignore disp item rect)) +(defun dec-right-flow-margin (disp item) + (declare (ignore disp item)) (let ((layout (gfw:layout-of *layout-tester-win*))) (decf (gfw:right-margin-of layout) +margin-delta+) (gfw:layout *layout-tester-win*))) -(defun dec-bottom-flow-margin (disp item rect) - (declare (ignore disp item rect)) +(defun dec-bottom-flow-margin (disp item) + (declare (ignore disp item)) (let ((layout (gfw:layout-of *layout-tester-win*))) (decf (gfw:bottom-margin-of layout) +margin-delta+) (gfw:layout *layout-tester-win*))) @@ -382,8 +379,8 @@ (setf it (gfw:append-item menu "Wrap" nil #'set-flow-layout-wrap)) (gfw:check it (find :wrap style))))) -(defun exit-layout-callback (disp item rect) - (declare (ignorable disp item rect)) +(defun exit-layout-callback (disp item) + (declare (ignorable disp item)) (exit-layout-tester)) (defun run-layout-tester-internal () Modified: trunk/src/tests/uitoolkit/windlg.lisp ============================================================================== --- trunk/src/tests/uitoolkit/windlg.lisp (original) +++ trunk/src/tests/uitoolkit/windlg.lisp Sun Jul 9 12:03:27 2006 @@ -37,15 +37,15 @@ (defclass main-win-events (gfw:event-dispatcher) ()) -(defun windlg-exit-fn (disp item rect) - (declare (ignore disp item rect)) +(defun windlg-exit-fn (disp item) + (declare (ignore disp item)) (gfs:dispose *main-win*) (setf *main-win* nil) (gfw:shutdown 0)) (defmethod gfw:event-close ((self main-win-events) window) (declare (ignore window)) - (windlg-exit-fn self nil nil)) + (windlg-exit-fn self nil)) (defclass test-win-events (gfw:event-dispatcher) ()) @@ -66,8 +66,8 @@ (declare (ignore point button)) (gfs:dispose window)) -(defun create-borderless-win (disp item rect) - (declare (ignore disp item rect)) +(defun create-borderless-win (disp item) + (declare (ignore disp item)) (let ((window (make-instance 'gfw:top-level :dispatcher (make-instance 'test-borderless-events) :owner *main-win* :style '(:borderless)))) @@ -75,8 +75,8 @@ (gfw:center-on-owner window) (gfw:show window t))) -(defun create-miniframe-win (disp item rect) - (declare (ignore disp item rect)) +(defun create-miniframe-win (disp item) + (declare (ignore disp item)) (let ((window (make-instance 'gfw:top-level :dispatcher (make-instance 'test-mini-events) :owner *main-win* :text "Mini Frame" @@ -85,8 +85,8 @@ (setf (gfw:size window) (gfs:make-size :width 150 :height 225)) (gfw:show window t))) -(defun create-palette-win (disp item rect) - (declare (ignore disp item rect)) +(defun create-palette-win (disp item) + (declare (ignore disp item)) (let ((window (make-instance 'gfw:top-level :dispatcher (make-instance 'test-mini-events) :owner *main-win* :text "Palette" @@ -95,8 +95,8 @@ (setf (gfw:size window) (gfs:make-size :width 150 :height 225)) (gfw:show window t))) -(defun open-file-dlg (disp item rect) - (declare (ignore disp item rect)) +(defun open-file-dlg (disp item) + (declare (ignore disp item)) (gfw:with-file-dialog (*main-win* '(:open :add-to-recent :multiple-select) paths @@ -107,8 +107,8 @@ :text "Select Lisp-related files...") (print paths))) -(defun save-file-dlg (disp item rect) - (declare (ignore disp item rect)) +(defun save-file-dlg (disp item) + (declare (ignore disp item)) (gfw:with-file-dialog (*main-win* '(:save) paths @@ -117,8 +117,8 @@ :initial-directory #P"c:/") (print paths))) -(defun choose-font-dlg (disp item rect) - (declare (ignore disp item rect)) +(defun choose-font-dlg (disp item) + (declare (ignore disp item)) (gfw:with-graphics-context (gc *main-win*) (gfw:with-font-dialog (*main-win* nil font color :gc gc) (if color @@ -198,15 +198,15 @@ :style '(:vertical :normalize)) :parent dlg)) (ok-btn (make-instance 'gfw:button - :callback (lambda (disp btn rect) - (declare (ignore disp btn rect)) + :callback (lambda (disp btn) + (declare (ignore disp btn)) (gfs:dispose dlg)) :style '(:default-button) :text "OK" :parent btn-panel)) (cancel-btn (make-instance 'gfw:button - :callback (lambda (disp btn rect) - (declare (ignore disp btn rect)) + :callback (lambda (disp btn) + (declare (ignore disp btn)) (gfs:dispose dlg)) :style '(:cancel-button) :text "Cancel" @@ -220,12 +220,12 @@ (gfw:show dlg t) dlg)) -(defun open-modal-dlg (disp item rect) - (declare (ignore disp item rect)) +(defun open-modal-dlg (disp item) + (declare (ignore disp item)) (open-dlg "Modal" '(:owner-modal))) -(defun open-modeless-dlg (disp item rect) - (declare (ignore disp item rect)) +(defun open-modeless-dlg (disp item) + (declare (ignore disp item)) (open-dlg "Modeless" '(:modeless))) (defun run-windlg-internal () Modified: trunk/src/uitoolkit/widgets/event-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/event-generics.lisp Sun Jul 9 12:03:27 2006 @@ -48,10 +48,10 @@ (:method (dispatcher widget) (declare (ignorable dispatcher widget)))) -(defgeneric event-collapse (dispatcher item rect) +(defgeneric event-collapse (dispatcher item) (:documentation "Implement this to respond to an object (or item within) being collapsed.") - (:method (dispatcher item rect) - (declare (ignorable dispatcher item rect)))) + (:method (dispatcher item) + (declare (ignorable dispatcher item)))) (defgeneric event-deactivate (dispatcher widget) (:documentation "Implement this to respond to an object being deactivated.") @@ -68,10 +68,10 @@ (:method (dispatcher widget) (declare (ignorable dispatcher widget)))) -(defgeneric event-expand (dispatcher item rect) +(defgeneric event-expand (dispatcher item) (:documentation "Implement this to respond to an object (or item within) being expanded.") - (:method (dispatcher item rect) - (declare (ignorable dispatcher item rect)))) + (:method (dispatcher item) + (declare (ignorable dispatcher item)))) (defgeneric event-focus-gain (dispatcher widget) (:documentation "Implement this to respond to an object gaining keyboard focus.") @@ -173,10 +173,10 @@ (:method (dispatcher widget size type) (declare (ignorable dispatcher widget size type)))) -(defgeneric event-select (dispatcher item rect) +(defgeneric event-select (dispatcher item) (:documentation "Implement this to respond to an object (or item within) being selected.") - (:method (dispatcher item rect) - (declare (ignorable dispatcher item rect)))) + (:method (dispatcher item) + (declare (ignorable dispatcher item)))) (defgeneric event-show (dispatcher widget) (:documentation "Implement this to respond to an object being shown.") Modified: trunk/src/uitoolkit/widgets/event-source.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event-source.lisp (original) +++ trunk/src/uitoolkit/widgets/event-source.lisp Sun Jul 9 12:03:27 2006 @@ -35,7 +35,7 @@ (defconstant +callback-info+ '((gfw:event-activate . (gfw:event-source)) (gfw:event-arm . (gfw:event-source)) - (gfw:event-select . (gfw:event-source gfs:rectangle)))) + (gfw:event-select . (gfw:event-source)))) (defun make-specializer-list (disp-class arg-info) (let ((tmp (mapcar #'find-class arg-info))) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Sun Jul 9 12:03:27 2006 @@ -120,7 +120,7 @@ (defun dispatch-notification (widget wparam-hi) (let ((disp (dispatcher widget))) (case wparam-hi - (0 (event-select disp widget (gfs:make-rectangle))) ; FIXME + (0 (event-select disp widget)) (#.gfs::+en-killfocus+ (event-focus-loss disp widget)) (#.gfs::+en-setfocus+ (event-focus-gain disp widget)) (#.gfs::+en-update+ (event-modify disp widget))))) @@ -172,7 +172,7 @@ (if (null item) (warn 'gfs:toolkit-warning :detail (format nil "no menu item for id ~x" wparam-lo)) (unless (null (dispatcher item)) - (event-select (dispatcher item) item (gfs:make-rectangle)))))) ; FIXME + (event-select (dispatcher item) item))))) ((eq wparam-hi 1) (format t "accelerator wparam: ~x lparam: ~x~%" wparam lparam)) ; FIXME: debug (t

1 0

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

09 Jul '06

Author: junrue Date: Sun Jul 9 11:30:38 2006 New Revision: 187 Modified: trunk/docs/manual/api.texinfo trunk/src/demos/textedit/textedit-window.lisp trunk/src/tests/uitoolkit/drawing-tester.lisp trunk/src/tests/uitoolkit/event-tester.lisp trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/uitoolkit/widgets/control.lisp trunk/src/uitoolkit/widgets/event-generics.lisp trunk/src/uitoolkit/widgets/event-source.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/window.lisp Log: completed event-activate and added event-deactivate Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Sun Jul 9 11:30:38 2006 @@ -836,8 +836,9 @@ This chapter documents two types of functions: @itemize @bullet -@item generic functions implemented in order to handle system events -@item functions provided to help implement application message pumps +@item generic functions whose methods are to be implemented by application +code in order to handle system events +@item functions provided to help implement message loops @end itemize @anchor{default-message-filter} @@ -861,29 +862,19 @@ @end table @end defun -@deffn GenericFunction event-activate dispatcher widget type +@anchor{event-activate} +@deffn GenericFunction event-activate dispatcher widget Implement this method to respond to @var{widget} being activated. For a @ref{top-level} @ref{window} or @ref{dialog}, this means that @var{widget} was brought to the foreground and its trim (titlebar and border) was highlighted to indicate that it is now the active window. For a @ref{menu}, it means that the user has clicked on the @ref{item} invoking @ref{widget} and it is about to be shown; this is -an opportunity to update the menu's contents. +an opportunity to update the menu's contents. @xref{event-deactivate}. @table @var @event-dispatcher-arg @item widget The menu, dialog, or window that has been activated. -@item type -Provides a hint as to how activation occurred, via one of the following -keywords: -@table @code -@item :click -Indicates that @var{widget} was activated as the result of a mouse click. -@item :programmatic -Indicates that @var{widget} was activated as the result of the keyboard -interface to select a window, or programmatically via a call to -@sc{activate}. -@end table @end table @end deffn @@ -910,6 +901,19 @@ @end table @end deffn +@anchor{event-deactivate} +@deffn GenericFunction event-deactivate dispatcher widget +Implement this method to respond to @var{widget} being deactivated, +meaning that some other object has been made active. This event only +applies to @ref{top-level} @ref{window}s or +@ref{dialog}s. @xref{event-activate}. +@table @var +@event-dispatcher-arg +@item widget +The dialog or window that has been deactivated. +@end table +@end deffn + @deffn GenericFunction event-dispose dispatcher widget Implement this method to respond to @var{widget} being disposed (explicitly via @ref{dispose}, not collected via the garbage collector). This @@ -1089,7 +1093,7 @@ @item widget The @ref{widget} (or item) that was selected. @item rect -The @ref{rectangle} bounding @var{widget}. +The @ref{rectangle} bounding the selection inside @var{widget}. @end table @end deffn @@ -1123,7 +1127,7 @@ @anchor{obtain-event-time} @defun obtain-event-time => milliseconds Returns the timestamp for the event currently being processed, or -zero if called prior to the delivery of any events. +zero if called prior to delivery of any events. @end defun Modified: trunk/src/demos/textedit/textedit-window.lisp ============================================================================== --- trunk/src/demos/textedit/textedit-window.lisp (original) +++ trunk/src/demos/textedit/textedit-window.lisp Sun Jul 9 11:30:38 2006 @@ -40,8 +40,8 @@ (defvar *textedit-file-filters* '(("Text Files (*.txt)" . "*.txt") ("All Files (*.*)" . "*.*"))) -(defun manage-textedit-file-menu (disp menu type) - (declare (ignore disp type)) +(defun manage-textedit-file-menu (disp menu) + (declare (ignore disp)) (gfw:enable (elt (gfw:items menu) 2) (gfw:text-modified-p *textedit-control*))) (defun textedit-file-new (disp item rect) @@ -95,15 +95,15 @@ (defclass textedit-win-events (gfw:event-dispatcher) ()) -(defmethod gfw:event-close ((disp textedit-win-events) window) - (declare (ignore window)) - (textedit-file-quit disp nil nil)) - -(defmethod gfw:event-focus-gain ((self textedit-win-events) window) +(defmethod gfw:event-activate ((self textedit-win-events) window) (declare (ignore window)) (if *textedit-control* (gfw:give-focus *textedit-control*))) +(defmethod gfw:event-close ((disp textedit-win-events) window) + (declare (ignore window)) + (textedit-file-quit disp nil nil)) + (defclass textedit-about-dialog-events (gfw:event-dispatcher) ()) (defmethod gfw:event-close ((disp textedit-about-dialog-events) (dlg gfw:dialog)) Modified: trunk/src/tests/uitoolkit/drawing-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/drawing-tester.lisp (original) +++ trunk/src/tests/uitoolkit/drawing-tester.lisp Sun Jul 9 11:30:38 2006 @@ -42,8 +42,8 @@ (gfw:check *last-checked-drawing-item* nil)) (gfw:check item t)) -(defun find-checked-item (disp menu type) - (declare (ignore disp type)) +(defun find-checked-item (disp menu) + (declare (ignore disp)) (dotimes (i (length (gfw:items menu))) (let ((item (elt (gfw:items menu) i))) (when (gfw:checked-p item) Modified: trunk/src/tests/uitoolkit/event-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/event-tester.lisp (original) +++ trunk/src/tests/uitoolkit/event-tester.lisp Sun Jul 9 11:30:38 2006 @@ -72,6 +72,14 @@ (not (gfw:key-toggled-p gfw:+vk-num-lock+)) (not (gfw:key-toggled-p gfw:+vk-scroll-lock+)))) +(defun text-for-activation (action) + (format nil + "~a action: ~s time: 0x~x ~s" + (incf *event-counter*) + action + (gfw:obtain-event-time) + (text-for-modifiers))) + (defun text-for-mouse (action button pnt) (format nil "~a mouse action: ~s button: ~a point: (~d,~d) time: 0x~x ~s" @@ -128,7 +136,15 @@ (gfw:id-of *timer*) (gfw:obtain-event-time) (text-for-modifiers))) - + +(defmethod gfw:event-activate ((d event-tester-window-events) window) + (setf *event-tester-text* (text-for-activation "window activated")) + (gfw:redraw window)) + +(defmethod gfw:event-deactivate ((d event-tester-window-events) window) + (setf *event-tester-text* (text-for-activation "window deactivated")) + (gfw:redraw window)) + (defmethod gfw:event-key-down ((d event-tester-window-events) window key-code char) (setf *event-tester-text* (text-for-key "down" key-code char)) (gfw:redraw window)) @@ -187,8 +203,7 @@ (setf *event-tester-text* (text-for-item (gfw:text item) "item armed")) (gfw:redraw *event-tester-window*)) -(defmethod gfw:event-activate ((d event-tester-echo-dispatcher) widget type) - (declare (ignore type)) +(defmethod gfw:event-activate ((d event-tester-echo-dispatcher) widget) (setf *event-tester-text* (text-for-item (format nil "~a" widget) "menu activated")) (gfw:redraw *event-tester-window*)) @@ -197,8 +212,8 @@ (setf *event-tester-text* (text-for-timer)) (gfw:redraw *event-tester-window*)) -(defun manage-file-menu (disp menu type) - (declare (ignore disp type)) +(defun manage-file-menu (disp menu) + (declare (ignore disp)) (let ((item (elt (gfw:items menu) 0))) (setf (gfw:text item) (if *timer* "Sto&p Timer" "&Start Timer")))) Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Sun Jul 9 11:30:38 2006 @@ -169,8 +169,7 @@ :initarg :sub-disp-class :initform nil))) -(defmethod gfw:event-activate ((d child-menu-dispatcher) menu type) - (declare (ignore type)) +(defmethod gfw:event-activate ((d child-menu-dispatcher) menu) (gfw:clear-all menu) (gfw:mapchildren *layout-tester-win* (lambda (parent child) @@ -208,8 +207,8 @@ (gfw:show victim (not (gfw:visible-p victim))) (gfw:layout *layout-tester-win*)))) -(defun check-flow-orient-items (disp menu type) - (declare (ignore disp type)) +(defun check-flow-orient-items (disp menu) + (declare (ignore disp)) (let ((layout (gfw:layout-of *layout-tester-win*))) (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))))) @@ -250,8 +249,8 @@ (setf (gfw:style-of layout) (push :wrap style))) (gfw:layout *layout-tester-win*))) -(defun enable-flow-spacing-items (disp menu type) - (declare (ignore disp type)) +(defun enable-flow-spacing-items (disp menu) + (declare (ignore disp)) (let ((spacing (gfw:spacing-of (gfw:layout-of *layout-tester-win*)))) (gfw:enable (elt (gfw:items menu) 0) (> spacing 0)))) @@ -338,8 +337,8 @@ (decf (gfw:bottom-margin-of layout) +margin-delta+) (gfw:layout *layout-tester-win*))) -(defun flow-mod-callback (disp menu type) - (declare (ignore disp type)) +(defun flow-mod-callback (disp menu) + (declare (ignore disp)) (gfw:clear-all menu) (let ((it nil) (margin-menu (gfw:defmenu ((:item "Left" Modified: trunk/src/uitoolkit/widgets/control.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/control.lisp (original) +++ trunk/src/uitoolkit/widgets/control.lisp Sun Jul 9 11:30:38 2006 @@ -146,8 +146,7 @@ (error 'gfs:disposed-error))) (defmethod give-focus ((self control)) - (if (gfs:null-handle-p (gfs::set-focus (gfs:handle self))) - (error 'gfs:win32-error :detail "set-focus failed"))) + (gfs::set-focus (gfs:handle self))) (defmethod initialize-instance :after ((self control) &key callback callbacks disp parent &allow-other-keys) (if (gfs:disposed-p parent) Modified: trunk/src/uitoolkit/widgets/event-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/event-generics.lisp Sun Jul 9 11:30:38 2006 @@ -33,10 +33,10 @@ (in-package :graphic-forms.uitoolkit.widgets) -(defgeneric event-activate (dispatcher widget type) +(defgeneric event-activate (dispatcher widget) (:documentation "Implement this to respond to an object being activated.") - (:method (dispatcher widget type) - (declare (ignorable dispatcher widget type)))) + (:method (dispatcher widget) + (declare (ignorable dispatcher widget)))) (defgeneric event-arm (dispatcher item) (:documentation "Implement this to respond to an object about to be selected.") @@ -53,10 +53,10 @@ (:method (dispatcher item rect) (declare (ignorable dispatcher item rect)))) -(defgeneric event-deactivate (dispatcher widget type) +(defgeneric event-deactivate (dispatcher widget) (:documentation "Implement this to respond to an object being deactivated.") - (:method (dispatcher widget type) - (declare (ignorable dispatcher widget type)))) + (:method (dispatcher widget) + (declare (ignorable dispatcher widget)))) (defgeneric event-deiconify (dispatcher widget) (:documentation "Implement this to respond to an object being deiconified.") Modified: trunk/src/uitoolkit/widgets/event-source.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event-source.lisp (original) +++ trunk/src/uitoolkit/widgets/event-source.lisp Sun Jul 9 11:30:38 2006 @@ -33,7 +33,7 @@ (in-package :graphic-forms.uitoolkit.widgets) -(defconstant +callback-info+ '((gfw:event-activate . (gfw:event-source symbol)) +(defconstant +callback-info+ '((gfw:event-activate . (gfw:event-source)) (gfw:event-arm . (gfw:event-source)) (gfw:event-select . (gfw:event-source gfs:rectangle)))) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Sun Jul 9 11:30:38 2006 @@ -190,7 +190,7 @@ (unless (null menu) (let ((d (dispatcher menu))) (unless (null d) - (event-activate d menu :click))))) ; FIXME: menus can be invoked programmatically, too + (event-activate d menu))))) 0) (defmethod process-message (hwnd (msg (eql gfs::+wm-menuselect+)) wparam lparam) @@ -349,18 +349,26 @@ (declare (ignore wparam)) (process-mouse-message #'event-mouse-up hwnd lparam :right-button)) +(defmethod process-message (hwnd (msg (eql gfs::+wm-activate+)) wparam lparam) + (declare (ignore lparam)) + (let ((widget (get-widget (thread-context) hwnd))) + (if widget + (ecase wparam + (#.gfs::+wa-active+ (event-activate (dispatcher widget) widget)) + (#.gfs::+wa-clickactive+ (event-activate (dispatcher widget) widget)) + (#.gfs::+wa-inactive+ (event-deactivate (dispatcher widget) widget))))) + 0) + (defmethod process-message (hwnd (msg (eql gfs::+wm-killfocus+)) wparam lparam) (declare (ignore wparam lparam)) - (let* ((tc (thread-context)) - (widget (get-widget tc hwnd))) + (let ((widget (get-widget (thread-context) hwnd))) (if widget (event-focus-loss (dispatcher widget) widget))) 0) (defmethod process-message (hwnd (msg (eql gfs::+wm-setfocus+)) wparam lparam) (declare (ignore wparam lparam)) - (let* ((tc (thread-context)) - (widget (get-widget tc hwnd))) + (let ((widget (get-widget (thread-context) hwnd))) (if widget (event-focus-gain (dispatcher widget) widget))) 0) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Sun Jul 9 11:30:38 2006 @@ -199,8 +199,7 @@ (error 'gfs:disposed-error))) (defmethod give-focus ((win window)) - (if (gfs:null-handle-p (gfs::set-focus (gfs:handle win))) - (error 'gfs:win32-error :detail "set-focus failed"))) + (gfs::set-focus (gfs:handle win))) (defmethod location ((win window)) (if (gfs:disposed-p win)

1 0