;;; mouse-wheel.el --- just a reinvention of the wheel

;; Copyright (C) 2003 Katsumi Yamaoka

;; Author: Katsumi Yamaoka <yamaoka@jpl.org>
;; Created: 2003/04/22

;; This program 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 program 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 this program; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.

;;; Commentary:

;;; Code:

(defvar mouse-wheel-move-lines 4
  "*Number of lines moving by the mouse wheel.")

(eval-when-compile
  (defmacro mouse-wheel-event-window (event)
    "Return the window over which mouse event EVENT occurred."
    (if (featurep 'xemacs)
	(list 'event-window event)
      (list 'posn-window (list 'event-end event)))))

(defun mouse-wheel-next-line (event &optional prev)
  "Move cursor vertically down using the mouse wheel.
The value of `mouse-wheel-move-lines' is used for the moving step."
  (interactive "e")
  (if (not (memq last-command '(next-line
				previous-line
				mouse-wheel-next-line
				mouse-wheel-prev-line
				mouse-wheel-next-page
				mouse-wheel-prev-page)))
      (setq temporary-goal-column (current-column)))
  (let ((window (mouse-wheel-event-window event)))
    (raise-frame (window-frame window))
    (select-window window))
  (if prev
      (forward-line (- mouse-wheel-move-lines))
    (forward-line mouse-wheel-move-lines)
    (if (eobp)
	(forward-line -1)))
  (move-to-column temporary-goal-column))

(defun mouse-wheel-prev-line (event)
  "Move cursor vertically up using the mouse wheel.
The value of `mouse-wheel-move-lines' is used for the moving step."
  (interactive "e")
  (mouse-wheel-next-line event t))

(defun mouse-wheel-next-page (event &optional prev)
  "Scroll text of current window down one page using the mouse wheel."
  (interactive "e")
  (if (not (memq last-command '(next-line
				previous-line
				mouse-wheel-next-line
				mouse-wheel-prev-line
				mouse-wheel-next-page
				mouse-wheel-prev-page)))
      (setq temporary-goal-column (current-column)))
  (let ((window (mouse-wheel-event-window event)))
    (raise-frame (window-frame window))
    (select-window window)
    (if prev
	(let (pos)
	  (move-to-window-line 0)
	  (move-to-column temporary-goal-column)
	  (setq pos (point))
	  (forward-line (min (- 3 (window-height)) 0))
	  (set-window-start window (point))
	  (goto-char pos))
      (if (pos-visible-in-window-p (point-max))
	  (progn
	    (goto-char (point-max))
	    (if (bolp)
		(forward-line -1)))
	(move-to-window-line -1)
	(beginning-of-line)
	(set-window-start window (point)))
      (move-to-column temporary-goal-column))))

(defun mouse-wheel-prev-page (event)
  "Scroll text of current window up one page using the mouse wheel."
  (interactive "e")
  (mouse-wheel-next-page event t))

(if (featurep 'xemacs)
    (progn
      (define-key global-map [button4] 'mouse-wheel-prev-line)
      (define-key global-map [button5] 'mouse-wheel-next-line)
      (define-key global-map [(shift button4)] 'mouse-wheel-prev-page)
      (define-key global-map [(shift button5)] 'mouse-wheel-next-page))
  (define-key global-map [mouse-4] 'mouse-wheel-prev-line)
  (define-key global-map [mouse-5] 'mouse-wheel-next-line)
  (define-key global-map [(shift mouse-4)] 'mouse-wheel-prev-page)
  (define-key global-map [(shift mouse-5)] 'mouse-wheel-next-page))

(provide 'mouse-wheel)

;;; mouse-wheel.el ends here