;; Improved window scrolling commands.
;; Copyright (C) 1988 Free Software Foundation, Inc.

;; This file is not officially part of GNU Emacs, but is being donated
;; to the Free Software Foundation.

;; 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.  Refer to the GNU Emacs General Public
;; License for full details.

;; Everyone is granted permission to copy, modify and redistribute
;; GNU Emacs, but only under the conditions described in the
;; GNU Emacs General Public License.   A copy of this license is
;; supposed to have been given to you along with GNU Emacs so you
;; can know your rights and responsibilities.  It should be in a
;; file named COPYING.  Among other things, the copyright notice
;; and this notice must be preserved on all copies.

;; Author: Joe Wells
;; jbw%bucsf.bu.edu@bu-it.bu.edu (school year)
;; joew%uswest@boulder.colorado.edu (summer)

;; The ideas for this package were derived from the C code in
;; src/window.c and elsewhere.  The names of the functions conflict
;; with names in lisp/term/sun.el.  If someone can think of better
;; names, send me a suggestion.  The functions in this file should
;; always be byte-compiled for speed.  The functions really don't know
;; what to do with an argument of '-, which results from C-u - or ESC
;; -.  I could use some suggestions on that also.

(require 'backquote)

(defmacro sip:abs (n)
  (`(let ((m (, n)))
      (if (< m 0) (- m) m))))

(defmacro sip:same-sign (x y)
  (`(let ((z (, y)))
     (if (< (, x) 0)
	 (< z 0) (>= z 0)))))

(defvar sip:goal-column 0
  "Current goal column for scrolling motion.  It is the column where
point was at the start of current run of scrolling commands.")

(defvar sip:default-motion nil
  "Default argument to scroll-up-in-place or scroll-down-in-place,
when repeated with no intervening command and no argument.  This is
the last argument used.")

(defvar sip:eob-motion nil
  "Amount of motion to be used by scroll-up-in-place or
scroll-down-in-place when repeated after hitting the end/beginning of
the buffer with no intervening command and no argument.  This is the
amount of vertical motion that was actually done on the last scroll
operation (which was less than requested, because of buffer
boundaries).")

(defvar sip:eob-blank-limit nil
  "This is the minimum amount of text that is required on the last
screen.  scroll-up-in-place will refuse to scroll any more than this.
Normally this is one less than the number of text line in the window.
However, if a sequence of scrolling commands starts with less text on
the last screen, this is remembered here.")

(defun scroll-down-in-place (n)
  "Scroll text of current window downward ARG lines; or near full screen if
no ARG.  When calling from a program, supply a number as argument or nil.
Leaves point in same row and column of window."
  (interactive "P")
  (scroll-in-place-command n -1)
  nil)

(defun scroll-up-in-place (n)
  "Scroll text of current window upward ARG lines; or near full screen if
no ARG.  When calling from a program, supply a number as argument or nil.
Leaves point in same row and column of window."
  (interactive "P")
  (scroll-in-place-command n 1)
  nil)

(defun scroll-in-place-command (arg direction)
  "Scroll text of current window ARG lines in DIRECTION direction.  If ARG
is null, scrolls almost entire window.  If ARG is '-, scrolls window in
- DIRECTION direction.  DIRECTION is either 1 or -1.  Leaves point in same
row and column of window."
  ;;  (message "%s %s %s %s %s %s"
  ;;	   last-command this-command arg sip:default-motion
  ;;	   sip:eob-motion sip:eob-blank-limit)
  (let* ((window (selected-window))
	 (height (- (window-height window)
		    (if (eq window (minibuffer-window)) 0 1)))
	 (lines (- height next-screen-context-lines))
	 (n (prefix-numeric-value arg))
	 (first-scroll
	  (not (memq last-command '(scroll-down-in-place scroll-up-in-place))))
	 moved)
    ;; Barf on zero argument
    (and (numberp arg) (zerop arg) (while t (signal 'args-out-of-range arg)))
    ;; Figure out how much vertical motion to use.  An explicit argument
    ;; is always given precedence.  If a immediately prior scroll ran
    ;; into a buffer boundary, and didn't go full distance, and this is
    ;; a scroll in the opposite direction, go back the amount last
    ;; traveled.  (Man is that a confusing sentence!)  Otherwise, if
    ;; following a prior scroll use the last explicit argument.
    (cond ((or (numberp arg) (consp arg))
	   (setq sip:default-motion n)
	   (setq sip:eob-motion nil)
	   (setq lines n))
	  ((eq arg '-)			;needs more work
	   (setq lines (- lines)))
	  (first-scroll
	   (setq sip:default-motion lines)
	   (setq sip:eob-motion nil))
	  ((and sip:eob-motion
		(not (sip:same-sign direction sip:eob-motion)))
	   (setq lines (sip:abs sip:eob-motion))
	   (setq sip:eob-motion nil))
	  (t				;in sequence w/o arg ...
	   (setq lines sip:default-motion)))
    (cond (first-scroll
	   (setq sip:goal-column (or (and track-eol (eolp) 9999)
						  (current-column)))
	   (setq sip:eob-blank-limit
		 (save-excursion
		   (goto-char (window-start window))
		   (vertical-motion (1- height))))))
    (setq lines (* direction lines))
    ;; if point not in window, center window around point
    (save-excursion
      (cond ((not (pos-visible-in-window-p (point) window))
	     (vertical-motion (/ (- height) 2))
	     (set-window-start window (point)))))
    (catch 'foo
      (save-excursion
	(goto-char (window-start window))
	(cond ((< lines 0)		; upward -- scrolling down
	       (cond ((bobp)
		      (ding)
		      (message (get 'beginning-of-buffer 'error-message))
		      (throw 'foo nil)))
	       (setq moved (vertical-motion lines)))
	      ((> lines 0)		; downward -- scrolling up
	       (setq moved (+ (vertical-motion (+ lines sip:eob-blank-limit))
			      (vertical-motion (- sip:eob-blank-limit))))
	       (cond ((< moved 1)
		      (ding)
		      (message (get 'end-of-buffer 'error-message))
		      (throw 'foo nil))))
	      (t (error "Impossible zero value")))
	(set-window-start window (point)))
      (if (< (sip:abs moved) (sip:abs lines))
	  (setq sip:eob-motion moved))
      (vertical-motion moved)))		;keep point on same window line
  (move-to-column sip:goal-column))

(provide 'scroll-in-place)