-;; Mouse support that is independent of window systems.
-;; Copyright (C) 1988 Free Software Foundation, Inc.
+;;; mouse.el --- window system-independent mouse support.
-;; This file is part of GNU Emacs.
+;;; Copyright (C) 1988, 1992 Free Software Foundation, Inc.
-;; GNU Emacs 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 1, or (at your option)
-;; any later version.
+;; Maintainer: FSF
+;; Keywords: hardware
-;; GNU Emacs 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.
+;;; This file is part of GNU Emacs.
-;; 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+;;; GNU Emacs 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.
-(provide 'mouse)
+;;; GNU Emacs 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, 675 Mass Ave, Cambridge, MA 02139, USA.
\f
-(defun mouse-select ()
- "Select the Emacs window the mouse is on."
- (interactive "@"))
+;;; Utility functions.
+
+(defsubst mouse-movement-p (object)
+ "Return non-nil if OBJECT is a mouse movement event."
+ (and (consp object)
+ (eq (car object) 'mouse-movement)))
+
+(defsubst event-start (event)
+ "Return the starting position of EVENT.
+If EVENT is a mouse press or a mouse click, this returns the location
+of the event.
+If EVENT is a drag, this returns the drag's starting position.
+The return value is of the form
+ (WINDOW BUFFER-POSITION (COL . ROW) TIMESTAMP)
+The `posn-' functions access elements of such lists."
+ (nth 1 event))
+
+(defsubst event-end (event)
+ "Return the ending location of EVENT. EVENT should be a drag event.
+The return value is of the form
+ (WINDOW BUFFER-POSITION (COL . ROW) TIMESTAMP)
+The `posn-' functions access elements of such lists."
+ (nth 2 event))
+
+(defsubst posn-window (position)
+ "Return the window in POSITION.
+POSITION should be a list of the form
+ (WINDOW BUFFER-POSITION (COL . ROW) TIMESTAMP)
+as returned by the `event-start' and `event-end' functions."
+ (nth 0 position))
+
+(defsubst posn-point (position)
+ "Return the buffer location in POSITION.
+POSITION should be a list of the form
+ (WINDOW BUFFER-POSITION (COL . ROW) TIMESTAMP)
+as returned by the `event-start' and `event-end' functions."
+ (nth 1 position))
+
+(defsubst posn-col-row (position)
+ "Return the row and column in POSITION.
+POSITION should be a list of the form
+ (WINDOW BUFFER-POSITION (COL . ROW) TIMESTAMP)
+as returned by the `event-start' and `event-end' functions."
+ (nth 2 position))
+
+(defsubst posn-timestamp (position)
+ "Return the timestamp of POSITION.
+POSITION should be a list of the form
+ (WINDOW BUFFER-POSITION (COL . ROW) TIMESTAMP)
+nas returned by the `event-start' and `event-end' functions."
+ (nth 3 position))
+
+;;; Indent track-mouse like progn.
+(put 'track-mouse 'lisp-indent-function 0)
-(defun mouse-delete-window ()
- "Delete the Emacs window the mouse is on."
- (interactive "@")
- (delete-window))
+\f
+(defun mouse-delete-window (click)
+ "Delete the window you click on.
+This must be bound to a mouse click."
+ (interactive "e")
+ (delete-window (posn-window (event-start click))))
-(defun mouse-keep-one-window ()
- "Select Emacs window mouse is on, then kill all other Emacs windows."
+(defun mouse-tear-off-window (click)
+ "Delete the window clicked on, and create a new frame displaying its buffer."
+ (interactive "e")
+ (let* ((window (posn-window (event-start click)))
+ (buf (window-buffer window))
+ (frame (new-frame)))
+ (select-frame frame)
+ (switch-to-buffer buf)
+ (delete-window window)))
+
+(defun mouse-delete-other-windows ()
+ "Delete all window except the one you click on."
(interactive "@")
(delete-other-windows))
-(defun mouse-select-and-split ()
- "Select Emacs window mouse is on, then split it vertically in half."
- (interactive "@")
- (split-window-vertically nil))
-
-(defun mouse-set-point (event)
- "Select Emacs window mouse is on, and move point to mouse position."
+(defun mouse-split-window-vertically (click)
+ "Select Emacs window mouse is on, then split it vertically in half.
+The window is split at the line clicked on.
+This command must be bound to a mouse click."
(interactive "@e")
- (let ((relative-coordinate
- (coordinates-in-window-p (car event) (selected-window))))
- (if (consp relative-coordinate)
- (progn
- (move-to-window-line (car (cdr relative-coordinate)))
- ;; Note that hscroll must get above 1
- ;; before the text actually starts to move.
- (move-to-column (+ (car relative-coordinate) (current-column)
- (1- (max 1 (window-hscroll (selected-window))))))
- (what-line)))))
-
-(defun mouse-eval-last-sexpr (event)
+ (let ((start (event-start click)))
+ (select-window (posn-window start))
+ (split-window-vertically (1+ (cdr (posn-col-row click))))))
+
+(defun mouse-split-window-horizontally (click)
+ "Select Emacs window mouse is on, then split it horizontally in half.
+The window is split at the column clicked on.
+This command must be bound to a mouse click."
(interactive "@e")
- (save-excursion
- (mouse-set-point event)
- (eval-last-sexp nil)))
+ (split-window-horizontally (1+ (car (mouse-coords click)))))
-(defun mouse-line-length (event)
- "Print the length of the line indicated by the pointer."
- (interactive "@e")
- (let ((relative-coordinate
- (coordinates-in-window-p (car event) (selected-window))))
- (if (consp relative-coordinate)
- (save-excursion
- (move-to-window-line (car (cdr relative-coordinate)))
- (end-of-line)
- (push-mark nil t)
- (beginning-of-line)
- (message "Line length: %d"
- (- (region-end) (region-beginning)))
- (sleep-for 1)))))
-
-(defun mouse-set-mark (event)
- "Select Emacs window mouse is on, and set mark at mouse position.
-Display cursor at that position for a second."
- (interactive "@e")
+(defun mouse-set-point (click)
+ "Move point to the position clicked on with the mouse.
+This must be bound to a mouse click."
+ (interactive "e")
+ (let ((posn (event-start click)))
+ (select-window (posn-window posn))
+ (if (numberp (posn-point posn))
+ (goto-char (posn-point posn)))))
+
+(defun mouse-set-region (click)
+ "Set the region to the text that the mouse is dragged over.
+This must be bound to a mouse click."
+ (interactive "e")
+ (let ((posn (event-start click))
+ (end (event-end click)))
+ (select-window (posn-window posn))
+ (if (numberp (posn-point posn))
+ (goto-char (posn-point posn)))
+ (sit-for 1)
+ (push-mark)
+ (if (numberp (posn-point end))
+ (goto-char (posn-point end)))))
+
+(defun mouse-set-mark (click)
+ "Set mark at the position clicked on with the mouse.
+Display cursor at that position for a second.
+This must be bound to a mouse click."
+ (interactive "e")
(let ((point-save (point)))
(unwind-protect
- (progn (mouse-set-point event)
+ (progn (mouse-set-point click)
(push-mark nil t)
(sit-for 1))
(goto-char point-save))))
-(defun mouse-fill-paragraph (event)
- "Fill the paragraph at the mouse position."
- (interactive "@e")
- (save-excursion
- (mouse-set-point event)
- (fill-paragraph)))
-
-(defun mouse-fill-paragraph-with-prefix (event)
- "Fill the paragraph at the mouse position with specified fill prefix.
-Click at the end of the fill prefix that you want;
-The text before the mouse position, on the same line, is used as the prefix."
- (interactive "@e")
- (save-excursion
- (mouse-set-point event)
- (let ((fill-prefix (buffer-substring (save-excursion (beginning-of-line)
- (point))
- (point))))
- (fill-paragraph))))
-
-(defun mouse-scroll (event)
- "Scroll point to the mouse position."
- (interactive "@e")
- (let ((relative-coordinate
- (coordinates-in-window-p (car event) (selected-window))))
- (if (consp relative-coordinate)
- (progn
- (recenter (car (cdr relative-coordinate)))
- (scroll-right (+ (car relative-coordinate) (current-column)))))))
-
-(defun mouse-del-char (event)
- "Delete the char pointed to by the mouse."
- (interactive "@e")
- (let ((relative-coordinate
- (coordinates-in-window-p (car event) (selected-window))))
- (if (consp relative-coordinate)
- (progn
- (move-to-window-line (car (cdr relative-coordinate)))
- (move-to-column (+ (car relative-coordinate) (current-column)))
- (delete-char 1 nil)))))
-
-(defun mouse-kill-line (event)
- "Kill the line pointed to by the mouse."
- (interactive "@e")
- (let ((relative-coordinate
- (coordinates-in-window-p (car event) (selected-window))))
- (if (consp relative-coordinate)
- (progn
- (move-to-window-line (car (cdr relative-coordinate)))
- (move-to-column (+ (car relative-coordinate) (current-column)))
- (kill-line nil)))))
-
-(defun narrow-window-to-region (m n)
- "Narrow window to region between point and last mark"
- (interactive "r")
- (save-excursion
- (save-restriction
- (if (eq (selected-window) (next-window))
- (split-window))
- (goto-char m)
- (recenter 0)
- (if (eq (selected-window)
- (if (zerop (minibuffer-depth))
- (next-window)))
- ()
- (shrink-window (- (- (window-height) (count-lines m n)) 1))))))
-
-(defun mouse-window-to-region (event)
- "Narrow window to region between cursor and mouse pointer."
- (interactive "@e")
- (let ((point-save (point)))
- (unwind-protect
- (progn (mouse-set-point event)
- (push-mark nil t)
- (sit-for 1))
- (goto-char point-save)
- (narrow-window-to-region (region-beginning) (region-end)))))
+(defun mouse-kill (click)
+ "Kill the region between point and the mouse click.
+The text is saved in the kill ring, as with \\[kill-region]."
+ (interactive "e")
+ (let ((click-posn (event-point click)))
+ (if (numberp click-posn)
+ (kill-region (min (point) click-posn)
+ (max (point) click-posn)))))
+
+(defun mouse-yank-at-click (click arg)
+ "Insert the last stretch of killed text at the position clicked on.
+Prefix arguments are interpreted as with \\[yank]."
+ (interactive "e\nP")
+ (mouse-set-point click)
+ (yank arg))
+
+(defun mouse-kill-ring-save (click)
+ "Copy the region between point and the mouse click in the kill ring.
+This does not delete the region; it acts like \\[kill-ring-save]."
+ (interactive "e")
+ (mouse-set-mark click)
+ (call-interactively 'kill-ring-save))
-(defun mouse-ignore ()
- "Don't do anything."
- (interactive))
+(defun mouse-save-then-kill (click)
+ "Copy the region between point and the mouse click in the kill ring.
+This does not delete the region; it acts like \\[kill-ring-save]."
+ (interactive "e")
+ (mouse-set-mark click)
+ (if (string= (buffer-substring (point) (mark)) (car kill-ring))
+ ;; If this text was already saved in kill ring,
+ ;; now delete it from the buffer.
+ (progn
+ (let ((buffer-undo-list t))
+ (delete-region (point) (mark)))
+ ;; Make the undo list by hand so it is shared.
+ (setq buffer-undo-list
+ (cons (cons (car kill-ring) (point)) buffer-undo-list)))
+ ;; Otherwise, save this region.
+ (call-interactively 'kill-ring-save)))
+
+(defun mouse-buffer-menu (event)
+ "Pop up a menu of buffers for selection with the mouse."
+ (interactive "e")
+ (let ((menu
+ (list "Buffer Menu"
+ (cons "Select Buffer"
+ (let ((tail (buffer-list))
+ head)
+ (while tail
+ (let ((elt (car tail)))
+ (if (not (string-match "^ "
+ (buffer-name elt)))
+ (setq head (cons
+ (cons
+ (format
+ "%14s %s"
+ (buffer-name elt)
+ (or (buffer-file-name elt) ""))
+ elt)
+ head))))
+ (setq tail (cdr tail)))
+ (reverse head))))))
+ (switch-to-buffer (or (x-popup-menu event menu) (current-buffer)))))
\f
;; Commands for the scroll bar.
-(defun mouse-scroll-down (nlines)
- (interactive "@p")
- (scroll-down nlines))
+(defun mouse-scroll-down (click)
+ (interactive "@e")
+ (scroll-down (1+ (cdr (mouse-coords click)))))
-(defun mouse-scroll-up (nlines)
- (interactive "@p")
- (scroll-up nlines))
+(defun mouse-scroll-up (click)
+ (interactive "@e")
+ (scroll-up (1+ (cdr (mouse-coords click)))))
(defun mouse-scroll-down-full ()
(interactive "@")
(interactive "@")
(scroll-up nil))
-(defun mouse-scroll-move-cursor (nlines)
- (interactive "@p")
- (move-to-window-line nlines))
+(defun mouse-scroll-move-cursor (click)
+ (interactive "@e")
+ (move-to-window-line (1+ (cdr (mouse-coords click)))))
(defun mouse-scroll-absolute (event)
(interactive "@e")
(goto-char newpos)
(recenter '(4)))))
-(defun mouse-scroll-left (ncolumns)
- (interactive "@p")
- (scroll-left ncolumns))
+(defun mouse-scroll-left (click)
+ (interactive "@e")
+ (scroll-left (1+ (car (mouse-coords click)))))
-(defun mouse-scroll-right (ncolumns)
- (interactive "@p")
- (scroll-right ncolumns))
+(defun mouse-scroll-right (click)
+ (interactive "@e")
+ (scroll-right (1+ (car (mouse-coords click)))))
(defun mouse-scroll-left-full ()
(interactive "@")
(interactive "@")
(scroll-right nil))
-(defun mouse-scroll-move-cursor-horizontally (ncolumns)
- (interactive "@p")
- (move-to-column ncolumns))
+(defun mouse-scroll-move-cursor-horizontally (click)
+ (interactive "@e")
+ (move-to-column (1+ (car (mouse-coords click)))))
(defun mouse-scroll-absolute-horizontally (event)
(interactive "@e")
(length (car (cdr pos))))
(set-window-hscroll (selected-window) 33)))
-;; Set up these commands, including the prefix keys for the scroll bar.
-
-(fset 'mouse-vertical-scroll-bar-prefix (make-sparse-keymap))
-(define-key global-mouse-map mouse-vertical-scroll-bar-prefix
- 'mouse-vertical-scroll-bar-prefix)
-
-(defun mouse-scroll-motion (event)
- (interactive "e")
- (let ((pos (car (car event)))
- (length (car (cdr (car event)))))
- (message "[%d %d]" pos length)))
-
-(let ((map (function mouse-vertical-scroll-bar-prefix)))
- (define-key map mouse-button-right 'mouse-scroll-down)
- (define-key map mouse-button-left 'mouse-scroll-up)
- (define-key map mouse-button-middle 'mouse-scroll-absolute)
- (define-key map mouse-motion 'x-horizontal-line))
-
-;(fset 'mouse-vertical-slider-prefix (make-sparse-keymap))
-;(define-key global-mouse-map mouse-vertical-slider-prefix
-; 'mouse-vertical-slider-prefix)
-
-;(let ((map (function mouse-vertical-slider-prefix)))
-; (define-key map mouse-button-right 'mouse-scroll-move-cursor)
-; (define-key map mouse-button-left 'mouse-scroll-move-cursor)
-; (define-key map mouse-button-middle 'mouse-scroll-move-cursor))
-
-(fset 'mouse-vertical-thumbup-prefix (make-sparse-keymap))
-(define-key global-mouse-map mouse-vertical-thumbup-prefix
- 'mouse-vertical-thumbup-prefix)
-
-(let ((map (function mouse-vertical-thumbup-prefix)))
- (define-key map mouse-button-right 'mouse-scroll-down-full)
- (define-key map mouse-button-left 'mouse-scroll-down-full)
- (define-key map mouse-button-middle 'mouse-scroll-down-full))
-
-(fset 'mouse-vertical-thumbdown-prefix (make-sparse-keymap))
-(define-key global-mouse-map mouse-vertical-thumbdown-prefix
- 'mouse-vertical-thumbdown-prefix)
-
-(let ((map (function mouse-vertical-thumbdown-prefix)))
- (define-key map mouse-button-right 'mouse-scroll-up-full)
- (define-key map mouse-button-left 'mouse-scroll-up-full)
- (define-key map mouse-button-middle 'mouse-scroll-up-full))
-
-;; Horizontal bar
-
-(fset 'mouse-horizontal-scroll-bar-prefix (make-sparse-keymap))
-(define-key global-mouse-map mouse-horizontal-scroll-bar-prefix
- 'mouse-horizontal-scroll-bar-prefix)
-
-(let ((map (function mouse-horizontal-scroll-bar-prefix)))
- (define-key map mouse-button-right 'mouse-scroll-right)
- (define-key map mouse-button-left 'mouse-scroll-left)
- (define-key map mouse-button-middle 'mouse-scroll-absolute-horizontally))
-
-(fset 'mouse-horizontal-thumbleft-prefix (make-sparse-keymap))
-(define-key global-mouse-map mouse-horizontal-thumbleft-prefix
- 'mouse-horizontal-thumbleft-prefix)
-
-(let ((map (function mouse-horizontal-thumbleft-prefix)))
- (define-key map mouse-button-right 'mouse-scroll-left-full)
- (define-key map mouse-button-left 'mouse-scroll-left-full)
- (define-key map mouse-button-middle 'mouse-scroll-left-full))
-
-(fset 'mouse-horizontal-thumbright-prefix (make-sparse-keymap))
-(define-key global-mouse-map mouse-horizontal-thumbright-prefix
- 'mouse-horizontal-thumbright-prefix)
-
-(let ((map (function mouse-horizontal-thumbright-prefix)))
- (define-key map mouse-button-right 'mouse-scroll-right-full)
- (define-key map mouse-button-left 'mouse-scroll-right-full)
- (define-key map mouse-button-middle 'mouse-scroll-right-full))
-
-
+(global-set-key [scroll-bar mouse-1] 'mouse-scroll-up)
+(global-set-key [scroll-bar mouse-2] 'mouse-scroll-absolute)
+(global-set-key [scroll-bar mouse-3] 'mouse-scroll-down)
+
+(global-set-key [vertical-slider mouse-1] 'mouse-scroll-move-cursor)
+(global-set-key [vertical-slider mouse-2] 'mouse-scroll-move-cursor)
+(global-set-key [vertical-slider mouse-3] 'mouse-scroll-move-cursor)
+
+(global-set-key [thumbup mouse-1] 'mouse-scroll-up-full)
+(global-set-key [thumbup mouse-2] 'mouse-scroll-up-full)
+(global-set-key [thumbup mouse-3] 'mouse-scroll-up-full)
+
+(global-set-key [thumbdown mouse-1] 'mouse-scroll-down-full)
+(global-set-key [thumbdown mouse-2] 'mouse-scroll-down-full)
+(global-set-key [thumbdown mouse-3] 'mouse-scroll-down-full)
+
+(global-set-key [horizontal-scroll-bar mouse-1] 'mouse-scroll-left)
+(global-set-key [horizontal-scroll-bar mouse-2]
+ 'mouse-scroll-absolute-horizontally)
+(global-set-key [horizontal-scroll-bar mouse-3] 'mouse-scroll-right)
+
+(global-set-key [horizontal-slider mouse-1]
+ 'mouse-scroll-move-cursor-horizontally)
+(global-set-key [horizontal-slider mouse-2]
+ 'mouse-scroll-move-cursor-horizontally)
+(global-set-key [horizontal-slider mouse-3]
+ 'mouse-scroll-move-cursor-horizontally)
+
+(global-set-key [thumbleft mouse-1] 'mouse-scroll-left-full)
+(global-set-key [thumbleft mouse-2] 'mouse-scroll-left-full)
+(global-set-key [thumbleft mouse-3] 'mouse-scroll-left-full)
+
+(global-set-key [thumbright mouse-1] 'mouse-scroll-right-full)
+(global-set-key [thumbright mouse-2] 'mouse-scroll-right-full)
+(global-set-key [thumbright mouse-3] 'mouse-scroll-right-full)
+
+(global-set-key [horizontal-scroll-bar S-mouse-2]
+ 'mouse-split-window-horizontally)
+(global-set-key [mode-line S-mouse-2]
+ 'mouse-split-window-horizontally)
+(global-set-key [vertical-scroll-bar S-mouse-2]
+ 'mouse-split-window)
+\f
;;;;
;;;; Here are experimental things being tested. Mouse events
;;;; are of the form:
;;
;; Dynamically put a box around the line indicated by point
;;
-
-(require 'backquote)
-
-(defun mouse-select-buffer-line (event)
- (interactive "@e")
- (let ((relative-coordinate
- (coordinates-in-window-p (car event) (selected-window)))
- (abs-y (car (cdr (car event)))))
- (if (consp relative-coordinate)
- (progn
- (save-excursion
- (move-to-window-line (car (cdr relative-coordinate)))
- (x-draw-rectangle
- (selected-screen)
- abs-y 0
- (save-excursion
- (move-to-window-line (car (cdr relative-coordinate)))
- (end-of-line)
- (push-mark nil t)
- (beginning-of-line)
- (- (region-end) (region-beginning))) 1)
- (setq the-buffer (Buffer-menu-buffer t)))
- (sit-for 1)
- (x-erase-rectangle (selected-screen))))))
-
-(defvar last-line-drawn nil)
-(defvar begin-delim "[^ \t]")
-(defvar end-delim "[^ \t]")
-
-(defun mouse-boxing (event)
- (interactive "@e")
- (save-excursion
- (let ((screen (selected-screen)))
- (while (= (x-mouse-events) 0)
- (let* ((pos (read-mouse-position screen))
- (abs-x (car pos))
- (abs-y (cdr pos))
- (relative-coordinate
- (coordinates-in-window-p (` ((, abs-x) (, abs-y)))
- (selected-window)))
- (begin-reg nil)
- (end-reg nil)
- (end-column nil)
- (begin-column nil))
- (if (and (consp relative-coordinate)
- (or (not last-line-drawn)
- (not (= last-line-drawn abs-y))))
- (progn
- (move-to-window-line (car (cdr relative-coordinate)))
- (if (= (following-char) 10)
- ()
- (progn
- (setq begin-reg (1- (re-search-forward end-delim)))
- (setq begin-column (1- (current-column)))
- (end-of-line)
- (setq end-reg (1+ (re-search-backward begin-delim)))
- (setq end-column (1+ (current-column)))
- (message "%s" (buffer-substring begin-reg end-reg))
- (x-draw-rectangle screen
- (setq last-line-drawn abs-y)
- begin-column
- (- end-column begin-column) 1))))))))))
-
-(defun mouse-erase-box ()
- (interactive)
- (if last-line-drawn
- (progn
- (x-erase-rectangle (selected-screen))
- (setq last-line-drawn nil))))
-
-(defun test-x-rectangle ()
- (use-local-mouse-map (setq rectangle-test-map (make-sparse-keymap)))
- (define-key rectangle-test-map mouse-motion-button-left 'mouse-boxing)
- (define-key rectangle-test-map mouse-button-left-up 'mouse-erase-box))
+;;
+;;(require 'backquote)
+;;
+;;(defun mouse-select-buffer-line (event)
+;; (interactive "@e")
+;; (let ((relative-coordinate
+;; (coordinates-in-window-p (car event) (selected-window)))
+;; (abs-y (car (cdr (car event)))))
+;; (if (consp relative-coordinate)
+;; (progn
+;; (save-excursion
+;; (move-to-window-line (car (cdr relative-coordinate)))
+;; (x-draw-rectangle
+;; (selected-screen)
+;; abs-y 0
+;; (save-excursion
+;; (move-to-window-line (car (cdr relative-coordinate)))
+;; (end-of-line)
+;; (push-mark nil t)
+;; (beginning-of-line)
+;; (- (region-end) (region-beginning))) 1))
+;; (sit-for 1)
+;; (x-erase-rectangle (selected-screen))))))
+;;
+;;(defvar last-line-drawn nil)
+;;(defvar begin-delim "[^ \t]")
+;;(defvar end-delim "[^ \t]")
+;;
+;;(defun mouse-boxing (event)
+;; (interactive "@e")
+;; (save-excursion
+;; (let ((screen (selected-screen)))
+;; (while (= (x-mouse-events) 0)
+;; (let* ((pos (read-mouse-position screen))
+;; (abs-x (car pos))
+;; (abs-y (cdr pos))
+;; (relative-coordinate
+;; (coordinates-in-window-p (` ((, abs-x) (, abs-y)))
+;; (selected-window)))
+;; (begin-reg nil)
+;; (end-reg nil)
+;; (end-column nil)
+;; (begin-column nil))
+;; (if (and (consp relative-coordinate)
+;; (or (not last-line-drawn)
+;; (not (= last-line-drawn abs-y))))
+;; (progn
+;; (move-to-window-line (car (cdr relative-coordinate)))
+;; (if (= (following-char) 10)
+;; ()
+;; (progn
+;; (setq begin-reg (1- (re-search-forward end-delim)))
+;; (setq begin-column (1- (current-column)))
+;; (end-of-line)
+;; (setq end-reg (1+ (re-search-backward begin-delim)))
+;; (setq end-column (1+ (current-column)))
+;; (message "%s" (buffer-substring begin-reg end-reg))
+;; (x-draw-rectangle screen
+;; (setq last-line-drawn abs-y)
+;; begin-column
+;; (- end-column begin-column) 1))))))))))
+;;
+;;(defun mouse-erase-box ()
+;; (interactive)
+;; (if last-line-drawn
+;; (progn
+;; (x-erase-rectangle (selected-screen))
+;; (setq last-line-drawn nil))))
+
+;;; (defun test-x-rectangle ()
+;;; (use-local-mouse-map (setq rectangle-test-map (make-sparse-keymap)))
+;;; (define-key rectangle-test-map mouse-motion-button-left 'mouse-boxing)
+;;; (define-key rectangle-test-map mouse-button-left-up 'mouse-erase-box))
;;
;; Here is how to do double clicking in lisp. About to change.
(> (- (nth 4 event ) double-start) double-click-interval)
(setq double-start nil)))
-(defun x-test-doubleclick ()
- (use-local-mouse-map (setq doubleclick-test-map (make-sparse-keymap)))
- (define-key doubleclick-test-map mouse-button-left 'double-down)
- (define-key doubleclick-test-map mouse-button-left-up 'double-up))
+;;; (defun x-test-doubleclick ()
+;;; (use-local-mouse-map (setq doubleclick-test-map (make-sparse-keymap)))
+;;; (define-key doubleclick-test-map mouse-button-left 'double-down)
+;;; (define-key doubleclick-test-map mouse-button-left-up 'double-up))
;;
;; This scrolls while button is depressed. Use preferable in scrollbar.
(setq scrolled-lines 0)
(sleep-for 1))
-(defun x-testing-scroll ()
- (let ((scrolling-map (function mouse-vertical-scroll-bar-prefix)))
- (define-key scrolling-map mouse-button-left 'incr-scroll-down)
- (define-key scrolling-map mouse-button-right 'incr-scroll-up)
- (define-key scrolling-map mouse-button-left-up 'incr-scroll-stop)
- (define-key scrolling-map mouse-button-right-up 'incr-scroll-stop)))
+;;; (defun x-testing-scroll ()
+;;; (let ((scrolling-map (function mouse-vertical-scroll-bar-prefix)))
+;;; (define-key scrolling-map mouse-button-left 'incr-scroll-down)
+;;; (define-key scrolling-map mouse-button-right 'incr-scroll-up)
+;;; (define-key scrolling-map mouse-button-left-up 'incr-scroll-stop)
+;;; (define-key scrolling-map mouse-button-right-up 'incr-scroll-stop)))
;;
;; Some playthings suitable for picture mode? They need work.
(mouse-multiple-insert
(- (car relative-coordinate) (current-column)) " "))
((= (current-column) (car relative-coordinate)) (ding))))))
+\f
+;; Font selection.
+
+(defvar x-fixed-font-alist
+ '("Font menu"
+ ("Misc"
+ ("fixed" "fixed")
+ ("6x10" "6x10")
+ ("6x12" "6x12")
+ ("6x13" "6x13")
+ ("7x13" "7x13")
+ ("7x14" "7x14")
+ ("8x13" "8x13")
+ ("8x13 bold" "8x13bold")
+ ("8x16" "8x16")
+ ("9x15" "9x15")
+ ("9x15 bold" "9x15bold")
+ ("10x20" "10x20")
+ ("11x18" "11x18")
+ ("12x24" "12x24"))
+;;; We don't seem to have these; who knows what they are.
+;;; ("fg-18" "fg-18")
+;;; ("fg-25" "fg-25")
+;;; ("lucidasanstypewriter-12" "lucidasanstypewriter-12")
+;;; ("lucidasanstypewriter-bold-14" "lucidasanstypewriter-bold-14")
+;;; ("lucidasanstypewriter-bold-24" "lucidasanstypewriter-bold-24")
+;;; ("lucidatypewriter-bold-r-24" "-b&h-lucidatypewriter-bold-r-normal-sans-24-240-75-75-m-140-iso8859-1")
+;;; ("fixed-medium-20" "-misc-fixed-medium-*-*-*-20-*-*-*-*-*-*-*")
+ ("Courier"
+ ("8" "-adobe-courier-medium-r-normal--8-*-*-*-m-*-iso8859-1")
+ ("10" "-adobe-courier-medium-r-normal--10-*-*-*-m-*-iso8859-1")
+ ("12" "-adobe-courier-medium-r-normal--12-*-*-*-m-*-iso8859-1")
+ ("14" "-adobe-courier-medium-r-normal--14-*-*-*-m-*-iso8859-1")
+ ("18" "-adobe-courier-medium-r-normal--18-*-*-*-m-*-iso8859-1")
+ ("24" "-adobe-courier-medium-r-normal--24-*-*-*-m-*-iso8859-1")
+ ("8 bold" "-adobe-courier-bold-r-normal--8-*-*-*-m-*-iso8859-1")
+ ("10 bold" "-adobe-courier-bold-r-normal--10-*-*-*-m-*-iso8859-1")
+ ("12 bold" "-adobe-courier-bold-r-normal--12-*-*-*-m-*-iso8859-1")
+ ("14 bold" "-adobe-courier-bold-r-normal--14-*-*-*-m-*-iso8859-1")
+ ("18 bold" "-adobe-courier-bold-r-normal--18-*-*-*-m-*-iso8859-1")
+ ("24 bold" "-adobe-courier-bold-r-normal--24-*-*-*-m-*-iso8859-1")
+ ("8 slant" "-adobe-courier-medium-o-normal--8-*-*-*-m-*-iso8859-1")
+ ("10 slant" "-adobe-courier-medium-o-normal--10-*-*-*-m-*-iso8859-1")
+ ("12 slant" "-adobe-courier-medium-o-normal--12-*-*-*-m-*-iso8859-1")
+ ("14 slant" "-adobe-courier-medium-o-normal--14-*-*-*-m-*-iso8859-1")
+ ("18 slant" "-adobe-courier-medium-o-normal--18-*-*-*-m-*-iso8859-1")
+ ("24 slant" "-adobe-courier-medium-o-normal--24-*-*-*-m-*-iso8859-1")
+ ("8 bold slant" "-adobe-courier-bold-o-normal--8-*-*-*-m-*-iso8859-1")
+ ("10 bold slant" "-adobe-courier-bold-o-normal--10-*-*-*-m-*-iso8859-1")
+ ("12 bold slant" "-adobe-courier-bold-o-normal--12-*-*-*-m-*-iso8859-1")
+ ("14 bold slant" "-adobe-courier-bold-o-normal--14-*-*-*-m-*-iso8859-1")
+ ("18 bold slant" "-adobe-courier-bold-o-normal--18-*-*-*-m-*-iso8859-1")
+ ("24 bold slant" "-adobe-courier-bold-o-normal--24-*-*-*-m-*-iso8859-1"))
+ )
+ "X fonts suitable for use in Emacs.")
+
+(defun mouse-set-font (font)
+ "Select an emacs font from a list of known good fonts"
+ (interactive
+ (x-popup-menu last-nonmenu-event x-fixed-font-alist))
+ (modify-frame-parameters (selected-frame)
+ (list (cons 'font font))))
+\f
+;;; Bindings for mouse commands.
+
+;; This won't be needed once the drag and down events
+;; are properly implemented.
+(global-set-key [mouse-1] 'mouse-set-point)
+
+(global-set-key [drag-mouse-1] 'mouse-set-region)
+(global-set-key [mouse-2] 'mouse-yank-at-click)
+(global-set-key [mouse-3] 'mouse-save-then-kill)
+
+(global-set-key [C-mouse-1] 'mouse-buffer-menu)
+
+(global-set-key [C-mouse-3] 'mouse-set-font)
+
+;; Replaced with dragging mouse-1
+;; (global-set-key [S-mouse-1] 'mouse-set-mark)
+
+(global-set-key [mode-line mouse-1] 'mouse-delete-other-windows)
+(global-set-key [mode-line mouse-3] 'mouse-delete-window)
+\f
+;; Define the mouse help menu tree.
+
+(defvar help-menu-map '(keymap "Help"))
+(global-set-key [C-mouse-2] help-menu-map)
+
+(defvar help-apropos-map '(keymap "Is there a command that..."))
+(defvar help-keys-map '(keymap "Key Commands <==> Functions"))
+(defvar help-manual-map '(keymap "Manual and tutorial"))
+(defvar help-misc-map '(keymap "Odds and ends"))
+(defvar help-modes-map '(keymap "Modes"))
+(defvar help-admin-map '(keymap "Administrivia"))
+
+(define-key help-menu-map [apropos]
+ (cons "@Is there a command that..." help-apropos-map))
+(define-key help-menu-map [keys]
+ (cons "@Key Commands <==> Functions" help-keys-map))
+(define-key help-menu-map [manuals]
+ (cons "@Manual and tutorial" help-manual-map))
+(define-key help-menu-map [misc]
+ (cons "@Odds and ends" help-misc-map))
+(define-key help-menu-map [modes]
+ (cons "@Modes" help-modes-map))
+(define-key help-menu-map [admin]
+ (cons "@Administrivia" help-admin-map))
+
+(define-key help-apropos-map "c" '("Command Apropos" . command-apropos))
+(define-key help-apropos-map "a" '("Apropos" . apropos))
+
+(define-key help-keys-map "b"
+ '("List all keystroke commands" . describe-bindings))
+(define-key help-keys-map "c"
+ '("Describe key briefly" . describe-key-briefly))
+(define-key help-keys-map "k"
+ '("Describe key verbose" . describe-key))
+(define-key help-keys-map "f"
+ '("Describe Lisp function" . describe-function))
+(define-key help-keys-map "w"
+ '("Where is this command" . where-is))
+
+(define-key help-manual-map "i" '("Info system" . info))
+(define-key help-manual-map "t"
+ '("Invoke Emacs tutorial" . help-with-tutorial))
+
+(define-key help-misc-map "l" '("Last 100 Keystrokes" . view-lossage))
+(define-key help-misc-map "s" '("Describe syntax table" . describe-syntax))
+
+(define-key help-modes-map "m"
+ '("Describe current major mode" . describe-mode))
+(define-key help-modes-map "b"
+ '("List all keystroke commands" . describe-bindings))
+
+(define-key help-admin-map "n"
+ '("view Emacs news" . view-emacs-news))
+(define-key help-admin-map "l"
+ '("View the GNU Emacs license" . describe-copying))
+(define-key help-admin-map "d"
+ '("Describe distribution" . describe-distribution))
+(define-key help-admin-map "w"
+ '("Describe (non)warranty" . describe-no-warranty))
+
+(provide 'mouse)
+
+;;; mouse.el ends here