[graphic-forms-cvs] r179 - in trunk: docs/manual src src/demos/textedit src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Thu Jul 6 16:19:39 UTC 2006
Author: junrue
Date: Thu Jul 6 12:19:37 2006
New Revision: 179
Modified:
trunk/docs/manual/api.texinfo
trunk/docs/manual/glossary.texinfo
trunk/src/demos/textedit/textedit-window.lisp
trunk/src/packages.lisp
trunk/src/uitoolkit/widgets/edit.lisp
trunk/src/uitoolkit/widgets/top-level.lisp
trunk/src/uitoolkit/widgets/widget-generics.lisp
trunk/src/uitoolkit/widgets/widget-utils.lisp
trunk/src/uitoolkit/widgets/widget.lisp
Log:
defined new generic functions for configuring auto-scrolling and scrollbars; refactored existing code that modifies native styles to use a centralized function to set the bits and then refresh the hwnd
Modified: trunk/docs/manual/api.texinfo
==============================================================================
--- trunk/docs/manual/api.texinfo (original)
+++ trunk/docs/manual/api.texinfo Thu Jul 6 12:19:37 2006
@@ -294,11 +294,14 @@
Specifies that the @code{edit control} will scroll text content to the
right by 10 characters when the user types a character at the end
of the line. For single-line @code{edit control}s, this style is set
-by the library.
+by the library. See @ref{auto-hscroll-p}, @ref{auto-vscroll-p}, and
+ at ref{enable-auto-scrolling}.
@item :auto-vscroll
Specifies that the @code{edit control} will scroll text up by a page
when the user types @sc{enter} on the last line. This style keyword
-is only meaningful when @code{:multi-line} is also specified.
+is only meaningful when @code{:multi-line} is also specified. See
+ at ref{auto-hscroll-p}, @ref{auto-vscroll-p}, and
+ at ref{enable-auto-scrolling}.
@item :horizontal-scrollbar
Specifies that a horizontal scrollbar should be displayed.
@item :mask-characters
@@ -964,6 +967,18 @@
be used to set the menu item's initial state.
@end deffn
+ at anchor{auto-hscroll-p}
+ at deffn GenericFunction auto-hscroll-p self => boolean
+Returns T if @code{self} is configured for automatic horizontal scrolling;
+ at sc{nil} otherwise. See @ref{auto-vscroll-p} and @ref{enable-auto-scrolling}.
+ at end deffn
+
+ at anchor{auto-vscroll-p}
+ at deffn GenericFunction auto-vscroll-p self => boolean
+Returns T if @code{self} is configured for automatic vertical scrolling;
+ at sc{nil} otherwise. See @ref{auto-hscroll-p} and @ref{enable-auto-scrolling}.
+ at end deffn
+
@deffn GenericFunction cancel-widget self
Returns the @ref{widget} that responds to the @sc{esc} key or
otherwise acts to cancel the @ref{owner}. In a @ref{dialog}, this
@@ -1055,6 +1070,13 @@
function is also used to start and stop @ref{timer}s.
@end deffn
+ at anchor{enable-auto-scrolling}
+ at deffn GenericFunction enable-auto-scrolling self horizontal vertical
+Configures the object to allow (or to disable) automatic scrolling in
+the horizontal or vertical directions. See @ref{auto-hscroll-p}
+and @ref{auto-vscroll-p}.
+ at end deffn
+
@deffn GenericFunction enable-layout self flag
Cause the object to allow or disallow layout management.
@end deffn
@@ -1063,6 +1085,16 @@
Returns @sc{t} if @code{self} is enabled; @sc{nil} otherwise.
@end deffn
+ at anchor{enable-scrollbars}
+ at deffn GenericFunction enable-scrollbars self horizontal vertical
+Specifying T for @code{horizontal} (@code{vertical}) reveals a
+scrollbar to attached to the right-hand (bottom) of
+ at code{self}. Specifying @sc{nil} hides the scrollbar. These flags do
+not affect scrolling behavior in @code{self} -- they only control
+scrollbar visibility. See @ref{horizontal-scrollbar-p} and
+ at ref{vertical-scrollbar-p}.
+ at end deffn
+
@anchor{file-dialog-paths}
@deffn Function file-dialog-paths dlg => @sc{list}
Interrogates the data structure associated with an instance of
@@ -1094,6 +1126,12 @@
Places keyboard focus on @code{self}.
@end deffn
+ at anchor{horizontal-scrollbar-p}
+ at deffn GenericFunction horizontal-scrollbar-p self => boolean
+Returns T if @code{self} has been configured to display a horizontal
+scrollbar; @sc{nil} otherwise. @xref{enable-scrollbars}.
+ at end deffn
+
@deffn GenericFunction item-index self item
Return the zero-based index of the location of the other object in this object.
@end deffn
@@ -1283,6 +1321,12 @@
before this function returns.
@end deffn
+ at anchor{vertical-scrollbar-p}
+ at deffn GenericFunction vertical-scrollbar-p self => boolean
+Returns T if @code{self} has been configured to display a vertical
+scrollbar; @sc{nil} otherwise. @xref{enable-scrollbars}.
+ at end deffn
+
@deffn GenericFunction visible-p self
Returns T if the object is visible (not necessarily top-most); nil otherwise.
@end deffn
Modified: trunk/docs/manual/glossary.texinfo
==============================================================================
--- trunk/docs/manual/glossary.texinfo (original)
+++ trunk/docs/manual/glossary.texinfo Thu Jul 6 12:19:37 2006
@@ -26,6 +26,13 @@
intended for more knowledgeable users and should not be the sole
mechanism for invoking functionality. Compare with @ref{mnemonic}.
+ at item auto-scrolling
+ at cindex auto-scrolling
+Auto-scrolling is a feature whereby scrolling occurs
+as a side effect of user input so content can remain visible,
+thus avoiding the need to explicitly manipulate scrollbars to
+achieve the same result.
+
@item control
@cindex control
A control is a system-defined window class that accepts user input
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 6 12:19:37 2006
@@ -49,6 +49,18 @@
(setf *textedit-win* nil)
(gfw:shutdown 0))
+(defun format-textedit (disp menu time)
+ (declare (ignore disp time))
+ (gfw:check (elt (gfw:items menu) 1)
+ (and *textedit-control* (gfw:auto-hscroll-p *textedit-control*))))
+
+(defun wordwrap-textedit (disp item time rect)
+ (declare (ignore disp item time rect))
+ (when *textedit-control*
+ (let ((flag (not (gfw:auto-hscroll-p *textedit-control*))))
+ ;(gfw:enable-auto-scrolling *textedit-control* flag t)
+ (gfw:enable-scrollbars *textedit-control* flag t))))
+
(defclass textedit-win-events (gfw:event-dispatcher) ())
(defmethod gfw:event-close ((disp textedit-win-events) window time)
@@ -150,9 +162,9 @@
(:item "&Go To...")
(:item "" :separator)
(:item "Select &All")))
- (:item "F&ormat"
+ (:item "F&ormat" :callback #'format-textedit
:submenu ((:item "&Font...")
- (:item "&Word Wrap")))
+ (:item "&Word Wrap" :callback #'wordwrap-textedit)))
(:item "&Help"
:submenu ((:item "&About TextEdit" :callback #'about-textedit)))))))
(setf *textedit-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'textedit-win-events)
Modified: trunk/src/packages.lisp
==============================================================================
--- trunk/src/packages.lisp (original)
+++ trunk/src/packages.lisp Thu Jul 6 12:19:37 2006
@@ -317,6 +317,8 @@
#:append-item
#:append-separator
#:append-submenu
+ #:auto-hscroll-p
+ #:auto-vscroll-p
#:background-color
#:background-pattern
#:border-width
@@ -355,8 +357,10 @@
#:display-to-object
#:echo-char
#:enable
+ #:enable-auto-scrolling
#:enable-layout
#:enable-redraw
+ #:enable-scrollbars
#:enabled-p
#:event-activate
#:event-arm
Modified: trunk/src/uitoolkit/widgets/edit.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/edit.lisp (original)
+++ trunk/src/uitoolkit/widgets/edit.lisp Thu Jul 6 12:19:37 2006
@@ -40,6 +40,14 @@
;;; methods
;;;
+(defmethod auto-hscroll-p ((self edit))
+ (let ((bits (gfs::get-window-long (gfs:handle self) gfs::+gwl-style+)))
+ (= (logand bits gfs::+es-autohscroll+) gfs::+es-autohscroll+)))
+
+(defmethod auto-vscroll-p ((self edit))
+ (let ((bits (gfs::get-window-long (gfs:handle self) gfs::+gwl-style+)))
+ (= (logand bits gfs::+es-autovscroll+) gfs::+es-autovscroll+)))
+
(defmethod compute-style-flags ((self edit) &rest extra-data)
(declare (ignore extra-data))
(let ((std-flags (logior +default-child-style+ gfs::+ws-tabstop+))
@@ -66,6 +74,20 @@
(setf std-flags (logior std-flags gfs::+es-autohscroll+)))
(values std-flags (if (find :no-border style) 0 gfs::+ws-ex-clientedge+))))
+(defmethod enable-auto-scrolling ((self edit) horizontal vertical)
+ (declare (ignore horizontal vertical))
+ (error 'gfs:toolkit-error :detail "not yet implemented"))
+
+(defmethod enable-scrollbars ((self edit) horizontal vertical)
+ (let ((bits (gfs::get-window-long (gfs:handle self) gfs::+gwl-style+)))
+ (if horizontal
+ (setf bits (logior bits gfs::+ws-hscroll+))
+ (setf bits (logand bits (lognot gfs::+ws-hscroll+))))
+ (if vertical
+ (setf bits (logior bits gfs::+ws-vscroll+))
+ (setf bits (logand bits (lognot gfs::+ws-vscroll+))))
+ (update-native-style self bits)))
+
(defmethod initialize-instance :after ((self edit) &key parent text &allow-other-keys)
(initialize-comctl-classes gfs::+icc-standard-classes+)
(multiple-value-bind (std-style ex-style)
Modified: trunk/src/uitoolkit/widgets/top-level.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/top-level.lisp (original)
+++ trunk/src/uitoolkit/widgets/top-level.lisp Thu Jul 6 12:19:37 2006
@@ -63,11 +63,7 @@
(setf new-flags (logior orig-flags gfs::+ws-maximizebox+))
(setf new-flags (logior new-flags gfs::+ws-thickframe+))))
(when (/= orig-flags new-flags)
- (gfs::set-window-long hwnd gfs::+gwl-style+ new-flags)
- (gfs::set-window-pos hwnd (cffi:null-pointer) 0 0 0 0 (logior gfs::+swp-framechanged+
- gfs::+swp-nomove+
- gfs::+swp-nosize+
- gfs::+swp-nozorder+)))))
+ (update-native-style win new-flags))))
;;;
;;; methods
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 6 12:19:37 2006
@@ -54,6 +54,12 @@
(defgeneric append-submenu (self text submenu dispatcher &optional checked disabled)
(:documentation "Adds a submenu anchored to a parent menu and returns the corresponding item."))
+(defgeneric auto-hscroll-p (self)
+ (:documentation "Returns T if automatic horizontal scrolling is enabled; nil otherwise."))
+
+(defgeneric auto-vscroll-p (self)
+ (:documentation "Returns T if automatic vertical scrolling is enabled; nil otherwise."))
+
(defgeneric border-width (self)
(:documentation "Returns the object's border width."))
@@ -135,6 +141,9 @@
(defgeneric enable (self flag)
(:documentation "Enables or disables the object, causing it to be redrawn with its default look and allows it to be selected."))
+(defgeneric enable-auto-scrolling (self horizontal vertical)
+ (:documentation "Enables or disables automatic scrolling in either dimension."))
+
(defgeneric enable-layout (self flag)
(:documentation "Cause the object to allow or disallow layout management."))
@@ -144,6 +153,9 @@
(defgeneric enabled-p (self)
(:documentation "Returns T if the object is enabled; nil otherwise."))
+(defgeneric enable-scrollbars (self horizontal vertical)
+ (:documentation "Shows or hides scrollbars for the widget in either dimension."))
+
(defgeneric expand (self deep flag)
(:documentation "Set the object (and optionally it's children) to the expanded or collapsed state."))
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 6 12:19:37 2006
@@ -116,6 +116,14 @@
(error 'gfs:comdlg-error :detail (format nil "~a failed" (symbol-name dlg-func))))
retval))
+(defun update-native-style (widget bits)
+ (let ((hwnd (gfs:handle widget)))
+ (gfs::set-window-long hwnd gfs::+gwl-style+ bits)
+ (gfs::set-window-pos hwnd (cffi:null-pointer) 0 0 0 0 (logior gfs::+swp-framechanged+
+ gfs::+swp-nomove+
+ gfs::+swp-nosize+
+ gfs::+swp-nozorder+))))
+
(defun get-widget-text (w)
(if (gfs:disposed-p w)
(error 'gfs:disposed-error))
Modified: trunk/src/uitoolkit/widgets/widget.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget.lisp Thu Jul 6 12:19:37 2006
@@ -79,12 +79,20 @@
(error 'gfs:toolkit-error :detail "no widget for parent handle"))
(ancestor-p ancestor parent)))
-(defmethod border-width :before ((widget widget))
- (if (gfs:disposed-p widget)
+(defmethod auto-hscroll-p :before ((self widget))
+ (if (gfs:disposed-p self)
+ (error 'gfs:disposed-error)))
+
+(defmethod auto-vscroll-p :before ((self widget))
+ (if (gfs:disposed-p self)
+ (error 'gfs:disposed-error)))
+
+(defmethod border-width :before ((self widget))
+ (if (gfs:disposed-p self)
(error 'gfs:disposed-error)))
-(defmethod border-width ((widget widget))
- (let* ((hwnd (gfs:handle widget))
+(defmethod border-width ((self widget))
+ (let* ((hwnd (gfs:handle self))
(bits (gfs::get-window-long hwnd gfs::+gwl-exstyle+)))
(cond
((/= (logand bits gfs::+ws-ex-clientedge+) 0)
@@ -152,13 +160,18 @@
(error 'gfs:win32-error :detail "destroy-window failed"))))
(setf (slot-value w 'gfs:handle) nil))
-(defmethod enable :before ((w widget) flag)
+(defmethod enable :before ((self widget) flag)
(declare (ignore flag))
- (if (gfs:disposed-p w)
+ (if (gfs:disposed-p self)
(error 'gfs:disposed-error)))
-(defmethod enable ((w widget) flag)
- (gfs::enable-window (gfs:handle w) (if (null flag) 0 1)))
+(defmethod enable ((self widget) flag)
+ (gfs::enable-window (gfs:handle self) (if (null flag) 0 1)))
+
+(defmethod enable-auto-scrolling :before ((self widget) hscroll vscroll)
+ (declare (ignore hscroll vscroll))
+ (if (gfs:disposed-p self)
+ (error 'gfs:disposed-error)))
(defmethod enabled-p :before ((w widget))
(if (gfs:disposed-p w)
More information about the Graphic-forms-cvs
mailing list