Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv6218
Modified Files: input.lisp panes.lisp Log Message: Move scroll wheel code to panes.lisp, since it has nothing to do with event queues.
--- /project/mcclim/cvsroot/mcclim/input.lisp 2006/07/08 16:58:36 1.36 +++ /project/mcclim/cvsroot/mcclim/input.lisp 2006/07/09 06:23:22 1.37 @@ -521,42 +521,3 @@
(defclass clim-sheet-input-mixin (standard-sheet-input-mixin) ()) - -;;; Mixin for panes which want the mouse wheel to scroll vertically - -(defclass mouse-wheel-scroll-mixin () ()) - -(defparameter *mouse-scroll-distance* 4 - "Number of lines by which to scroll the window in response to the scroll wheel") - -(defgeneric scroll-quantum (pane) - (:documentation "Returns the number of pixels respresenting a 'line', used -to computed distance to scroll in response to mouse wheel events.")) - -(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)) - (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 --- /project/mcclim/cvsroot/mcclim/panes.lisp 2006/03/29 10:43:37 1.169 +++ /project/mcclim/cvsroot/mcclim/panes.lisp 2006/07/09 06:23:22 1.170 @@ -27,7 +27,7 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA.
-;;; $Id: panes.lisp,v 1.169 2006/03/29 10:43:37 tmoore Exp $ +;;; $Id: panes.lisp,v 1.170 2006/07/09 06:23:22 ahefner Exp $
(in-package :clim-internals)
@@ -2326,6 +2326,44 @@
(defgeneric* (setf window-viewport-position) (x y clim-stream-pane))
+;;; Mixin for panes which want the mouse wheel to scroll vertically + +(defclass mouse-wheel-scroll-mixin () ()) + +(defparameter *mouse-scroll-distance* 4 + "Number of lines by which to scroll the window in response to the scroll wheel") + +(defgeneric scroll-quantum (pane) + (:documentation "Returns the number of pixels respresenting a 'line', used +to computed distance to scroll in response to mouse wheel events.")) + +(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)) + (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
;;; ;;; 29.4 CLIM Stream Panes