Path: utzoo!utgpu!jarvis.csri.toronto.edu!cs.utexas.edu!uunet!brunix!tac
From: tac@cs.brown.edu (Theodore A. Camus)
Newsgroups: comp.emacs
Subject: mouse scrolling
Message-ID: <30704@brunix.UUCP>
Date: 26 Feb 90 19:17:36 GMT
Sender: news@brunix.UUCP
Reply-To: tac@cs.brown.edu (Theodore A. Camus)
Organization: Brown University Department of Computer Science
Lines: 64


This may be useful to some of you.
Place the mouse one line below the cursor and shift left click;
everything moves up one. Place it two below the cursor, and it 
moves two, etc.  

X version :
-----------

(define-key mouse-map x-button-s-left 'x-scroll-to-cursor)

(defun x-scroll-to-cursor (arg)
  (let* ((cursor-y (current-row))
         (mouse-y (progn (x-mouse-set-point arg) (current-row)))
         (pos (point))
         (ok (cond ((< mouse-y cursor-y)
                    (move-to-window-line 0)
                    (/= (point) 1))
                   (t (/= (point) (point-max))))))
    (cond (ok (goto-char pos)
              (scroll-up (- mouse-y cursor-y))
              (move-to-window-line 0)
              (next-line cursor-y)
              (move-to-column (- (car arg) (car (window-edges)))))
          (t  (goto-char pos)))))

Suntool version :
-----------------

(global-set-mouse '(text shift left)   'mouse-scroll-to-cursor)

(defun mouse-scroll-to-cursor (w x y)
  (let* ((offset  (current-row)) 
         (pos (point))  
         (ok (cond ((< y offset) 
                    (move-to-window-line 0)
                    (/= (point) 1))
                   (t (/= (point) (point-max))))))
        (cond (ok (goto-char pos)
                  (scroll-up (- y offset))
                  (cursor-to-window-top)
                  (next-line offset)
                  (move-to-column x))
              (t  (goto-char pos)))))


Needed for both :
-----------------

(defun current-row ()
  "Returns current row #, from screen top, from 0."
  (let* ((pos (point))
         (top (window-start))
         (count 0))
    (beginning-of-line)
    (while (/= (point) top)
        (forward-line -1)
        (setq count (1+ count)))
    (goto-char pos)
    count))
  CSnet:     tac@cs.brown.edu                          Ted Camus  
  ARPAnet:   tac%cs.brown.edu@relay.cs.net             Box 1910 CS Dept
  BITnet:    tac@browncs.BITNET                        Brown University
  "An ounce of example is worth a pound of theory."    Providence, RI 02912