;;; wheel.el --- Configuration of the mouse wheel

;; Copyright (C) 2000, 2001 Stéphane Levant <sun@tuxfamily.org>

;; Author: Stéphane Levant <sun@tuxfamily.org>
;; Created: 2000
;; Keywords:  mouse
;; URL: http://arsunik.free.fr/emacs

(defconst wheel-version "1.3")

;; 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:

;; Sets actions for the up and down buttons of wheel mice.
;; Actions that can de associated with the wheel are :
;; scroll page, half page, 3 lines (customizable), 10 lines (customizable).
;; A switch buffer action and a change font action are also provided
;; if the functions `buffer-select+' and `font-select+' are defined.
;; Everything can be configured with a fun customize buffer in the mouse
;; section.

;; INSTALL: Just adds this line to your .emacs :
;; (require 'wheel)

;; Example of manual configuration:
;; (custom-set-variables
;;  '(setq wheel-nb-line 3)
;;  '(setq wheel-nb-line-2 10)
;;  '(wheel-action (quote line))
;;  '(wheel-action-control (quote half-page))
;;  '(wheel-action-meta (quote line-2))
;;  '(wheel-action-shift (quote none)))
;; (require 'wheel)

;; A funny exemple:
;; (custom-set-variables
;;  '(setq wheel-nb-line 3)
;;  '(wheel-action (quote line))
;;  '(wheel-action-control (quote font-select))
;;  '(wheel-action-meta (quote switch-buffer))
;;  '(wheel-action-shift (quote page)))
;; (require 'wheel)


;; See `wheel-choice' to have all available choices.

;; Thanks go to:
;;   * Jean-Marc Saffroy, for correction of the documentation;
;;   * Laurent Schurter, for useful corrections.

;; TODO: Allow user functions with a list

;;; Code:

(defun wheel-set-action (variable action-name)
  (set variable action-name)
  (let ((key1 (cdr (assq variable
    '((wheel-action         . [(mouse-4)])
      (wheel-action-control . [(control mouse-4)])
      (wheel-action-shift   . [(shift mouse-4)])
      (wheel-action-meta    . [(meta mouse-4)])))))
 (key2 (cdr (assq variable
    '((wheel-action         . [(mouse-5)])
      (wheel-action-control . [(control mouse-5)])
      (wheel-action-shift   . [(shift mouse-5)])
      (wheel-action-meta    . [(meta mouse-5)]))))))
    (cond
     ((eq action-name 'none))
     ((eq action-name 'page)
      (global-set-key key1 'wheel-scroll-down)
      (global-set-key key2 'wheel-scroll-up))
     ((eq action-name 'half-page)
      (global-set-key key1 'wheel-scroll-half-down)
      (global-set-key key2 'wheel-scroll-half-up))
     ((eq action-name 'line)
      (global-set-key key1 'wheel-previous-line)
      (global-set-key key2 'wheel-next-line))
     ((eq action-name 'line-2)
      (global-set-key key1 'wheel-previous-line-2)
      (global-set-key key2 'wheel-next-line-2))
     ((eq action-name 'font-select)
      (global-set-key key1 'font-select-)
      (global-set-key key2 'font-select+))
     ((eq action-name 'switch-buffer)
      (global-set-key key1 'wheel-buffer-select-)
      (global-set-key key2 'wheel-buffer-select+)))))

(defvar wheel-choice
  '(choice
    (const :tag "None" none)
    (const :tag "Move X lines (default : 3)" line)
    (const :tag "Move X lines (default : 10)" line-2)
    (const :tag "Move half page" half-page)
    (const :tag "Move page" page)
    (const :tag "Switch buffers" switch-buffer)
    (const :tag "Change font size" font-select)))

(defgroup wheel nil
  "*Set actions for the up and down buttons of wheel mice."
  :prefix "wheel-"
  :group 'mouse)

(defcustom wheel-nb-line 3
  "*Number of lines to move for the functions `wheel-previous-line' and
`wheel-next-line'"
  :type 'integer
  :group 'wheel)


(defcustom wheel-nb-line-2 10
  "*Number of lines to move for the functions `wheel-previous-line-2' and
`wheel-next-line-2'"
  :type 'integer
  :group 'wheel)

(defcustom wheel-action 'line
  "*Set the default action for the wheel."
  :type wheel-choice
  :set 'wheel-set-action
  :group 'wheel)

(defcustom wheel-action-control 'font-select
  "*Set the action for the wheel with control key held down."
  :type wheel-choice
  :set 'wheel-set-action
  :group 'wheel)

(defcustom wheel-action-meta 'switch-buffer
  "*Set the action for the wheel with meta key held down."
  :type wheel-choice
  :set 'wheel-set-action
  :group 'wheel)

(defcustom wheel-action-shift 'page
  "*Set the action for the wheel with shift key held down."
  :type wheel-choice
  :set 'wheel-set-action
  :group 'wheel)

(defmacro wheel-action (event &rest command)
  "Select the window where the pointer is and execute the command."
  `(let ((w (selected-window)))
     (select-window (posn-window (event-end ,event)))
     (set-buffer (window-buffer (posn-window (event-end ,event))))
     (condition-case ()
  (progn
    ,@command)
       (error nil))
     (select-window w)))

(defun wheel-scroll-down (event)
  "Scroll one page down."
  (interactive "e")
  (wheel-action event (scroll-down)))

(defun wheel-scroll-up (event)
  "Scroll one page up."
  (interactive "e")
  (wheel-action event (scroll-up)))

(defun wheel-scroll-half-down (event)
  "Scroll one half page down."
  (interactive "e")
  (wheel-action event
  (scroll-down (/ (1- (window-height)) 2))
  (previous-line (/ (1- (window-height)) 2))))

(defun wheel-scroll-half-up (event)
  "Scroll one half page up."
  (interactive "e")
  (wheel-action event
  (scroll-up (/ (1- (window-height)) 2))
  (next-line (/ (1- (window-height)) 2))))

(defun wheel-previous-line (event)
  "Scroll `wheel-nb-line' lines down."
  (interactive "e")
  (wheel-action event
  (scroll-down wheel-nb-line)
  (previous-line wheel-nb-line)))

(defun wheel-next-line (event)
  "Scroll `wheel-nb-line' lines up."
  (interactive "e")
  (wheel-action event
  (scroll-up wheel-nb-line)
  (next-line wheel-nb-line)))

(defun wheel-previous-line-2 (event)
  "Scroll `wheel-nb-line-2' lines down."
  (interactive "e")
  (wheel-action event
  (scroll-down wheel-nb-line-2)
  (previous-line wheel-nb-line-2)))

(defun wheel-next-line-2 (event)
  "Scroll `wheel-nb-line-2' lines up."
  (interactive "e")
  (wheel-action event
  (scroll-up wheel-nb-line-2)
  (next-line wheel-nb-line-2)))

(defun wheel-buffer-select+ (event)
  "Execute `buffer-select+' if this function is defined..."
  (interactive "e")
  (wheel-action event (buffer-select+)))

(defun wheel-buffer-select- (event)
  "Execute `buffer-select-' if this function is defined..."
  (interactive "e")
  (wheel-action event (buffer-select-)))

(defun  wheel-customize ()
  "Customize the actions associed with the wheel mouse"
  (interactive)
  (customize-group 'wheel))

(provide 'wheel)
;;; wheel.el ends here