Author: junrue Date: Mon Sep 25 12:12:28 2006 New Revision: 267
Modified: trunk/docs/manual/widget-functions.texinfo trunk/src/tests/uitoolkit/scroll-grid-panel.lisp trunk/src/tests/uitoolkit/scroll-tester.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/scrolling-event-dispatcher.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/window.lisp Log: some more pieces of the scrolling puzzle
Modified: trunk/docs/manual/widget-functions.texinfo ============================================================================== --- trunk/docs/manual/widget-functions.texinfo (original) +++ trunk/docs/manual/widget-functions.texinfo Mon Sep 25 12:12:28 2006 @@ -653,10 +653,13 @@ before this function returns. @end deffn
-@defun update-scrolling-state @ref{event-dispatcher} @ref{window} &optional axis detail => symbol +@defun update-scrolling-state @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} +updated. The dispatcher assigned to @var{window} must be an instance of +(or an instance of a subclass of) @ref{scrolling-event-dispatcher}. + +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 @@ -664,7 +667,8 @@ 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. +behalf of a window when set as that window's dispatcher. Application +code may also call this function as needed. @end defun
@anchor{update-from-items}
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 Mon Sep 25 12:12:28 2006 @@ -43,18 +43,18 @@ (defclass scroll-grid-panel-events (gfw:event-dispatcher) ())
(defun make-scroll-grid-panel (parent) - (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+))) + (let ((panel-size (gfs:make-size :width (1+ (* (gfs:size-width *grid-model-size*) +grid-cell-extent+)) + :height (1+ (* (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 (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))) + (setf (gfw:thumb-limits scrollbar) (gfs:make-span :end (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))) + (setf (gfw:thumb-limits scrollbar) (gfs:make-span :end (gfs:size-height panel-size)) (gfw:thumb-position scrollbar) 0) (gfs:dispose scrollbar)) #| @@ -79,14 +79,13 @@ (gfg:foreground-color gc) color)) (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) + (gfg:pen-style gc) '(:solid :flat-endcap)) (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+)) + (last-row (floor (+ (gfs:point-y pnt) (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+)) + (last-col (floor (+ (gfs:point-x pnt) (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
Modified: trunk/src/tests/uitoolkit/scroll-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/scroll-tester.lisp (original) +++ trunk/src/tests/uitoolkit/scroll-tester.lisp Mon Sep 25 12:12:28 2006 @@ -47,18 +47,6 @@ (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))
Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Mon Sep 25 12:12:28 2006 @@ -365,22 +365,27 @@ (declare (ignore wparam lparam)) (let ((widget (get-widget (thread-context) hwnd))) (if widget - (let ((rct (gfs:make-rectangle))) - (cffi:with-foreign-object (ps-ptr 'gfs::paintstruct) - (cffi:with-foreign-slots ((gfs::rcpaint-x - gfs::rcpaint-y - gfs::rcpaint-width - gfs::rcpaint-height) - ps-ptr gfs::paintstruct) - (let ((gc (make-instance 'gfg:graphics-context :handle (gfs::begin-paint hwnd ps-ptr)))) - (setf (gfs:location rct) (gfs:make-point :x gfs::rcpaint-x - :y gfs::rcpaint-y)) - (setf (gfs:size rct) (gfs:make-size :width gfs::rcpaint-width - :height gfs::rcpaint-height)) + (cffi:with-foreign-object (ps-ptr 'gfs::paintstruct) + (cffi:with-foreign-slots ((gfs::rcpaint-x gfs::rcpaint-y + gfs::rcpaint-width gfs::rcpaint-height) + ps-ptr gfs::paintstruct) + (let ((gc (make-instance 'gfg:graphics-context :handle (gfs::begin-paint hwnd ps-ptr))) + (pnt (gfs:make-point :x gfs::rcpaint-x :y gfs::rcpaint-y)) + (size (gfs:make-size :width gfs::rcpaint-width :height gfs::rcpaint-height)) + (disp (dispatcher widget))) (unwind-protect - (event-paint (dispatcher widget) widget gc rct) + (let ((parent (gfw:parent widget))) + (when (and parent (typep (dispatcher parent) 'scrolling-event-dispatcher)) + (let ((origin (slot-value (dispatcher parent) 'viewport-origin))) + (gfs::set-window-org (gfs:handle gc) + (- (gfs:point-x origin)) + (- (gfs:point-y origin)) + (cffi:null-pointer)) + (decf (gfs:point-x pnt) (gfs:point-x origin)) + (decf (gfs:point-y pnt) (gfs:point-y origin)))) + (event-paint disp widget gc (gfs:make-rectangle :location pnt :size size))) (gfs:dispose gc) - (gfs::end-paint hwnd ps-ptr)))))) + (gfs::end-paint hwnd ps-ptr))))) (error 'gfs:toolkit-error :detail "no object for hwnd"))) 0)
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 Mon Sep 25 12:12:28 2006 @@ -38,61 +38,97 @@ ;;;
(defun clamp-scroll-pos (pos total-steps page-size) - (setf pos (min pos (- total-steps page-size))) + (setf pos (min pos (1+ (- 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)))) +(defun compute-scrolling-delta (scrollbar step-size detail) + (let ((page-size (page-increment scrollbar)) + (limits (thumb-limits scrollbar)) + (curr-pos (thumb-position scrollbar))) + (let ((new-pos (case detail + (:start (gfs:span-start limits)) + (:end (gfs:span-end limits)) + (:step-back (1- curr-pos)) + (:step-forward (1+ curr-pos)) + (: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)) + (setf (thumb-position scrollbar) new-pos) + (* (- curr-pos new-pos) step-size)))) + +(defun update-scrolling-state (window &optional axis detail) + (unless axis + (return-from update-scrolling-state nil)) + (unless detail + (setf detail :thumb-position)) + (let ((layout (layout-of window)) + (disp (dispatcher window))) + (unless (typep layout 'heap-layout) + (return-from update-scrolling-state nil)) + (let ((child (top-child-of (layout-of window))) + (step-incs (step-increments disp)) + (delta-x 0) + (delta-y 0)) + (cond + ((eql axis :horizontal) + (let ((scrollbar (obtain-horizontal-scrollbar window))) + (setf delta-x (compute-scrolling-delta scrollbar (gfs:size-width step-incs) detail)) + (gfs:dispose scrollbar))) + ((eql axis :vertical) + (let ((scrollbar (obtain-vertical-scrollbar window))) + (setf delta-y (compute-scrolling-delta scrollbar (gfs:size-height step-incs) detail)) + (gfs:dispose scrollbar)))) + (let ((origin (slot-value disp 'viewport-origin))) + (incf (gfs:point-x origin) delta-x) + (incf (gfs:point-y origin) delta-y) + (scroll child delta-x delta-y nil 0)))) detail)
-(defun validate-step-values (step-increments) - (if (or (<= (gfs:size-width step-increments) 0) (<= (gfs:size-height step-increments) 0)) +(defun validate-step-values (amounts) + (if (or (<= (gfs:size-width amounts) 0) (<= (gfs:size-height amounts) 0)) (error 'gfs:toolkit-error :detail "invalid step increment")))
+(defun update-scrollbar-page-sizes (window) + (let ((disp (dispatcher window)) + (viewport-size (client-size window)) + (top nil) + (scrollbar nil) + (layout (layout-of window))) + (unless (and layout (typep layout 'heap-layout)) + (return-from update-scrollbar-page-sizes nil)) + (setf top (top-child-of layout)) + (unless top + (setf top (car (first (compute-layout layout window -1 -1))))) + (let ((step-incs (step-increments disp)) + (top-size (if top (size top) viewport-size))) + (setf scrollbar (obtain-horizontal-scrollbar window)) + (if scrollbar + (setf (page-increment scrollbar) (* (1+ (min (gfs:size-width viewport-size) + (gfs:size-width top-size))) + (gfs:size-width step-incs)))) + (setf scrollbar (obtain-vertical-scrollbar window)) + (if scrollbar + (setf (page-increment scrollbar) (* (1+ (min (gfs:size-height viewport-size) + (gfs:size-height top-size))) + (gfs:size-height step-incs))))))) + ;;; ;;; methods ;;;
+(defmethod event-resize ((disp scrolling-event-dispatcher) (window window) size type) + (declare (ignore size type)) + (call-next-method) + (update-scrollbar-page-sizes window)) + (defmethod event-scroll ((disp scrolling-event-dispatcher) (window window) axis detail) - (update-scrolling-state disp window axis detail)) + (declare (ignore disp)) + (update-scrolling-state window axis detail))
(defmethod initialize-instance :after ((self scrolling-event-dispatcher) &key) (validate-step-values (step-increments self))) @@ -106,7 +142,3 @@ (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 Mon Sep 25 12:12:28 2006 @@ -51,7 +51,9 @@ (vertical-policy :accessor vertical-policy-of :initarg :vertical-policy - :initform :always)) + :initform :always) + (viewport-origin + :initform (gfs:make-point))) (:documentation "Instances of this class manage scrolling behavior in addition to other event processing."))
(defvar *default-dispatcher* (make-instance 'event-dispatcher))
Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Mon Sep 25 12:12:28 2006 @@ -358,7 +358,7 @@ (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+))) + (let ((flags gfs::+sw-invalidate+)) (if (> millis 0) (let ((tmp (ash (logand millis #xFFFF) 16))) (setf flags (logior flags tmp gfs::+sw-smoothscroll+))))