Author: junrue
Date: Fri Sep 22 20:37:13 2006
New Revision: 264
Added:
trunk/src/uitoolkit/widgets/scrollbar.lisp
trunk/src/uitoolkit/widgets/scrolling-event-dispatcher.lisp
Modified:
trunk/docs/manual/widget-functions.texinfo
trunk/docs/manual/widget-types.texinfo
trunk/graphic-forms-uitoolkit.asd
trunk/src/packages.lisp
trunk/src/tests/uitoolkit/scroll-grid-panel.lisp
trunk/src/tests/uitoolkit/scroll-tester.lisp
trunk/src/uitoolkit/widgets/widget-classes.lisp
trunk/src/uitoolkit/widgets/widget-generics.lisp
trunk/src/uitoolkit/widgets/window.lisp
Log:
implemented standard scrollbar abstraction
Modified: trunk/docs/manual/widget-functions.texinfo
==============================================================================
--- trunk/docs/manual/widget-functions.texinfo (original)
+++ trunk/docs/manual/widget-functions.texinfo Fri Sep 22 20:37:13 2006
@@ -388,27 +388,27 @@
@end defun
@anchor{obtain-horizontal-scrollbar}
-@deffn GenericFunction obtain-horizontal-scrollbar self => widget
-Returns a @ref{widget} representing the horizontal scrollbar attached
+@deffn GenericFunction obtain-horizontal-scrollbar self => @ref{standard-scrollbar}
+Returns an object representing the horizontal scrollbar attached
to the bottom of @var{self}, if @var{self} is configured to have one
and whether or not said scrollbar is currently visible; or returns
@sc{nil} if @var{self} is not configured to have a horizontal scrollbar.
Note that the widget returned by this function is not a @ref{control}
-instance; it is instead an abstract of what is referred to in the Microsoft
-documentation as a @emph{standard scrollbar}.
+instance; rather, it is an abstraction of what Microsoft's documentation
+refers to as a @emph{standard scrollbar}.
See also @ref{obtain-vertical-scrollbar} and @ref{horizontal-scrollbar-p}.
@end deffn
@anchor{obtain-vertical-scrollbar}
-@deffn GenericFunction obtain-vertical-scrollbar self => widget
-Returns a @ref{widget} representing the vertical scrollbar attached
+@deffn GenericFunction obtain-vertical-scrollbar self => @ref{standard-scrollbar}
+Returns an object representing the vertical scrollbar attached
to the right side of @var{self}, if @var{self} is configured to have one
and whether or not said scrollbar is currently visible; or returns
@sc{nil} if @var{self} is not configured to have a vertical scrollbar.
Note that the widget returned by this function is not a @ref{control}
-instance; it is instead an abstract of what is referred to in the Microsoft
-documentation as a @emph{standard scrollbar}.
+instance; rather, it is an abstraction of what Microsoft's documentation
+refers to as a @emph{standard scrollbar}.
See also @ref{obtain-horizontal-scrollbar} and @ref{vertical-scrollbar-p}.
@end deffn
Modified: trunk/docs/manual/widget-types.texinfo
==============================================================================
--- trunk/docs/manual/widget-types.texinfo (original)
+++ trunk/docs/manual/widget-types.texinfo Fri Sep 22 20:37:13 2006
@@ -142,6 +142,24 @@
A subclass of @ref{item} representing a @ref{menu} item.
@end deftp
+@anchor{standard-scrollbar}
+@deftp Class standard-scrollbar orientation step-increment
+This class encapsulates a @emph{standard scrollbar}, which
+is Microsoft's term for a scrollbar-like component attached to
+the right side or bottom of a window. This class is not meant
+to be instantiated by application code. See @ref{obtain-horizontal-scrollbar}
+and @ref{obtain-vertical-scrollbar}.
+@table @var
+@item orientation
+This slot holds an internal value identifying this object as
+either the horizontal or vertical scrollbar.
+@item step-increment
+This slot holds an integer value specifying how many pixels
+to move the viewport when the scrollbar is stepped forward
+or back.
+@end table
+@end deftp
+
@anchor{timer}
@deftp Class timer id initial-delay delay
A timer is a non-windowed object that generates events at a regular
Modified: trunk/graphic-forms-uitoolkit.asd
==============================================================================
--- trunk/graphic-forms-uitoolkit.asd (original)
+++ trunk/graphic-forms-uitoolkit.asd Fri Sep 22 20:37:13 2006
@@ -138,6 +138,8 @@
(:file "menu-item")
(:file "menu-language")
(:file "event")
+ (:file "scrolling-event-dispatcher")
+ (:file "scrollbar")
(:file "window")
(:file "root-window")
(:file "top-level")
Modified: trunk/src/packages.lisp
==============================================================================
--- trunk/src/packages.lisp (original)
+++ trunk/src/packages.lisp Fri Sep 22 20:37:13 2006
@@ -435,7 +435,7 @@
#:iconified-p
#:id-of
#:initial-delay-of
- #:horizontal-scrollbar
+ #:horizontal-policy-of
#:image
#:item-count
#:item-height
@@ -470,7 +470,9 @@
#:obtain-chosen-color
#:obtain-displays
#:obtain-event-time
+ #:obtain-horizontal-scrollbar
#:obtain-primary-display
+ #:obtain-vertical-scrollbar
#:owner
#:pack
#:page-increment
@@ -513,7 +515,9 @@
#:text-height
#:text-limit
#:text-modified-p
- #:thumb-size
+ #:thumb-limits
+ #:thumb-position
+ #:thumb-track-position
#:tooltip-text
#:top-child-of
#:top-index
@@ -523,7 +527,7 @@
#:trim-sizes
#:undo-available-p
#:update
- #:vertical-scrollbar
+ #:vertical-policy-of
#:visible-item-count
#:visible-p
#:with-color-dialog
Modified: trunk/src/tests/uitoolkit/scroll-grid-panel.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/scroll-grid-panel.lisp (original)
+++ trunk/src/tests/uitoolkit/scroll-grid-panel.lisp Fri Sep 22 20:37:13 2006
@@ -33,18 +33,70 @@
(in-package #:graphic-forms.uitoolkit.tests)
+(defconstant +grid-cell-extent+ 50)
+(defconstant +grid-half-extent+ 25)
+
+(defvar *grid-model-size* (gfs:make-size :width 25 :height 16)) ; grid cells
+
+(defvar *grid-char-size* (gfs:make-size))
+
(defclass scroll-grid-panel-events (gfw:event-dispatcher) ())
(defun make-scroll-grid-panel (parent)
- (let ((panel-size (gfs:make-size :width 1000 :height 800))
+ (let ((panel-size (gfs:make-size :width (* (gfs:size-width *grid-model-size*) +grid-cell-extent+)
+ :height (* (gfs:size-height *grid-model-size*) +grid-cell-extent+)))
(panel (make-instance 'gfw:panel :dispatcher (make-instance 'scroll-grid-panel-events)
:parent parent)))
(setf (gfw:maximum-size panel) panel-size)
(assert (gfs:equal-size-p panel-size (gfw::max-size-of panel)))
+#|
+ (let* ((gc (make-instance 'gfg:graphics-context :widget panel))
+ (font (make-instance 'gfg:font :gc gc)))
+ (unwind-protect
+ (let ((metrics (gfg:metrics gc font)))
+ (setf (gfs:size-width *grid-char-size*) (gfg:maximum-char-width metrics)
+ (gfs:size-height *grid-char-size*) (+ (gfg:ascent metrics)
+ (gfg:descent metrics))))
+ (gfs:dispose font)
+ (gfs:dispose gc)))
+|#
+ (setf (gfs:size-width *grid-char-size*) (floor +grid-half-extent+ 2)
+ (gfs:size-height *grid-char-size*) (floor +grid-half-extent+ 2))
panel))
(defmethod gfw:event-paint ((disp scroll-grid-panel-events) window gc rect)
+ (declare (ignore window))
(let ((color (gfg:rgb->color (gfs::get-sys-color gfs::+color-btnface+))))
(setf (gfg:background-color gc) color
(gfg:foreground-color gc) color))
- (gfg:draw-filled-rectangle gc rect))
+ (gfg:draw-filled-rectangle gc rect)
+ (setf (gfg:foreground-color gc) gfg:*color-black*
+ (gfg:pen-style gc) '(:solid :flat-endcap)
+ (gfg:pen-width gc) 2)
+ (let* ((pnt (gfs:location rect))
+ (size (gfs:size rect))
+ (first-row (floor (gfs:point-y pnt) +grid-cell-extent+))
+ (last-row (floor (gfs:size-height size) +grid-cell-extent+))
+ (first-col (floor (gfs:point-x pnt) +grid-cell-extent+))
+ (last-col (floor (gfs:size-width size) +grid-cell-extent+))
+ (lr-pnt (gfs:make-point :x (* +grid-cell-extent+ (gfs:size-width *grid-model-size*))
+ :y (* +grid-cell-extent+ (gfs:size-height *grid-model-size*)))))
+ (loop for row from first-row upto last-row
+ for start-pnt = (gfs:make-point :y (* row +grid-cell-extent+))
+ do (progn
+ (gfg:draw-line gc start-pnt (gfs:make-point :x (gfs:point-x lr-pnt)
+ :y (gfs:point-y start-pnt)))
+ (loop for col from first-col upto last-col
+ for text = (format nil "~d ~d" col row)
+ for start-pnt = (gfs:make-point :x (* col +grid-cell-extent+))
+ for text-pnt = (gfs:make-point :x (+ (* col +grid-cell-extent+)
+ (- +grid-half-extent+
+ (gfs:size-width *grid-char-size*)))
+ :y (+ (* row +grid-cell-extent+)
+ (- +grid-half-extent+
+ (gfs:size-height *grid-char-size*))))
+ do (progn
+ (if (= row first-row)
+ (gfg:draw-line gc start-pnt (gfs:make-point :x (gfs:point-x start-pnt)
+ :y (gfs:point-y lr-pnt))))
+ (gfg:draw-text gc text text-pnt '(:transparent))))))))
Modified: trunk/src/tests/uitoolkit/scroll-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/scroll-tester.lisp (original)
+++ trunk/src/tests/uitoolkit/scroll-tester.lisp Fri Sep 22 20:37:13 2006
@@ -55,7 +55,7 @@
:submenu ((:item "E&xit" :callback #'scroll-tester-exit)))))))
(setf *scroll-tester-win* (make-instance 'gfw:top-level :dispatcher disp
:layout layout
- :style '(:workspace)))
+ :style '(:workspace :horizontal-scrollbar :vertical-scrollbar)))
(let ((icons (make-instance 'gfg:icon-bundle :file (merge-pathnames "default.ico")))
(panel (make-scroll-grid-panel *scroll-tester-win*)))
(setf (gfw:menu-bar *scroll-tester-win*) menubar
Added: trunk/src/uitoolkit/widgets/scrollbar.lisp
==============================================================================
--- (empty file)
+++ trunk/src/uitoolkit/widgets/scrollbar.lisp Fri Sep 22 20:37:13 2006
@@ -0,0 +1,175 @@
+;;;;
+;;;; scrollbar.lisp
+;;;;
+;;;; Copyright (C) 2006, Jack D. Unrue
+;;;; All rights reserved.
+;;;;
+;;;; Redistribution and use in source and binary forms, with or without
+;;;; modification, are permitted provided that the following conditions
+;;;; are met:
+;;;;
+;;;; 1. Redistributions of source code must retain the above copyright
+;;;; notice, this list of conditions and the following disclaimer.
+;;;;
+;;;; 2. Redistributions in binary form must reproduce the above copyright
+;;;; notice, this list of conditions and the following disclaimer in the
+;;;; documentation and/or other materials provided with the distribution.
+;;;;
+;;;; 3. Neither the names of the authors nor the names of its contributors
+;;;; may be used to endorse or promote products derived from this software
+;;;; without specific prior written permission.
+;;;;
+;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY
+;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS-
+;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY
+;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
+;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
+;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+;;;;
+
+(in-package :graphic-forms.uitoolkit.widgets)
+
+;;;
+;;; helper functions
+;;;
+
+(defun validate-scrollbar-type (type)
+ (unless (or (= type gfs::+sb-ctl+) (= type gfs::+sb-horz+) (= type gfs::+sb-vert+))
+ (error 'gfs:toolkit-error :detail "invalid scrollbar type ID")))
+
+(defun sb-get-info (scrollbar type)
+ (if (gfs:disposed-p scrollbar)
+ (error 'gfs:disposed-error))
+ (validate-scrollbar-type type)
+ (let ((hwnd (gfs:handle scrollbar)))
+ (cffi:with-foreign-object (info-ptr 'gfs::scrollinfo)
+ (gfs::zero-mem info-ptr gfs::scrollinfo)
+ (cffi:with-foreign-slots ((gfs::cbsize gfs::fmask gfs::pagesize gfs::pos
+ gfs::minpos gfs::maxpos gfs::trackpos)
+ info-ptr gfs::scrollinfo)
+ (setf gfs::cbsize (cffi:foreign-type-size 'gfs::scrollinfo)
+ gfs::fmask gfs::+sif-all+)
+ (gfs::get-scroll-info hwnd type info-ptr)
+ (list (gfs:make-span :start gfs::minpos :end gfs::maxpos)
+ gfs::pagesize
+ gfs::pos
+ gfs::trackpos)))))
+
+(defun sb-set-page-increment (scrollbar type amount)
+ (validate-scrollbar-type type)
+ (when (< amount 0)
+ (warn 'gfs:toolkit-warning :detail "negative scrollbar page increment")
+ (return-from sb-set-page-increment 0))
+ (if (gfs:disposed-p scrollbar)
+ (error 'gfs:disposed-error))
+ (let ((hwnd (gfs:handle scrollbar)))
+ (cffi:with-foreign-object (info-ptr 'gfs::scrollinfo)
+ (gfs::zero-mem info-ptr gfs::scrollinfo)
+ (cffi:with-foreign-slots ((gfs::cbsize gfs::fmask gfs::pagesize)
+ info-ptr gfs::scrollinfo)
+ (setf gfs::cbsize (cffi:foreign-type-size 'gfs::scrollinfo)
+ gfs::fmask gfs::+sif-page+
+ gfs::pagesize amount))
+ (gfs::set-scroll-info hwnd type info-ptr 1)))
+ amount)
+
+(defun sb-set-thumb-limits (scrollbar type span)
+ (when (or (< (gfs:span-start span) 0) (< (gfs:span-end span) 0))
+ (warn 'gfs:toolkit-warning :detail "negative scrollbar limit")
+ (return-from sb-set-thumb-limits nil))
+ (if (gfs:disposed-p scrollbar)
+ (error 'gfs:disposed-error))
+ (let ((hwnd (gfs:handle scrollbar)))
+ (cffi:with-foreign-object (info-ptr 'gfs::scrollinfo)
+ (gfs::zero-mem info-ptr gfs::scrollinfo)
+ (cffi:with-foreign-slots ((gfs::cbsize gfs::fmask gfs::maxpos gfs::minpos)
+ info-ptr gfs::scrollinfo)
+ (setf gfs::cbsize (cffi:foreign-type-size 'gfs::scrollinfo)
+ gfs::fmask gfs::+sif-range+
+ gfs::minpos (gfs:span-start span)
+ gfs::maxpos (gfs:span-end span)))
+ (gfs::set-scroll-info hwnd type info-ptr 1)))
+ span)
+
+(defun sb-set-thumb-position (scrollbar type position)
+ (when (< position 0)
+ (warn 'gfs:toolkit-warning :detail "negative scrollbar position")
+ (return-from sb-set-thumb-position 0))
+ ;;
+ ;; TODO: should check position against limits, but doing that
+ ;; is not cheap, whereas the application will be calling this
+ ;; method frequently to maintain the scrollbar's position;
+ ;; more thought needed.
+ ;;
+ (if (gfs:disposed-p scrollbar)
+ (error 'gfs:disposed-error))
+ (let ((hwnd (gfs:handle scrollbar)))
+ (cffi:with-foreign-object (info-ptr 'gfs::scrollinfo)
+ (gfs::zero-mem info-ptr gfs::scrollinfo)
+ (cffi:with-foreign-slots ((gfs::cbsize gfs::fmask gfs::pos)
+ info-ptr gfs::scrollinfo)
+ (setf gfs::cbsize (cffi:foreign-type-size 'gfs::scrollinfo)
+ gfs::fmask gfs::+sif-pos+
+ gfs::pos position))
+ (gfs::set-scroll-info hwnd type info-ptr 1)))
+ position)
+
+;;;
+;;; standard scrollbar implementation
+;;;
+
+(defmethod gfs:dispose ((self standard-scrollbar))
+ (setf (slot-value self 'gfs:handle) nil))
+
+(defmethod initialize-instance :after ((self standard-scrollbar) &key)
+ (if (gfs:null-handle-p (gfs:handle self))
+ (error 'gfs:disposed-error))
+ (let ((orient (orientation-of self)))
+ (unless (or (= orient gfs::+sb-horz+) (= orient gfs::+sb-vert+))
+ (error 'gfs:toolkit-error :detail "invalid standard scrollbar orientation")))
+ (setf (slot-value self 'dispatcher) nil))
+
+(defmethod page-increment ((self standard-scrollbar))
+ (destructuring-bind (limits pagesize pos trackpos)
+ (sb-get-info self (orientation-of self))
+ (declare (ignore limits pos trackpos))
+ pagesize))
+
+(defmethod (setf page-increment) (amount (self standard-scrollbar))
+ (sb-set-page-increment self (orientation-of self) amount))
+
+(defmethod (setf step-increment) :after (amount (self standard-scrollbar))
+ (if (< amount 0)
+ (warn 'gfs:toolkit-warning :detail "negative scrollbar step increment")))
+
+(defmethod thumb-limits ((self standard-scrollbar))
+ (destructuring-bind (limits pagesize pos trackpos)
+ (sb-get-info self (orientation-of self))
+ (declare (ignore pagesize pos trackpos))
+ limits))
+
+(defmethod (setf thumb-limits) (span (self standard-scrollbar))
+ (sb-set-thumb-limits self (orientation-of self) span))
+
+(defmethod thumb-position ((self standard-scrollbar))
+ (destructuring-bind (limits pagesize pos trackpos)
+ (sb-get-info self (orientation-of self))
+ (declare (ignore limits pagesize trackpos))
+ pos))
+
+(defmethod (setf thumb-position) (position (self standard-scrollbar))
+ (sb-set-thumb-position self (orientation-of self) position))
+
+(defmethod thumb-track-position ((self standard-scrollbar))
+ (destructuring-bind (limits pagesize pos trackpos)
+ (sb-get-info self (orientation-of self))
+ (declare (ignore limits pagesize pos))
+ trackpos))
+
+;;;
+;;; TBD: scrollbar control implementation
+;;;
Added: trunk/src/uitoolkit/widgets/scrolling-event-dispatcher.lisp
==============================================================================
--- (empty file)
+++ trunk/src/uitoolkit/widgets/scrolling-event-dispatcher.lisp Fri Sep 22 20:37:13 2006
@@ -0,0 +1,50 @@
+;;;;
+;;;; scrolling-event-dispatcher.lisp
+;;;;
+;;;; Copyright (C) 2006, Jack D. Unrue
+;;;; All rights reserved.
+;;;;
+;;;; Redistribution and use in source and binary forms, with or without
+;;;; modification, are permitted provided that the following conditions
+;;;; are met:
+;;;;
+;;;; 1. Redistributions of source code must retain the above copyright
+;;;; notice, this list of conditions and the following disclaimer.
+;;;;
+;;;; 2. Redistributions in binary form must reproduce the above copyright
+;;;; notice, this list of conditions and the following disclaimer in the
+;;;; documentation and/or other materials provided with the distribution.
+;;;;
+;;;; 3. Neither the names of the authors nor the names of its contributors
+;;;; may be used to endorse or promote products derived from this software
+;;;; without specific prior written permission.
+;;;;
+;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY
+;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS-
+;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY
+;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
+;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
+;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+;;;;
+
+(in-package :graphic-forms.uitoolkit.widgets)
+
+;;;
+;;; helper functions
+;;;
+
+(defun validate-scrollbar-policies (disp)
+ (unless (and (find (horizontal-policy-of disp) '(:always :when-needed))
+ (find (vertical-policy-of disp) '(:always :when-needed)))
+ (error 'gfs:toolkit-error :detail "invalid scrollbar policy")))
+
+;;;
+;;; methods
+;;;
+
+(defmethod initialize-instance :after ((self scrolling-event-dispatcher) &key)
+ (validate-scrollbar-policies self))
Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-classes.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget-classes.lisp Fri Sep 22 20:37:13 2006
@@ -39,6 +39,17 @@
(defclass event-dispatcher () ()
(:documentation "Instances of this class receive events on behalf of user interface objects."))
+(defclass scrolling-event-dispatcher (event-dispatcher)
+ ((horizontal-policy
+ :accessor horizontal-policy-of
+ :initarg :horizontal-policy
+ :initform :always)
+ (vertical-policy
+ :accessor vertical-policy-of
+ :initarg :vertical-policy
+ :initform :always))
+ (:documentation "Instances of this class manage scrolling behavior in addition to other event processing."))
+
(defvar *default-dispatcher* (make-instance 'event-dispatcher))
(defclass layout-managed ()
@@ -98,6 +109,17 @@
(defclass menu-item (item) ()
(:documentation "A subclass of item representing a menu item."))
+(defclass standard-scrollbar (event-source)
+ ((orientation
+ :reader orientation-of
+ :initarg :orientation
+ :initform nil)
+ (step-increment
+ :accessor step-increment
+ :initarg :step-increment
+ :initform 1))
+ (:documentation "This class encapsulates a scrollbar attached to a window."))
+
(defclass widget (event-source)
((style
:accessor style-of
Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-generics.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget-generics.lisp Fri Sep 22 20:37:13 2006
@@ -405,8 +405,20 @@
(defgeneric (setf text-modified-p) (modified self)
(:documentation "Sets self's modified flag."))
-(defgeneric thumb-size (self)
- (:documentation "Returns an integer representing the width (or height) of this object's thumb."))
+(defgeneric thumb-limits (self)
+ (:documentation "Returns the lowest and highest allowed positions of self's thumb component."))
+
+(defgeneric (setf thumb-limits) (span self)
+ (:documentation "Sets the lowest and highest allowed positions of self's thumb component."))
+
+(defgeneric thumb-position (self)
+ (:documentation "Returns the position of self's thumb component."))
+
+(defgeneric (setf thumb-position) (position self)
+ (:documentation "Sets the position of self's thumb component."))
+
+(defgeneric thumb-track-position (self)
+ (:documentation "Returns self's current track position."))
(defgeneric tooltip-text (self)
(:documentation "Returns the text that will appear within a tooltip when the mouse hovers over this object."))
Modified: trunk/src/uitoolkit/widgets/window.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/window.lisp (original)
+++ trunk/src/uitoolkit/widgets/window.lisp Fri Sep 22 20:37:13 2006
@@ -307,6 +307,22 @@
(perform (layout-of self) self (gfs:size-width size) (gfs:size-height size)))
size)))
+(defmethod obtain-horizontal-scrollbar :before ((self window))
+ (if (gfs:disposed-p self)
+ (error 'gfs:disposed-error)))
+
+(defmethod obtain-horizontal-scrollbar ((self window))
+ (if (test-native-style self gfs::+ws-hscroll+)
+ (make-instance 'standard-scrollbar :handle (gfs:handle self) :orientation gfs::+sb-horz+)))
+
+(defmethod obtain-vertical-scrollbar :before ((self window))
+ (if (gfs:disposed-p self)
+ (error 'gfs:disposed-error)))
+
+(defmethod obtain-vertical-scrollbar ((self window))
+ (if (test-native-style self gfs::+ws-vscroll+)
+ (make-instance 'standard-scrollbar :handle (gfs:handle self) :orientation gfs::+sb-vert+)))
+
(defmethod pack ((self window))
(unless (null (layout-of self))
(perform (layout-of self) self -1 -1))
