(require 'mouse)
(defun scroll-bar-event-ratio (event)
"Given a scroll bar event EVENT, return the scroll bar position as a ratio.
The value is a cons cell (PORTION . WHOLE) containing two integers
whose ratio gives the event's vertical position in the scroll bar, with 0
referring to the top and 1 to the bottom."
(nth 2 event))
(defun scroll-bar-scale (num-denom whole)
"Given a pair (NUM . DENOM) and WHOLE, return (/ (* NUM WHOLE) DENOM).
This is handy for scaling a position on a scroll bar into real units,
like buffer positions. If SCROLL-BAR-POS is the (PORTION . WHOLE) pair
from a scroll bar event, then (scroll-bar-scale SCROLL-BAR-POS
\(buffer-size)) is the position in the current buffer corresponding to
that scroll bar position."
(truncate (/ (* (float (car num-denom)) whole) (cdr num-denom))))
(defun scroll-bar-columns (side)
"Return the width, measured in columns, of the vertical scrollbar on SIDE.
SIDE must be the symbol `left' or `right'."
(let* ((wsb (window-scroll-bars))
(vtype (nth 2 wsb))
(cols (nth 1 wsb)))
(cond
((not (memq side '(left right)))
(error "`left' or `right' expected instead of %S" side))
((and (eq vtype side) cols))
((eq (frame-parameter nil 'vertical-scroll-bars) side)
(ceiling (or (frame-parameter nil 'scroll-bar-width) 14)
(frame-char-width)))
(0))))
(defvar scroll-bar-mode)
(defvar previous-scroll-bar-mode nil)
(defvar scroll-bar-mode-explicit nil
"Non-nil means `set-scroll-bar-mode' should really do something.
This is nil while loading `scroll-bar.el', and t afterward.")
(defun set-scroll-bar-mode-1 (ignore value)
(set-scroll-bar-mode value))
(defun set-scroll-bar-mode (value)
"Set `scroll-bar-mode' to VALUE and put the new value into effect."
(if scroll-bar-mode
(setq previous-scroll-bar-mode scroll-bar-mode))
(setq scroll-bar-mode value)
(when scroll-bar-mode-explicit
(let ((parameter (assq 'vertical-scroll-bars default-frame-alist)))
(if (consp parameter)
(setcdr parameter scroll-bar-mode)
(setq default-frame-alist
(cons (cons 'vertical-scroll-bars scroll-bar-mode)
default-frame-alist))))
(let ((frames (frame-list)))
(while frames
(modify-frame-parameters
(car frames)
(list (cons 'vertical-scroll-bars scroll-bar-mode)))
(setq frames (cdr frames))))))
(defcustom scroll-bar-mode default-frame-scroll-bars
"*Specify whether to have vertical scroll bars, and on which side.
Possible values are nil (no scroll bars), `left' (scroll bars on left)
and `right' (scroll bars on right).
To set this variable in a Lisp program, use `set-scroll-bar-mode'
to make it take real effect.
Setting the variable with a customization buffer also takes effect."
:type '(choice (const :tag "none (nil)" nil)
(const left)
(const right))
:group 'frames
:initialize 'custom-initialize-default
:set 'set-scroll-bar-mode-1)
(setq scroll-bar-mode-explicit t)
(defun scroll-bar-mode (&optional flag)
"Toggle display of vertical scroll bars on all frames.
This command applies to all frames that exist and frames to be
created in the future.
With a numeric argument, if the argument is negative,
turn off scroll bars; otherwise, turn on scroll bars."
(interactive "P")
(set-scroll-bar-mode (if (if (null flag)
(not scroll-bar-mode)
(setq flag (prefix-numeric-value flag))
(or (not (numberp flag)) (>= flag 0)))
(or previous-scroll-bar-mode
default-frame-scroll-bars))))
(defun toggle-scroll-bar (arg)
"Toggle whether or not the selected frame has vertical scroll bars.
With arg, turn vertical scroll bars on if and only if arg is positive.
The variable `scroll-bar-mode' controls which side the scroll bars are on
when they are turned on; if it is nil, they go on the left."
(interactive "P")
(if (null arg)
(setq arg
(if (cdr (assq 'vertical-scroll-bars
(frame-parameters (selected-frame))))
-1 1))
(setq arg (prefix-numeric-value arg)))
(modify-frame-parameters
(selected-frame)
(list (cons 'vertical-scroll-bars
(if (> arg 0)
(or scroll-bar-mode default-frame-scroll-bars))))))
(defun toggle-horizontal-scroll-bar (arg)
"Toggle whether or not the selected frame has horizontal scroll bars.
With arg, turn horizontal scroll bars on if and only if arg is positive.
Horizontal scroll bars aren't implemented yet."
(interactive "P")
(error "Horizontal scroll bars aren't implemented yet"))
(defun scroll-bar-set-window-start (event)
"Set the window start according to where the scroll bar is dragged.
EVENT should be a scroll bar click or drag event."
(interactive "e")
(let* ((end-position (event-end event))
(window (nth 0 end-position))
(portion-whole (nth 2 end-position)))
(save-excursion
(set-buffer (window-buffer window))
(save-excursion
(goto-char (+ (point-min)
(scroll-bar-scale portion-whole
(- (point-max) (point-min)))))
(beginning-of-line)
(set-window-start window (point))))))
(defun scroll-bar-drag-position (portion-whole)
"Calculate new window start for drag event."
(save-excursion
(goto-char (+ (point-min)
(scroll-bar-scale portion-whole
(- (point-max) (point-min)))))
(beginning-of-line)
(point)))
(defun scroll-bar-maybe-set-window-start (event)
"Set the window start according to where the scroll bar is dragged.
Only change window start if the new start is substantially different.
EVENT should be a scroll bar click or drag event."
(interactive "e")
(let* ((end-position (event-end event))
(window (nth 0 end-position))
(portion-whole (nth 2 end-position))
(next-portion-whole (cons (1+ (car portion-whole))
(cdr portion-whole)))
portion-start
next-portion-start
(current-start (window-start window)))
(save-excursion
(set-buffer (window-buffer window))
(setq portion-start (scroll-bar-drag-position portion-whole))
(setq next-portion-start (max
(scroll-bar-drag-position next-portion-whole)
(1+ portion-start)))
(if (or (>= current-start next-portion-start)
(< current-start portion-start))
(set-window-start window portion-start)
(set-window-start window current-start)))))
(defun scroll-bar-drag-1 (event)
(let* ((start-position (event-start event))
(window (nth 0 start-position))
(portion-whole (nth 2 start-position)))
(save-excursion
(set-buffer (window-buffer window))
(goto-char (+ (point-min)
(scroll-bar-scale portion-whole
(- (point-max) (point-min)))))
(vertical-motion 0 window)
(set-window-start window (point)))))
(defun scroll-bar-drag (event)
"Scroll the window by dragging the scroll bar slider.
If you click outside the slider, the window scrolls to bring the slider there."
(interactive "e")
(let* (done
(echo-keystrokes 0)
(end-position (event-end event))
(window (nth 0 end-position))
(before-scroll))
(with-current-buffer (window-buffer window)
(setq before-scroll point-before-scroll))
(save-selected-window
(select-window window)
(setq before-scroll
(or before-scroll (point))))
(scroll-bar-drag-1 event)
(track-mouse
(while (not done)
(setq event (read-event))
(if (eq (car-safe event) 'mouse-movement)
(setq event (read-event)))
(cond ((eq (car-safe event) 'scroll-bar-movement)
(scroll-bar-drag-1 event))
(t
(setq done t)))))
(sit-for 0)
(with-current-buffer (window-buffer window)
(setq point-before-scroll before-scroll))))
(defun scroll-bar-scroll-down (event)
"Scroll the window's top line down to the location of the scroll bar click.
EVENT should be a scroll bar click."
(interactive "e")
(let* ((end-position (event-end event))
(window (nth 0 end-position))
(before-scroll))
(with-current-buffer (window-buffer window)
(setq before-scroll point-before-scroll))
(unwind-protect
(save-selected-window
(let ((portion-whole (nth 2 end-position)))
(select-window window)
(setq before-scroll
(or before-scroll (point)))
(scroll-down
(scroll-bar-scale portion-whole (1- (window-height)))))
(sit-for 0))
(with-current-buffer (window-buffer window)
(setq point-before-scroll before-scroll)))))
(defun scroll-bar-scroll-up (event)
"Scroll the line next to the scroll bar click to the top of the window.
EVENT should be a scroll bar click."
(interactive "e")
(let* ((end-position (event-end event))
(window (nth 0 end-position))
(before-scroll))
(with-current-buffer (window-buffer window)
(setq before-scroll point-before-scroll))
(unwind-protect
(save-selected-window
(let ((portion-whole (nth 2 end-position)))
(select-window window)
(setq before-scroll
(or before-scroll (point)))
(scroll-up
(scroll-bar-scale portion-whole (1- (window-height)))))
(sit-for 0))
(with-current-buffer (window-buffer window)
(setq point-before-scroll before-scroll)))))
(defun scroll-bar-toolkit-scroll (event)
(interactive "e")
(let* ((end-position (event-end event))
(window (nth 0 end-position))
(part (nth 4 end-position))
before-scroll)
(cond ((eq part 'end-scroll))
(t
(with-current-buffer (window-buffer window)
(setq before-scroll point-before-scroll))
(save-selected-window
(select-window window)
(setq before-scroll (or before-scroll (point)))
(cond ((eq part 'above-handle)
(scroll-up '-))
((eq part 'below-handle)
(scroll-up nil))
((eq part 'ratio)
(let* ((portion-whole (nth 2 end-position))
(lines (scroll-bar-scale portion-whole
(1- (window-height)))))
(scroll-up (cond ((not (zerop lines)) lines)
((< (car portion-whole) 0) -1)
(t 1)))))
((eq part 'up)
(scroll-up -1))
((eq part 'down)
(scroll-up 1))
((eq part 'top)
(set-window-start window (point-min)))
((eq part 'bottom)
(goto-char (point-max))
(recenter))
((eq part 'handle)
(scroll-bar-drag-1 event))))
(sit-for 0)
(with-current-buffer (window-buffer window)
(setq point-before-scroll before-scroll))))))
(cond ((and (boundp 'x-toolkit-scroll-bars) x-toolkit-scroll-bars)
(global-set-key [vertical-scroll-bar mouse-1]
'scroll-bar-toolkit-scroll))
(t
(global-set-key [vertical-scroll-bar mouse-1]
'scroll-bar-scroll-up)
(global-set-key [vertical-scroll-bar drag-mouse-1]
'scroll-bar-scroll-up)
(global-set-key [vertical-scroll-bar down-mouse-2]
'scroll-bar-drag)
(global-set-key [vertical-scroll-bar mouse-3]
'scroll-bar-scroll-down)
(global-set-key [vertical-scroll-bar drag-mouse-3]
'scroll-bar-scroll-down)))
(provide 'scroll-bar)