[graphic-forms-cvs] r300 - in trunk/src: tests/uitoolkit uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Thu Oct 12 01:20:02 UTC 2006
Author: junrue
Date: Wed Oct 11 21:20:01 2006
New Revision: 300
Modified:
trunk/src/tests/uitoolkit/scroll-grid-panel.lisp
trunk/src/tests/uitoolkit/scroll-tester.lisp
trunk/src/tests/uitoolkit/scroll-text-panel.lisp
trunk/src/uitoolkit/widgets/scrolling-event-dispatcher.lisp
Log:
fixed scrolling regressions
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 Wed Oct 11 21:20:01 2006
@@ -68,8 +68,8 @@
(setf scrollbar (gfw:obtain-vertical-scrollbar window))
(setf (gfw:outer-limits scrollbar)
(gfs:make-span :end (gfs:size-height panel-size)))
- (setf (gfw:step-increments disp) (gfs:make-size :width 1 :height 1))
(setf (gfw:thumb-position scrollbar) 0)
+ (setf (gfw:step-increments disp) (gfs:make-size :width 1 :height 1))
(setf (slot-value disp 'gfw::viewport-origin) (gfs:make-point))
(gfw:event-resize disp window (gfw:size window) :restored)))
Modified: trunk/src/tests/uitoolkit/scroll-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/scroll-tester.lisp (original)
+++ trunk/src/tests/uitoolkit/scroll-tester.lisp Wed Oct 11 21:20:01 2006
@@ -81,9 +81,9 @@
(:item "&Text" :callback select-text)))))))
(setf (gfw:menu-bar *scroll-tester-win*) menubar
(gfw:top-child-of layout) grid-panel))
- (set-grid-scroll-params *scroll-tester-win*)
(setf (gfw:text *scroll-tester-win*) "Scroll Tester"
(gfw:size *scroll-tester-win*) (gfs:make-size :width 300 :height 275))
+ (set-grid-scroll-params *scroll-tester-win*)
(gfw:show *scroll-tester-win* t)))
(defun scroll-tester ()
Modified: trunk/src/tests/uitoolkit/scroll-text-panel.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/scroll-text-panel.lisp (original)
+++ trunk/src/tests/uitoolkit/scroll-text-panel.lisp Wed Oct 11 21:20:01 2006
@@ -79,19 +79,18 @@
panel))
(defun set-text-scroll-params (window)
- (let ((disp (gfw:dispatcher window))
- (panel (gfw::obtain-top-child window)))
+ (let* ((disp (gfw:dispatcher window))
+ (panel (gfw::obtain-top-child window))
+ (panel-size (gfw:size panel)))
(gfw:with-graphics-context (gc panel)
(let ((metrics (gfg:metrics gc (font-of (gfw:dispatcher panel))))
(scrollbar (gfw:obtain-horizontal-scrollbar window)))
(setf (gfw:outer-limits scrollbar)
- (gfs:make-span :end (* (gfs:size-width *text-model-size*)
- (gfg:average-char-width metrics))))
+ (gfs:make-span :end (gfs:size-width panel-size)))
(setf (gfw:thumb-position scrollbar) 0)
(setf scrollbar (gfw:obtain-vertical-scrollbar window))
(setf (gfw:outer-limits scrollbar)
- (gfs:make-span :end (* (gfs:size-height *text-model-size*)
- (gfg:height metrics))))
+ (gfs:make-span :end (gfs:size-height panel-size)))
(setf (gfw:thumb-position scrollbar) 0)
(setf (gfw:step-increments disp) (gfs:make-size :width (gfg:average-char-width metrics)
:height (gfg:height metrics)))))
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 Wed Oct 11 21:20:01 2006
@@ -38,7 +38,7 @@
;;;
(defun clamp-scroll-pos (pos total-steps page-size)
- (setf pos (min pos (1+ (- total-steps page-size))))
+ (setf pos (min pos (- total-steps page-size)))
(max pos 0))
(defun update-scrollbar (scrollbar step-size detail)
@@ -61,67 +61,64 @@
(setf (thumb-position scrollbar) new-pos)
new-pos)))
-(defun update-scrolling-state (window &optional axis detail)
+(defun update-scrolling-state (window axis &optional detail)
(unless axis
(return-from update-scrolling-state nil))
(unless detail
(setf detail :thumb-position))
- (let ((disp (dispatcher window)))
+ (let ((disp (dispatcher window))
+ (hscrollbar (obtain-horizontal-scrollbar window))
+ (vscrollbar (obtain-vertical-scrollbar window)))
(let ((child (obtain-top-child window))
+ (origin (slot-value disp 'viewport-origin))
(h-step (gfs:size-width (step-increments disp)))
(v-step (gfs:size-height (step-increments disp)))
(new-hpos 0)
(new-vpos 0))
(cond
- ((or (eql axis :horizontal) (eql axis :both))
- (let ((scrollbar (obtain-horizontal-scrollbar window)))
- (setf new-hpos (update-scrollbar scrollbar h-step detail))))
- ((or (eql axis :vertical) (eql axis :both))
- (let ((scrollbar (obtain-vertical-scrollbar window)))
- (setf new-vpos (update-scrollbar scrollbar v-step detail)))))
- (let* ((origin (slot-value disp 'viewport-origin))
- (delta-x (* (floor (- (gfs:point-x origin) new-hpos) h-step) h-step))
- (delta-y (* (floor (- (gfs:point-y origin) new-vpos) v-step) v-step)))
- (decf (gfs:point-x origin) delta-x)
- (decf (gfs:point-y origin) delta-y)
- (scroll child delta-x delta-y nil 0))))
+ ((eql axis :horizontal)
+ (setf new-hpos (update-scrollbar hscrollbar h-step detail))
+ (setf new-vpos (thumb-position vscrollbar)))
+ ((eql axis :vertical)
+ (setf new-hpos (thumb-position hscrollbar))
+ (setf new-vpos (update-scrollbar vscrollbar v-step detail)))
+ ((eql axis :both)
+ (setf new-hpos (update-scrollbar hscrollbar h-step detail))
+ (setf new-vpos (update-scrollbar vscrollbar v-step detail))))
+ (let ((new-x (* (floor new-hpos h-step) h-step))
+ (new-y (* (floor new-vpos v-step) v-step)))
+ (scroll child (- (gfs:point-x origin) new-x) (- (gfs:point-y origin) new-y) nil 0)
+ (setf (gfs:point-x origin) new-x)
+ (setf (gfs:point-y origin) new-y))))
detail)
(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-size (scrollbar viewport-dim top-dim)
- (if scrollbar
- (setf (page-increment scrollbar) (1+ (min viewport-dim top-dim))))
- scrollbar)
-
(defun update-scrollbar-page-sizes (window)
- (let ((viewport-size (client-size window))
- (top (obtain-top-child window)))
- (let ((top-size (if top (size top) viewport-size)))
- (update-scrollbar-page-size (obtain-vertical-scrollbar window)
- (gfs:size-height viewport-size)
- (gfs:size-height top-size))
- (setf viewport-size (client-size window))
- (update-scrollbar-page-size (obtain-horizontal-scrollbar window)
- (gfs:size-width viewport-size)
- (gfs:size-width top-size)))))
+ (setf (page-increment (obtain-vertical-scrollbar window))
+ (gfs:size-height (client-size window)))
+ (setf (page-increment (obtain-horizontal-scrollbar window))
+ (gfs:size-width (client-size window)))) ; recalculate client size on purpose
(defun update-viewport-origin-for-resize (window)
(let* ((top (obtain-top-child window))
(viewport-size (client-size window))
- (top-size (if top (size top) viewport-size))
+ (hscrollbar (obtain-horizontal-scrollbar window))
+ (vscrollbar (obtain-vertical-scrollbar window))
(origin (slot-value (dispatcher window) 'viewport-origin))
(saved-x (gfs:point-x origin))
(saved-y (gfs:point-y origin))
- (delta-x (- (+ (gfs:size-width viewport-size) (gfs:point-x origin)) (gfs:size-width top-size)))
- (delta-y (- (+ (gfs:size-height viewport-size) (gfs:point-y origin)) (gfs:size-height top-size))))
- (if (and (> delta-x 0) (> (gfs:point-x origin) 0))
- (setf (gfs:point-x origin) (max 0 (- (gfs:point-x origin) delta-x)))
+ (delta-x (- (+ (gfs:size-width viewport-size) saved-x)
+ (gfs:span-end (outer-limits hscrollbar))))
+ (delta-y (- (+ (gfs:size-height viewport-size) saved-y)
+ (gfs:span-end (outer-limits vscrollbar)))))
+ (if (and (> delta-x 0) (> saved-x 0))
+ (setf (gfs:point-x origin) (max 0 (- saved-x delta-x)))
(setf delta-x 0))
- (if (and (> delta-y 0) (> (gfs:point-y origin) 0))
- (setf (gfs:point-y origin) (max 0 (- (gfs:point-y origin) delta-y)))
+ (if (and (> delta-y 0) (> saved-y 0))
+ (setf (gfs:point-y origin) (max 0 (- saved-y delta-y)))
(setf delta-y 0))
(if (or (and (zerop (gfs:point-x origin)) (/= saved-x 0))
(and (zerop (gfs:point-y origin)) (/= saved-y 0)))
@@ -137,13 +134,21 @@
(defmethod event-pre-resize ((disp scrolling-event-dispatcher) (window window) rect type)
(declare (ignore type))
- (let ((h-step (gfs:size-width (step-increments disp)))
- (v-step (gfs:size-height (step-increments disp)))
- (size (gfs:size rect)))
+ (let* ((h-step (gfs:size-width (step-increments disp)))
+ (v-step (gfs:size-height (step-increments disp)))
+ (outer-size (gfw:size window))
+ (client-size (gfw:client-size window))
+ (width-diff (- (gfs:size-width outer-size) (gfs:size-width client-size)))
+ (height-diff (- (gfs:size-height outer-size) (gfs:size-height client-size)))
+ (size (gfs:size rect)))
(if (/= h-step 1)
- (setf (gfs:size-width size) (* (floor (gfs:size-width size) h-step) h-step)))
+ (setf (gfs:size-width size)
+ (+ (* (floor (- (gfs:size-width size) width-diff) h-step) h-step)
+ width-diff)))
(if (/= v-step 1)
- (setf (gfs:size-height size) (* (floor (gfs:size-height size) v-step) v-step)))
+ (setf (gfs:size-height size)
+ (+ (* (floor (- (gfs:size-height size) height-diff) v-step) v-step)
+ height-diff)))
(setf (gfs:size rect) size)))
(defmethod event-resize ((disp scrolling-event-dispatcher) (window window) size type)
More information about the Graphic-forms-cvs
mailing list