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))