kon-mwheel.el 1.5 --- accelerating mouse wheel commands

[Kalle Olavi Niemitalo]

;;; kon-mwheel.el --- accelerating mouse wheel commands

;; Copyright (C) 2001 by Kalle Olavi Niemitalo

;; Author: Kalle Olavi Niemitalo <address@hidden>
;; Keywords: mouse, local

;; $Id: kon-mwheel.el,v 1.5 2001/05/15 07:22:05 kalle Exp $

;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; Commentary:

;; No matter how I set the scrolling rate of the mouse wheel, it
;; always seemed either too slow or too fast.  So this code sets the
;; rate dynamically, based on how fast I turn the wheel.  Tries to,
;; anyway.

;; To start it up, call `kon-mwheel-bind-buttons'.

;; TO DO:
;; * Port to XEmacs.
;; * Support sideways scrolling with another wheel.
;; * Clear the timestamp ring if the wheel changes direction.

;;; Code:

(eval-when-compile (require 'cl))

(defgroup kon-mwheel '()
  "Accelerating mouse wheel."
  :group 'mouse)

(defcustom kon-mwheel-scroll-selected-window nil
  "If non-nil, the mouse wheel scrolls the selected window.
If nil, the mouse wheel scrolls the window at the mouse cursor."
  :type '(choice (const :tag "At mouse cursor" nil)
                 (other :tag "Selected window" t))
  :group 'kon-mwheel)

(defcustom kon-mwheel-timeout 200
  "How many milliseconds of mouse events to remember."
  :type 'integer
  :group 'kon-mwheel)

(defcustom kon-mwheel-acceleration [1 1 2 3 5 8 13 21 34 55 89 144 233 377 610
                                    987 1597 2584 4181 6765 10946 17711 28657]
  "Vector mapping number of wheel events to number of lines scrolled.
The first element of the vector is how many lines to scroll if there have
been no mouse wheel events during the last `kon-mwheel-timeout' milliseconds,
the second element is for one event, and so on.  If the vector is too short,
`kon-mwheel-scroll' uses the last element.

It is not useful to make this vector longer than `kon-mwheel-timestamp-ring'."
  :type '(vector (repeat :inline t integer))
  :group 'kon-mwheel)

(defvar kon-mwheel-timestamp-ring (make-ring 50)
  "The time stamps of recent mouse wheel events.")

(defun kon-mwheel-count-events (stamp)
  "Return how many mouse wheel events occurred since STAMP."
  (loop for index upfrom 0 below (ring-length kon-mwheel-timestamp-ring)
        ;; Timestamps wrap around sometimes so use clock arithmetic.
        while (>= (- (ring-ref kon-mwheel-timestamp-ring index) stamp) 0)
        count t))

(defun kon-mwheel-scroll (event direction)
  "Scroll the window by some number of lines.
Compute the distance based on the time stamp of EVENT.
DIRECTION is +1 for up and -1 for down."
  (let* ((now (posn-timestamp (event-start event)))
         (events (kon-mwheel-count-events (- now kon-mwheel-timeout)))
         (distance (aref kon-mwheel-acceleration
                         (min events (1- (length kon-mwheel-acceleration))))))
    (ring-insert kon-mwheel-timestamp-ring now)
    (save-selected-window
      (unless kon-mwheel-scroll-selected-window
        (select-window (posn-window (event-start event))))
      (scroll-up (* direction distance)))))

;;;###autoload
(defun kon-mwheel-scroll-up (event)
  "Scroll the window up by some number of lines.
See `kon-mwheel-acceleration'."
  (interactive "e")
  (kon-mwheel-scroll event +1))

;;;###autoload
(defun kon-mwheel-scroll-down (event)
  "Scroll the window down by some number of lines.
See `kon-mwheel-acceleration'."
  (interactive "e")
  (kon-mwheel-scroll event -1))

;;;###autoload
(defun kon-mwheel-bind-buttons ()
  "Bind mouse-4 and mouse-5 to kon-mwheel functions."
  (global-set-key (kbd "<mouse-4>") 'kon-mwheel-scroll-down)
  (global-set-key (kbd "<mouse-5>") 'kon-mwheel-scroll-up))

(provide 'kon-mwheel)

;;; kon-mwheel.el ends here