/[mcclim]/mcclim/input.lisp
ViewVC logotype

Diff of /mcclim/input.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.29 by moore, Mon Feb 23 10:48:28 2004 UTC revision 1.30 by hefner1, Sun Mar 21 21:49:06 2004 UTC
# Line 517  Line 517 
517    
518  (defclass clim-sheet-input-mixin (#+clim-mp standard-sheet-input-mixin #-clim-mp immediate-sheet-input-mixin)  (defclass clim-sheet-input-mixin (#+clim-mp standard-sheet-input-mixin #-clim-mp immediate-sheet-input-mixin)
519    ())    ())
520    
521    ;;; Mixin for panes which want the mouse wheel to scroll vertically
522    
523    (defclass mouse-wheel-scroll-mixin () ())
524    
525    (defparameter *mouse-scroll-distance* 4
526      "Number of lines by which to scroll the window in response to the scroll wheel")
527    
528    (defmethod dispatch-event :around ((sheet mouse-wheel-scroll-mixin)
529                                       (event pointer-button-press-event))
530      (let ((viewport (pane-viewport sheet))
531            (button (pointer-event-button event))
532            (dy (* *mouse-scroll-distance*
533                   (stream-line-height sheet))))
534        (if (and viewport
535                 (or (eql button +pointer-wheel-up+)
536                     (eql button +pointer-wheel-down+)))
537            (multiple-value-bind (x0 y0 x1 y1)
538                (bounding-rectangle* (pane-viewport-region sheet))
539              (declare (ignore x1))
540              (multiple-value-bind (sx0 sy0 sx1 sy1)
541                  (bounding-rectangle* (sheet-region sheet))
542                (declare (ignore sx0 sx1))
543                (let ((height (- y1 y0)))
544                  (scroll-extent sheet x0 (if (eql button +pointer-wheel-up+)
545                                              (max sy0 (- y0 dy))
546                                              (- (min sy1 (+ y1 dy)) height))))))
547            (call-next-method))))

Legend:
Removed from v.1.29  
changed lines
  Added in v.1.30

  ViewVC Help
Powered by ViewVC 1.1.5