Author: junrue Date: Sun Sep 24 02:54:04 2006 New Revision: 266

Modified: trunk/docs/manual/widget-functions.texinfo trunk/docs/manual/widget-types.texinfo trunk/src/packages.lisp trunk/src/tests/uitoolkit/scroll-grid-panel.lisp trunk/src/tests/uitoolkit/scroll-tester.lisp trunk/src/uitoolkit/system/gdi32.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/system/user32.lisp trunk/src/uitoolkit/widgets/layout.lisp trunk/src/uitoolkit/widgets/scrollbar.lisp trunk/src/uitoolkit/widgets/scrolling-event-dispatcher.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/widget-constants.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp trunk/src/uitoolkit/widgets/widget.lisp trunk/src/uitoolkit/widgets/window.lisp Log: more progress towards scroll-tester actually working

Modified: trunk/docs/manual/widget-functions.texinfo ============================================================================== --- trunk/docs/manual/widget-functions.texinfo (original) +++ trunk/docs/manual/widget-functions.texinfo Sun Sep 24 02:54:04 2006 @@ -522,6 +522,17 @@ decorations are modified appropriately. @end deffn

+@anchor{scroll} +@deffn GenericFunction scroll self delta-x delta-y children-p millis +Scrolls @var{self} by a number of pixels right or down equal to the +integer values @var{delta-x} and @var{delta-y}; either delta value +may be negative in order to scroll left or up. When @var{children-p} +is non-@sc{nil}, the children of @var{self} are scrolled as well. +When @var{millis} is greater than zero, the system will animate +the scrolling operation within the specified number of milliseconds. +Paint events are delivered for the areas needing to be repainted. +@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}. @@ -642,6 +653,20 @@ before this function returns. @end deffn

+@defun update-scrolling-state @ref{event-dispatcher} @ref{window} &optional axis detail => symbol +Call this function to respond to a scrolling event so that the content +of @var{window} can be scrolled and @var{window}'s scrollbar state(s) +updated. The @var{axis} argument can be @code{:horizontal} or @code{:vertical} +to request processing in the corresponding direction; or if unspecified, +scroll processing will occur in both directions. The @var{detail} argument +can be one of the values described for @ref{event-scroll}; or if +unspecified, @code{:thumb-position} will be assumed. This function returns +the value of the @var{detail} argument. + +Note that @ref{scrolling-event-dispatcher} calls this function on +behalf of a window when set as that window's dispatcher. +@end defun + @anchor{update-from-items} @deffn GenericFunction update-from-items self Synchronizes @var{self}'s internal model (i.e., a native control's

Modified: trunk/docs/manual/widget-types.texinfo ============================================================================== --- trunk/docs/manual/widget-types.texinfo (original) +++ trunk/docs/manual/widget-types.texinfo Sun Sep 24 02:54:04 2006 @@ -142,6 +142,39 @@ A subclass of @ref{item} representing a @ref{menu} item. @end deftp

+@anchor{scrolling-event-dispatcher} +@deftp Class scrolling-event-dispatcher horizontal-policy step-increments vertical-policy +This is a subclass of @ref{event-dispatcher} that is specialized for +processing scrolling events on behalf of @ref{window}s. +@table @var +@item horizontal-policy +One of the following keyword symbols describing a scrollbar visibility +policy: +@table @code +@item :always +The scrollbar is always visible, set to a disabled state if scrolling +is unnecessary. +@item :when-needed +The scrollbar is hidden when scrolling is unnecessary. +@end table +The default policy is @code{:always} +@item step-increments +A @ref{size} object describing how many pixels a single step in either +direction will jump, by default one pixel. +@item vertical-policy +One of the following keyword symbols describing a scrollbar visibility +policy: +@table @code +@item :always +The scrollbar is always visible, set to a disabled state if scrolling +is unnecessary. +@item :when-needed +The scrollbar is hidden when scrolling is unnecessary. +@end table +The default policy is @code{:always} +@end table +@end deftp + @anchor{standard-scrollbar} @deftp Class standard-scrollbar orientation step-increment This class encapsulates a @emph{standard scrollbar}, which

Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Sun Sep 24 02:54:04 2006 @@ -264,6 +264,7 @@ #:menu-item #:panel #:root-window + #:scrolling-event-dispatcher #:timer #:top-level #:widget @@ -506,7 +507,7 @@ #:size #:spacing-of #:startup - #:step-increment + #:step-increments #:style-of #:sub-menu #:text @@ -527,6 +528,7 @@ #:trim-sizes #:undo-available-p #:update + #:update-scrolling-state #:vertical-policy-of #:visible-item-count #:visible-p

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 Sun Sep 24 02:54:04 2006 @@ -49,6 +49,14 @@ :parent parent))) (setf (gfw:maximum-size panel) panel-size) (assert (gfs:equal-size-p panel-size (slot-value panel 'gfw::max-size))) + (let ((scrollbar (gfw:obtain-horizontal-scrollbar parent))) + (setf (gfw:thumb-limits scrollbar) (gfs:make-span :end (1- (gfs:size-width panel-size))) + (gfw:thumb-position scrollbar) 0) + (gfs:dispose scrollbar)) + (let ((scrollbar (gfw:obtain-vertical-scrollbar parent))) + (setf (gfw:thumb-limits scrollbar) (gfs:make-span :end (1- (gfs:size-height panel-size))) + (gfw:thumb-position scrollbar) 0) + (gfs:dispose scrollbar)) #| (let* ((gc (make-instance 'gfg:graphics-context :widget panel)) (font (make-instance 'gfg:font :gc gc)))

Modified: trunk/src/tests/uitoolkit/scroll-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/scroll-tester.lisp (original) +++ trunk/src/tests/uitoolkit/scroll-tester.lisp Sun Sep 24 02:54:04 2006 @@ -41,12 +41,24 @@ (setf *scroll-tester-win* nil) (gfw:shutdown 0))

-(defclass scroll-tester-events (gfw:event-dispatcher) ()) +(defclass scroll-tester-events (gfw:scrolling-event-dispatcher) ())

(defmethod gfw:event-close ((disp scroll-tester-events) window) (declare (ignore window)) (scroll-tester-exit disp nil))

+(defmethod gfw:event-resize ((disp scroll-tester-events) window size type) + (declare (ignore size type)) + (let ((client-size (gfw:client-size window)) + (scrollbar nil)) + (setf scrollbar (gfw:obtain-horizontal-scrollbar window)) + (if scrollbar + (setf (gfw:page-increment scrollbar) (gfs:size-width client-size))) + (setf scrollbar (gfw:obtain-vertical-scrollbar window)) + (if scrollbar + (setf (gfw:page-increment scrollbar) (gfs:size-height client-size)))) + (call-next-method)) + (defun scroll-tester-internal () (setf *default-pathname-defaults* (parse-namestring gfsys::*gf-tests-dir*)) (let ((disp (make-instance 'scroll-tester-events)) @@ -61,6 +73,7 @@ (setf (gfw:menu-bar *scroll-tester-win*) menubar (gfw:top-child-of layout) panel (gfw:image *scroll-tester-win*) icons)) + (setf (gfw:text *scroll-tester-win*) "Scroll Tester") (gfw:show *scroll-tester-win* t)))

(defun scroll-tester ()

Modified: trunk/src/uitoolkit/system/gdi32.lisp ============================================================================== --- trunk/src/uitoolkit/system/gdi32.lisp (original) +++ trunk/src/uitoolkit/system/gdi32.lisp Sun Sep 24 02:54:04 2006 @@ -272,6 +272,12 @@ (lpm LPTR))

(defcfun + ("GetWindowOrgEx" get-window-org) + BOOL + (hdc HANDLE) + (point LPTR)) + +(defcfun ("MaskBlt" mask-blt) BOOL (hdest HANDLE) @@ -422,5 +428,13 @@ (hdc HANDLE) (color COLORREF))

+(defcfun + ("SetWindowOrgEx" set-window-org) + BOOL + (hdc HANDLE) + (x INT) + (y INT) + (point LPTR)) + (defun makerop4 (fore back) (logior (logand (ash back 8) #xFF000000) fore))

Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Sun Sep 24 02:54:04 2006 @@ -1007,6 +1007,17 @@ (defconstant +stn-enable+ 2) (defconstant +stn-disable+ 3)

+;;; +;;; commands for ScrollWindowEx() +;;; +(defconstant +sw-scrollchildren+ #x0001) +(defconstant +sw-invalidate+ #x0002) +(defconstant +sw-erase+ #x0004) +(defconstant +sw-smoothscroll+ #x0010) + +;;; +;;; commands for ShowWindow() +;;; (defconstant +sw-hide+ 0) (defconstant +sw-shownormal+ 1) (defconstant +sw-normal+ 1)

Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Sun Sep 24 02:54:04 2006 @@ -631,6 +631,18 @@ (pnt :pointer))

(defcfun + ("ScrollWindowEx" scroll-window) + INT + (hwnd HANDLE) + (dx INT) + (dy INT) + (scrollrect LPTR) + (cliprect LPTR) + (updatergn HANDLE) + (updaterect LPTR) + (flags UINT)) + +(defcfun ("SendMessageA" send-message) LRESULT (hwnd HANDLE)

Modified: trunk/src/uitoolkit/widgets/layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/layout.lisp (original) +++ trunk/src/uitoolkit/widgets/layout.lisp Sun Sep 24 02:54:04 2006 @@ -33,12 +33,6 @@

(in-package :graphic-forms.uitoolkit.widgets)

-(eval-when (:compile-toplevel :load-toplevel :execute) - (defconstant +window-pos-flags+ (logior gfs::+swp-nozorder+ - gfs::+swp-noownerzorder+ - gfs::+swp-noactivate+ - gfs::+swp-nocopybits+))) - ;;; ;;; helper functions ;;;

Modified: trunk/src/uitoolkit/widgets/scrollbar.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/scrollbar.lisp (original) +++ trunk/src/uitoolkit/widgets/scrollbar.lisp Sun Sep 24 02:54:04 2006 @@ -142,10 +142,6 @@ (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))

Modified: trunk/src/uitoolkit/widgets/scrolling-event-dispatcher.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/scrolling-event-dispatcher.lisp (original) +++ trunk/src/uitoolkit/widgets/scrolling-event-dispatcher.lisp Sun Sep 24 02:54:04 2006 @@ -37,14 +37,76 @@ ;;; 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"))) +(defun clamp-scroll-pos (pos total-steps page-size) + (setf pos (min pos (- total-steps page-size))) + (max pos 0)) + +(defun update-scrolling-state (disp window &optional axis detail) + (unless detail + (setf detail :thumb-position)) + (unless axis + (if (horizontal-scrollbar-p window) + (update-scrolling-state disp window :horizontal detail)) + (if (vertical-scrollbar-p window) + (update-scrolling-state disp window :vertical detail)) + (return-from update-scrolling-state detail)) + (let ((scrollbar nil) + (step-incs (step-increments disp)) + (step-size 0)) + (ecase axis + (:horizontal + (setf scrollbar (obtain-horizontal-scrollbar window) + step-size (gfs:size-width step-incs))) + (:vertical + (setf scrollbar (obtain-vertical-scrollbar window) + step-size (gfs:size-height step-incs)))) + (let* ((page-size (page-increment scrollbar)) + (limits (thumb-limits scrollbar)) + (curr-pos (thumb-position scrollbar)) + (new-pos (case detail + (:start (gfs:span-start limits)) + (:end (gfs:span-end limits)) + (:step-back (- curr-pos step-size)) + (:step-forward (+ curr-pos step-size)) + (:page-back (- curr-pos page-size)) + (:page-forward (+ curr-pos page-size)) + (:thumb-position curr-pos) + (:thumb-track (thumb-track-position scrollbar)) + (otherwise curr-pos)))) + (setf new-pos (clamp-scroll-pos new-pos + (- (gfs:span-end limits) (gfs:span-start limits)) + page-size)) + (ecase axis + (:horizontal (scroll window (- new-pos curr-pos) 0 nil 0)) + (:vertical (scroll window 0 (- new-pos curr-pos) nil 0))) + (setf (thumb-position scrollbar) new-pos)) + (gfs:dispose scrollbar)) + detail) + +(defun validate-step-values (step-increments) + (if (or (<= (gfs:size-width step-increments) 0) (<= (gfs:size-height step-increments) 0)) + (error 'gfs:toolkit-error :detail "invalid step increment")))

;;; ;;; methods ;;;

+(defmethod event-scroll ((disp scrolling-event-dispatcher) (window window) axis detail) + (update-scrolling-state disp window axis detail)) + (defmethod initialize-instance :after ((self scrolling-event-dispatcher) &key) - (validate-scrollbar-policies self)) + (validate-step-values (step-increments self))) + +(defmethod print-object ((self scrolling-event-dispatcher) stream) + (print-unreadable-object (self stream :type t) + (format stream "horizontal policy: ~a " (horizontal-policy-of self)) + (format stream "vertical policy: ~a " (vertical-policy-of self)) + (format stream "step increments: ~a" (step-increments self)))) + +(defmethod (setf step-increment) :after (amounts (self scrolling-event-dispatcher)) + (validate-step-values amounts) + (setf (slot-value self 'step-increment) (gfs:copy-size amounts))) + +(defmethod (setf total-step-count) :after (amounts (self scrolling-event-dispatcher)) + (validate-step-values amounts) + (setf (slot-value self 'step-increment) (gfs:copy-size amounts)))

Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Sun Sep 24 02:54:04 2006 @@ -44,6 +44,10 @@ :accessor horizontal-policy-of :initarg :horizontal-policy :initform :always) + (step-increments + :accessor step-increments + :initarg :step-increments + :initform (gfs:make-size :width 1 :height 1)) (vertical-policy :accessor vertical-policy-of :initarg :vertical-policy @@ -113,11 +117,7 @@ ((orientation :reader orientation-of :initarg :orientation - :initform nil) - (step-increment - :accessor step-increment - :initarg :step-increment - :initform 1)) + :initform nil)) (:documentation "This class encapsulates a scrollbar attached to a window."))

(defclass widget (event-source)

Modified: trunk/src/uitoolkit/widgets/widget-constants.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-constants.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-constants.lisp Sun Sep 24 02:54:04 2006 @@ -98,4 +98,8 @@ (defconstant +default-child-style+ (logior gfs::+ws-child+ gfs::+ws-visible+)) (defconstant +default-widget-width+ 64) (defconstant +default-widget-height+ 64) - (defconstant +estimated-text-size+ 32)) ; bytes + (defconstant +estimated-text-size+ 32) ; bytes + (defconstant +window-pos-flags+ (logior gfs::+swp-nozorder+ + gfs::+swp-noownerzorder+ + gfs::+swp-noactivate+ + gfs::+swp-nocopybits+)))

Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Sun Sep 24 02:54:04 2006 @@ -327,8 +327,8 @@ (defgeneric retrieve-span (self) (:documentation "Returns the span object indicating the range of values that are valid for the object."))

-(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 scroll (self delta-x delta-y children-p millis) + (:documentation "Scrolls the contents of self a specified number of pixels."))

(defgeneric select (self flag) (:documentation "Set self 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 Sun Sep 24 02:54:04 2006 @@ -336,6 +336,11 @@ (defmethod resizable-p ((self widget)) nil)

+(defmethod scroll :before ((self widget) delta-x delta-y children-p millis) + (declare (ignore delta-x delta-y children-p millis)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + (defmethod select :before ((self widget) flag) (declare (ignore flag)) (if (gfs:disposed-p self)

Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Sun Sep 24 02:54:04 2006 @@ -138,6 +138,16 @@ (defun release-mouse () (gfs::release-capture))

+(defun scroll-children (window delta-x delta-y) + (let ((specs (mapchildren window (lambda (parent child) + (declare (ignore parent)) + (let ((pnt (location child)) + (size (size child))) + (incf (gfs:point-x pnt) delta-x) + (incf (gfs:point-y pnt) delta-y) + (list child (gfs:make-rectangle :location pnt :size size))))))) + (arrange-hwnds specs (lambda (child) (declare (ignore child)) +window-pos-flags+)))) + ;;; ;;; methods ;;; @@ -347,6 +357,22 @@ (if (not (gfs:disposed-p self)) (format stream "size: ~a" (size self)))))

+(defmethod scroll ((self window) delta-x delta-y children-p millis) + (let ((flags (logior gfs::+sw-erase+ gfs::+sw-invalidate+))) + (if (> millis 0) + (let ((tmp (ash (logand millis #xFFFF) 16))) + (setf flags (logior flags tmp gfs::+sw-smoothscroll+)))) + (if children-p + (scroll-children self delta-x delta-y)) + (gfs::scroll-window (gfs:handle self) + delta-x + delta-y + (cffi:null-pointer) + (cffi:null-pointer) + (cffi:null-pointer) + (cffi:null-pointer) + flags))) + (defmethod show ((self window) flag) (declare (ignore flag)) (call-next-method)