Relay-Version: version B 2.10 5/3/83; site utzoo.UUCP
Posting-Version: version B 2.10.2 9/18/84; site Navajo.ARPA
Path: utzoo!watmath!clyde!bonnie!akgua!gatech!seismo!harvard!talcott!panda!genrad!decvax!decwrl!glacier!Navajo!ehl
From: ehl@Navajo.ARPA
Newsgroups: net.sources.mac
Subject: macmouse.el (UW) for GNU EMACS
Message-ID: <274@Navajo.ARPA>
Date: Sun, 24-Nov-85 16:12:36 EST
Article-I.D.: Navajo.274
Posted: Sun Nov 24 16:12:36 1985
Date-Received: Wed, 27-Nov-85 05:46:04 EST
Reply-To: ehl@Navajo.UUCP (Elgin Lee)
Organization: Stanford University
Lines: 409
Keywords: uw gnu-emacs

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.edu