[mcclim-cvs] CVS update: mcclim/input.lisp

[Clemens Fruhwirth]

Update of /project/mcclim/cvsroot/mcclim
In directory common-lisp.net:/tmp/cvs-serv7567

Modified Files:
	input.lisp 
Log Message:
Rewrite dispatch-event for mouse-wheel-scroll-mixin to work with left
and right scrolling wheel buttons.

Date: Fri Jan 13 17:51:03 2006
Author: cfruhwirth

Index: mcclim/input.lisp
diff -u mcclim/input.lisp:1.33 mcclim/input.lisp:1.34
--- mcclim/input.lisp:1.33	Fri Jul  1 14:59:39 2005
+++ mcclim/input.lisp	Fri Jan 13 17:51:03 2006
@@ -535,23 +535,28 @@
 
 (defmethod scroll-quantum (pane) 10)
 
+(defun scroll-sheet (sheet vertical horizontal)
+  (with-bounding-rectangle* (vx0 vy0 vx1 vy1) (pane-viewport-region sheet)
+    (with-bounding-rectangle* (sx0 sy0 sx1 sy1) (sheet-region sheet)
+      (let ((viewport-height (- vy1 vy0))
+	    (viewport-width  (- vx1 vx0))
+	    (delta (* *mouse-scroll-distance*
+		      (scroll-quantum sheet))))
+	;; The coordinates (x,y) of the new upper-left corner of the viewport
+	;; must be "sx0 < x < sx1 - viewport-width"  and
+	;;         "sy0 < y < sy1 - viewport-height"	
+	(scroll-extent sheet
+		       (max sx0 (min (- sx1 viewport-width)  (+ vx0 (* delta horizontal))))
+		       (max sy0 (min (- sy1 viewport-height) (+ vy0 (* delta vertical)))))))))
+
 (defmethod dispatch-event :around ((sheet mouse-wheel-scroll-mixin)
                                    (event pointer-button-press-event))
-  (let ((viewport (pane-viewport sheet))
-        (button (pointer-event-button event))
-        (dy (* *mouse-scroll-distance*
-               (scroll-quantum sheet))))
-    (if (and viewport
-             (or (eql button +pointer-wheel-up+)
-                 (eql button +pointer-wheel-down+)))
-        (multiple-value-bind (x0 y0 x1 y1)
-            (bounding-rectangle* (pane-viewport-region sheet))
-          (declare (ignore x1))
-          (multiple-value-bind (sx0 sy0 sx1 sy1)
-              (bounding-rectangle* (sheet-region sheet))
-            (declare (ignore sx0 sx1))
-            (let ((height (- y1 y0)))
-              (scroll-extent sheet x0 (if (eql button +pointer-wheel-up+)
-                                          (max sy0 (- y0 dy))
-                                          (- (min sy1 (+ y1 dy)) height))))))
-        (call-next-method))))
\ No newline at end of file
+  (if (pane-viewport sheet)
+      (let ((button (pointer-event-button event)))
+	(cond
+	 ((eq button +pointer-wheel-up+)    (scroll-sheet sheet -1  0))
+	 ((eq button +pointer-wheel-down+)  (scroll-sheet sheet  1  0))
+	 ((eq button +pointer-wheel-left+)  (scroll-sheet sheet  0 -1))
+	 ((eq button +pointer-wheel-right+) (scroll-sheet sheet  0  1))
+	 (t (call-next-method))))      ; not a scroll wheel button
+    (call-next-method))))              ; no viewport