ehl@Navajo.ARPA (11/25/85)
With Chris Kent's permission, I've rewritten his macmouse package to
run under GNU EMACS rather than Gosling EMACS. I've also made a few
minor functional changes: mouse copy/delete/paste uses either the
kill ring or a named register, the thumbing region now spans the
entire buffer, and using the scrolling region doesn't set the
mark.
The package uses the command move-dot-to-x-y, which is provided in
Gosling EMACS. I've provided a GNU EMACS implementation of this
command in the file "dot-to-x-y.el", which in included here.
"macmouse.el" will automatically load this file if the feature
'dot-to-x-y has not been previously provided.
Hope this proves useful to someone.
Elgin Lee
UUCP: ..decvax!decwrl!glacier!navajo!ehl
old ARPA: ehl@su-navajo.ARPA
new ARPA: ehl@su-navajo.stanford.edu
----------Cut-Here----------
#! /bin/sh
: This is a shar archive. Extract with sh, not csh.
echo x - macmouse.el
cat > macmouse.el << '17675!Funky!Stuff!'
; $Header: macmouse.el,v 1.5 85/11/24 12:54:48 ehl Rel $
;
; Macintosh mouse routines for use with John Bruner's uw program.
; Modified for GNU EMACS by Elgin Lee, Stanford University
; Chris Kent, Purdue University Fri Oct 25 1985
; Copyright 1985 by Christopher A. Kent. All rights reserved.
; Permission to copy is given provided that the copy is not
; sold and this copyright notice is included.
;
; Provides a scroll bar/thumbing area in the unused scroll bar with the
; following features:
; click at line 1 does previous page
; click at line 24 does next page
; click anywhere else "thumbs" to the relative portion of the buffer.
; shift-click at line 1 scrolls one line down
; shift-click at line 24 scrolls one line up
; shift-click elsewhere moves line to top of window
; option-shift-click elsewhere moves line to bottom of window
;
; There is also basic positioning and kill-ring support:
; click in a buffer moves dot there
; drag copies the dragged region to the kill ring (mark is left
; at the beginning of the region.)
; shift-drag deletes the dragged region to the kill ring
; command-drag copies the dragged region to a named register
; shift-command-drag deletes the dragged region to a named
; register
;
; it is possible to use the scrolling and thumbing area to make the region
; larger than a single screen; just click, scroll, release. Make sure
; that the last scroll is just a down event; the up must be in the buffer.
;
; option-click yanks from the kill ring, doesn't affect mark.
; option-shift-click similarly yanks from a named buffer.
; option-command-click yanks from a named register.
(require 'dot-to-x-y)
(defvar _mouse-last-x 0 "x of last event")
(defvar _mouse-last-y 0 "y of last event")
(defvar _mouse-last-b 0 "buttons at last event")
(defvar _mouse-last-dot 0 "dot after last event")
(defvar _mouse-start-action nil "action (edit or scroll) of mouse-down")
(defun move-mac-cursor ()
"Move cursor according to Macintosh mouse event.
Provides a scroll bar/thumbing area in the unused scroll bar with the
following features:
click at line 1 does previous page
click at line 24 does next page
click anywhere else \"thumbs\" to the relative portion of the buffer.
shift-click at line 1 scrolls one line down
shift-click at line 24 scrolls one line up
shift-click elsewhere moves line to top of window
option-shift-click elsewhere moves line to bottom of window
There is also basic positioning and kill-ring support:
click in a buffer moves dot there
drag copies the dragged region to the kill ring (mark is left
at the beginning of the region.)
shift-drag deletes the dragged region to the kill ring
command-drag copies the dragged region to a named register
shift-command-drag deletes the dragged region to a named
register
it is possible to use the scrolling and thumbing area to make the region
larger than a single screen; just click, scroll, release. Make sure
that the last scroll is just a down event; the up must be in the buffer.
option-click yanks from the kill ring, doesn't affect mark.
option-shift-click similarly yanks from a named buffer.
option-command-click yanks from a named register."
(interactive)
(let* ((stack-trace-on-error nil)
(y (- (read-char) 32))
(x (- (read-char) 32))
(b (- (read-char) 32))
(command (/= (logand b 1) 0))
(shift (/= (logand b 2) 0))
(lock (/= (logand b 4) 0))
(option (/= (logand b 8) 0))
(down (/= (logand b 16) 0))
(up (/= (logand b 32) 0)))
(condition-case ()
(progn
(if (not (eq last-command '_mouse-scroll)) ; not if just scrolled
(setq _mouse-last-dot (dot)))
(move-dot-to-x-y x y)
(setq this-command '_mouse-edit)
(if down
(setq _mouse-start-action '_mouse-edit))
(_mouse-edit-action b))
(error
(setq this-command '_mouse-scroll)
(if down
(setq _mouse-start-action '_mouse-scroll))
(_mouse-scroll-region x y command shift lock option down up)))
(if down
(progn
(setq _mouse-last-x x)
(setq _mouse-last-y y)
(setq _mouse-last-b b))
(progn
(setq _mouse-last-x 0)
(setq _mouse-last-y 0)
(setq _mouse-last-b 0)))
)
)
(defun _mouse-edit-action (b)
" marking and editing actions on buttons:
if no movement, nothing.
if movement, put mark at _mouse-last-dot,
leave dot here,and edit.
editing (on upstrokes):
unmodified, copy to kill ring.
SHIFTed, delete (cut) to kill ring.
COMMANDed, copy to named register.
SHIFT-COMMANDed, delete (cut) to named register.
option-click yanks from kill ring;
shift-option-click yanks from named buffer;
command-option-click yanks from named register."
(if (and (> b 15) (< b 48))
(funcall (nth (- b 16)
'(_mouse-d _mouse-dc _mouse-ds _mouse-dsc _mouse-dl _mouse-dlc
_mouse-dls _mouse-dlsc _mouse-do _mouse-doc _mouse-dos
_mouse-dosc _mouse-dol _mouse-dolc _mouse-dols _mouse-dolsc
_mouse-u _mouse-uc _mouse-us _mouse-usc _mouse-ul _mouse-ulc
_mouse-uls _mouse-ulsc _mouse-uo _mouse-uoc _mouse-uos
_mouse-uosc _mouse-uol _mouse-uolc _mouse-uols _mouse-uolsc)))))
; individual button bindings
(defun _mouse-u () ; up
(if (not (_mouse-click-p))
(progn
(_mouse-set-region)
(copy-region-as-kill (dot) (mark)))))
(defun _mouse-uc () ; up/command
(if (not (_mouse-click-p))
(progn
(_mouse-set-region)
(message "Copy to register: ")
(copy-to-register (read-char) (mark) (dot) nil))))
(defun _mouse-us () ; up/shift
(if (not (_mouse-click-p))
(progn
(_mouse-set-region)
(kill-region (dot) (mark)))))
(defun _mouse-usc () ; up/shift/command
(if (not (_mouse-click-p))
(progn
(_mouse-set-region)
(message "Delete to register: ")
(copy-to-register (read-char) (mark) (dot) t))))
(defun _mouse-ul () ; up/lock
)
(defun _mouse-ulc () ; up/lock/command
)
(defun _mouse-uls () ; up/lock/shift
)
(defun _mouse-ulsc () ; up/lock/shift/command
)
(defun _mouse-uo () ; up/option
(if (_mouse-click-p)
(progn
(yank)
(setq this-command 'yank))))
(defun _mouse-uoc () ; up/option/command
(if (_mouse-click-p) ; click
(call-interactively 'insert-register)))
(defun _mouse-uos () ; up/option/shift
(if (_mouse-click-p) ; click
(insert-buffer (read-buffer "Insert contents of buffer: "))))
(defun _mouse-uosc () ; up/option/shift/command
)
(defun _mouse-uol () ; up/option/lock
)
(defun _mouse-uolc () ; up/option/lock
)
(defun _mouse-uols () ; up/option/lock/shift
)
(defun _mouse-uolsc () ; up/option/lock/shift/command
)
(defun _mouse-d () ; down
)
(defun _mouse-dc () ; down/command
)
(defun _mouse-ds () ; down/shift
)
(defun _mouse-dsc () ; down/shift/command
)
(defun _mouse-dl () ; down/lock
)
(defun _mouse-dlc () ; down/lock/command
)
(defun _mouse-dls () ; down/lock/shift
)
(defun _mouse-dlsc () ; down/lock/shift/command
)
(defun _mouse-do () ; down/option
)
(defun _mouse-doc () ; down/option/command
)
(defun _mouse-dos () ; down/option/shift
)
(defun _mouse-dosc () ; down/option/shift
)
(defun _mouse-dol () ; down/option/lock
)
(defun _mouse-dolc () ; down/option/lock
)
(defun _mouse-dols () ; down/option/lock/shift
)
(defun _mouse-dolsc () ; down/option/lock/shift/command
)
(defun _mouse-set-region ()
"set the region to be from last dot to dot."
(if (eq _mouse-start-action '_mouse-edit)
(progn
(set-mark-command nil)
(goto-char _mouse-last-dot)
(exchange-dot-and-mark))))
(defun _mouse-click-p ()
(= (dot) _mouse-last-dot))
(defun _mouse-scroll-region (x y command shift lock option down up)
" out of range actions:
left margin -- hard to generate, ignored
right margin -- simulate scroll bar
line 1 -- previous page
line 24/25 -- next page
other lines -- thumbing
top margin -- previous page
bottom margin -- next page
if shifted, deal with lines.
line 1 scrolls one line down
line 24/25 scrolls one line up
else line to top; with option to bottom.
if up stroke is in same place as down
stroke, don't do anything, so clicks in
the scroll region don't do the action
twice."
(if down
(if shift
(do-lines x y option)
(do-pages x y)))
(if (and up
(or (/= x _mouse-last-x) (/= y _mouse-last-y)))
(if shift
(do-lines x y option)
(do-pages x y)))
(_mouse-set-region))
(defun do-pages (x y)
"large motions via pages and thumbing"
(if (or (= y 0) (= y 1)
(and (= x 81) (= y 24))
(= y 25))
(progn
(if (or (= y 0) (= y 1))
(scroll-down)
(scroll-up)))
(if (= x 81)
(goto-percent (/ (* (- y 2) 100) 21)))))
(defun do-lines (x y option)
"fine control over lines"
(if (= x 81)
(if (or (= y 1) (= y 24) (= y 25))
(if (or (= y 0) (= y 1))
(scroll-down 1)
(scroll-up 1))
(progn
(move-dot-to-x-y 1 y)
(if option
(recenter -1)
(recenter 0))))))
(defun goto-percent (percent)
(goto-char (/ (* (buffer-size) percent) 100)))
(define-key esc-map "m" 'move-mac-cursor)
17675!Funky!Stuff!
echo x - dot-to-x-y.el
cat > dot-to-x-y.el << '17675!Funky!Stuff!'
;; $Header: dot-to-x-y.el,v 1.2 85/11/24 10:41:37 ehl Rel $
;;
;; Provides the GNU EMACS equivalent of the Gosling EMACS move-to-x-y
;; function, which moves to the specified (one-based) screen coordinates,
;; switching buffers if necessary. Returns an error condition when the
;; mouse is not in a buffer (e.g., the mode lines, horizontal window
;; separators, and the minibuffer (when disabled).
;;
;; Written by Elgin Lee, Stanford University
;; (ehl@su-navajo.stanford.edu, ..decvax!decwrl!glacier!navajo!ehl)
(provide 'dot-to-x-y)
(defun move-dot-to-x-y (x y)
"Moves to the indicated (one-based) coordinates, switching to the proper
window."
(let (edges window-min-x window-min-y window-max-x
window-max-y start-window found-window)
(while (and (not (equal (selected-window) start-window))
(not found-window))
(setq edges (window-edges)
window-min-x (car edges)
window-min-y (car (cdr edges))
window-max-x (car (cdr (cdr edges)))
window-max-y (car (cdr (cdr (cdr edges)))))
(if (null start-window)
(set 'start-window (selected-window)))
(if (and (> x window-min-x) (< x window-max-x)
(> y window-min-y)
(or (< y window-max-y)
(and (= y (screen-height)) (= y window-max-y))))
(progn
(move-to-window-line (- y window-min-y 1))
(move-to-column (- (+ x (current-column)) window-min-x 1))
(set 'found-window t))
(select-window (next-window))))
(if (not found-window)
(error "Mouse event not in a window"))))
17675!Funky!Stuff!
exit
--
Elgin Lee
UUCP: ..decvax!decwrl!glacier!navajo!ehl
old ARPA: ehl@su-navajo.ARPA, ehl@su-score.ARPA
new ARPA: ehl@su-navajo.stanford.edu, ehl@su-score.stanford.edujdb@mordor.UUCP (John Bruner) (01/08/86)
I received this some time ago from Gregory S. Glauer (glauer@bbn),
but for various reasons (one of them was the Christmas break) I
held it up until now. He rewrote Chris Kent's "macmouse.ml"
(Goslings Emacs mouse macros) to run under GNU Emacs.
Here, finally is the GNU Emacs code.
(Since I use "vi" I recommend that you forward any comments about
these Emacs packages to their authors.)
------------------------------------------------------------------------
;;; macmouse.el (Version: 2.0)
;;; Copyright (C) Gregory S. Lauer (glauer@bbn), 1985.
;;; Please send suggestions and corrections to the above address.
;;;
;;; This file contains macmouse, a GNU Emacs mouse package for UW.
;;
;; GNU Emacs is distributed in the hope that it will be useful,
;; but without any warranty. No author or distributor
;; accepts responsibility to anyone for the consequences of using it
;; or for whether it serves any particular purpose or works at all,
;; unless he says so in writing.
;; Everyone is granted permission to copy, modify and redistribute
;; GNU Emacs, but only under the conditions described in the
;; document "GNU Emacs copying permission notice". An exact copy
;; of the document is supposed to have been given to you along with
;; GNU Emacs so that you can know how you may redistribute it all.
;; It should be in a file named COPYING. Among other things, the
;; copyright notice and this notice must be preserved on all copies.
;;; Original version for Gosling emacs by Chris Kent, Purdue University 1985.
;;; Modified by Gregory Lauer, BBN, Novemeber 1985.
;
;
;
; Macmouse provides the following features:
; Up or down mouse button in a window selects that window
;
; A scroll bar/thumbing area for each window with the following features:
; the mode lines are horizontal scroll bars
; (running from rightmost column to under leftmost column)
; the unused right window bar and the dividing lines between
; windows are vertical scroll bars
; (running from top of window THRU modeline
; for vertical scroll bars:
; click at line 1 does previous page
; click at last line does next page
; click anywhere else "thumbs" to the relative portion of the buffer.
; shift-click at line 1 scrolls one line down
; shift-click at last line scrolls one line up
; shift-click elsewhere moves line to top of window
; option-shift-click elsewhere moves line to bottom of window
; for horizontal scroll bars:
; click at column 1 does scroll right one window width
; click at last column does scroll left one window width
; click anywhere else moves to that "percent" of the buffer width
; shift-click at column 1 scrolls one column right
; shift-click at last column scrolls one column left
; shift-click elsewhere moves column to right of window
; option-shift-click elsewhere moves column to left of window
;
; There is also basic positioning and kill-buffer support:
; click in a buffer moves dot there and selects that buffer
; drag copies the dragged region to the kill buffer
; shift-drag deletes the dragged region to the kill buffer
;
; It is possible to use the scrolling and thumbing area to make the region
; larger than a single screen; just click, scroll, release. Make sure
; that the last scroll is just a down event; the up must be in the buffer.
; The last mouse position is remembered for each different buffer (not
; window), and thus you can start a drag in one buffer, select another,
; go back to the first buffer, etc.
;
; option-click yanks from the kill buffer
; option-shift-click similarly yanks from a named buffer.
;
(make-variable-buffer-local 'mouse-last-x) ; x of last event
(set-default 'mouse-last-x 0)
(make-variable-buffer-local 'mouse-last-y) ; y of last event
(set-default 'mouse-last-y 0)
(make-variable-buffer-local 'mouse-last-b) ; buttons at last event
(set-default 'mouse-last-b 0)
(make-variable-buffer-local 'mouse-last-dot) ; dot after last event
(set-default 'mouse-last-dot 0)
(make-variable-buffer-local 'scrolling-p)
(set-default 'scrolling-p nil)
(defun move-mac-cursor ()
(interactive)
(let (savest b x y up down lock shift option command)
(setq savest stack-trace-on-error)
(setq stack-trace-on-error nil)
; decode everything
(setq y (- (read-char) 32))
(setq x (- (read-char) 32))
(setq b (- (read-char) 32))
(setq command (< 0 (logand b 1))) ; command key
(setq shift (< 0 (logand b 2))) ; shift
(setq lock (< 0 (logand b 4))) ; caps-lock
(setq option (< 0 (logand b 8))) ; option
(setq down (< 0 (logand b 16))) ; mouse down
(setq up (< 0 (logand b 32))) ; mouse up
(condition-case ()
(progn
(select-window-containing-x-and-y x y) ; side-effect sets scrolling-p
(if scrolling-p
(mouse-scroll-region b x y)
(progn
(move-to-window-x-y x y) ; move cursor to mouse-dot always
(if down (setq mouse-last-dot (dot)))
(mouse-edit-action))))
(error (message "Click not in selectable window")
(sit-for 1)
(message "")))
(setq stack-trace-on-error savest)
(if down
(progn
(setq mouse-last-x x)
(setq mouse-last-y y)
(setq mouse-last-b b))
(progn
(setq mouse-last-x 0)
(setq mouse-last-y 0)
(setq mouse-last-b 0)))))
(defun mouse-edit-action ()
;marking and editing actions on buttons:
; if no movement, nothing.
; if movement, save mouse-last-dot,
; and edit.
; editing (on upstrokes):
; unmodified, copy to kill buffer.
; SHIFTed, delete (cut) to kill buffer.
;
; option-click yanks from kill buffer;
; shift-option-click from named buffer.
(let ((fun (get 'mouse-function b)))
(if fun (apply fun nil))))
; individual button bindings
; generally will only need up mouse button: mouse-last-dot
; is saved automatically on down mouse button
; only need to define functions for keys that get used
(put 'mouse-function 32 ; up
'(lambda ()
(if (and (not (mouse-click-p))
(not scrolling-p))
(copy-region-as-kill (dot) mouse-last-dot))))
(put 'mouse-function 34 ; up/shift
'(lambda ()
(if (and (not (mouse-click-p))
(not scrolling-p))
(kill-region (dot) mouse-last-dot))))
(put 'mouse-function 40 ; up/option
'(lambda ()
(if (mouse-click-p)
(progn
(yank)
(exchange-dot-and-mark)))))
(put 'mouse-function 42
'(lambda () ; up/option/shift
(if (mouse-click-p)
(insert-buffer (read-buffer "Insert contents of buffer: ")))))
(defun mouse-click-p ()
(= (dot) mouse-last-dot))
(defun set-window-boundaries ()
(let ((edges (window-edges)))
(setq xl (1+ (car edges)))
(setq yt (1+ (car (cdr edges))))
(let ((temp (car (cdr (cdr edges)))))
(setq xr (if (= 80 temp) 81 temp)))
(let ((temp (car (cdr (cdr (cdr edges))))))
(setq yb (if (= 24 temp) 25 temp )))))
(defun select-window-containing-x-and-y (x y)
(let ((starting-window (selected-window)))
(set-window-boundaries)
(while (not (point-in-window x y))
(other-window 1)
(if (eq (selected-window) starting-window)
(error nil)
(set-window-boundaries)))
(if (or (= x xr) (= y yb))
(setq scrolling-p t)
(setq scrolling-p nil))))
(defun point-in-window (x y)
(and (<= xl x)(<= x xr)(<= yt y)(<= y yb)))
(defun move-to-window-x-y (x y)
(move-to-window-line (- y yt))
(move-to-window-column (- x xl)))
(defun move-to-window-column (x)
(move-to-column (+ (max 0 (- (window-hscroll) 1)) x)))
(defun mouse-scroll-region (b x y)
(if down
(if shift
(do-lines b x y)
(do-pages b x y)))
(if (and up
(or (/= x mouse-last-x)
(/= y mouse-last-y)))
(if shift
(do-lines b x y)
(do-pages b x y))))
(defun do-lines (b x y) ; fine control over lines
(if (= x xr)
(cond ((= y yt)(scroll-down 1))
((= y yb)(scroll-up 1))
(t (if option
(scroll-down (- yb y 1))
(scroll-up (- y yt))))))
(if (and (= y yb) (/= x xr))
(cond ((<= x xl)(scroll-right 1))
((>= x (1- xr))(scroll-left 1))
(t (if option
(move-column-right x)
(move-column-left x))))))
(defun move-column-left (x) ;need to mess about a bit because
(scroll-left ;first scroll left of 1 just writes
(if (= (window-hscroll) 0) ;a column of $s in column 1
(- x xl)
(- x xl 1))))
(defun move-column-right (x)
(scroll-right (- xr x 2)))
(defun do-pages (b x y) ; large motions via pages and thumbing
(if (= x xr)
(cond ((= y yt)(scroll-down nil))
((= y yb)(scroll-up nil))
(t (goto-percent (/ (* (- y yt 1) 100)
(- yb yt 2))))))
(if (and (= y yb)(/= x xr))
(cond ((<= x xl)(scroll-right (- (window-width)
next-screen-context-lines)))
((>= x (1- xr))(scroll-left (- (window-width)
next-screen-context-lines)))
(t (goto-horizontal-percent (/ (* (- x xl 1) 100)
(- xr xl 2)))))))
(defun goto-percent (p)
(goto-char (/ (* (- (dot-max) (dot-min)) p) 100)))
(defun goto-horizontal-percent (p) ;try to put this percent of 80 columns
(let ((window-offset (window-hscroll));in the center column of the window
delta) ;unless that would move column 0 or 80
(setq delta ;past the window edge
(- window-offset
(min (max 0 (- (/ (* 80 p) 100)
(/ (- xr xl) 2)))
(- 80 (- xr xl)))))
(scroll-right delta)))
(global-set-key "\em" 'move-mac-cursor)
--
John Bruner (S-1 Project, Lawrence Livermore National Laboratory)
MILNET: jdb@mordor [jdb@s1-c.ARPA] (415) 422-0758
UUCP: ...!ucbvax!dual!mordor!jdb ...!seismo!mordor!jdb