#| -*-Scheme-*-

$Id: bufwiu.scm,v 1.38 2005/11/06 16:30:58 cph Exp $

Copyright 1987,1989,1990,1991,1993,1994 Massachusetts Institute of Technology
Copyright 1996,2000,2005 Massachusetts Institute of Technology

This file is part of MIT/GNU Scheme.

MIT/GNU Scheme 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 of the License, or (at
your option) any later version.

MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software
Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
USA.

|#

;;;; Buffer Windows: Image Update

(declare (usual-integrations))

;;;; Insert/Delete

(define (%notice-window-changes! window)
  ;; Assumes that interrupts are disabled.
  (let ((group (%window-group window)))
    (if (fix:> (group-modified-tick group) (%window-modified-tick window))
	(let ((start (group-start-changes-index group))
	      (end (group-end-changes-index group)))
	  (if (%window-debug-trace window)
	      ((%window-debug-trace window) 'window window
					    '%notice-window-changes!))
	  (if (not (%window-force-redraw? window))
	      ;; If this change intersects the visible region of the
	      ;; buffer, request a display update.
	      (if start
		  (window-needs-redisplay! window)
		  ;; Otherwise mark the window to indicate that it has
		  ;; been updated to reflect these changes.
		  (%set-window-modified-tick! window
					      (group-modified-tick group))))
	  (if start
	      (begin
		;; If this change affects START-MARK, invalidate it
		;; and request a display update.
		(if (and (%window-start-line-mark window)
			 (%start-clobbered? window start end))
		    (begin
		      (clear-window-start! window)
		      (window-needs-redisplay! window)))
		;; If this change affects POINT, invalidate it and
		;; request a display update.
		(if (and (fix:<= start (%window-point-index window))
			 (fix:<= (%window-point-index window) end))
		    (begin
		      (%set-window-point-moved?! window 'SINCE-START-SET)
		      (window-needs-redisplay! window)))))))))

(define-integrable (%start-clobbered? window start end)
  (let ((wlstart (%window-start-line-index window))
	(wstart (%window-start-index window))
	(partial (%window-start-partial window)))
    (or (and (%window-current-start-delta window)
	     ;; If the delta between START-LINE and START has changed
	     ;; since the last redisplay, then the window start has
	     ;; been clobbered.  For example, if the first line was
	     ;; only partially visible, and is then entirely deleted,
	     ;; WLSTART and WSTART will be equal -- which would
	     ;; normally indicate that the window start is OK.
	     (not (and (fix:= (%window-current-start-delta window)
			      (fix:- wstart wlstart))
		       (fix:= (%window-current-start-partial window)
			      partial))))
	(and (if (and (fix:= wlstart wstart)
		      (fix:= 0 partial))
		 (fix:< start wstart)
		 (fix:<= start wstart))
	     (fix:<= wlstart end)))))

;;;; Clip

(define (make-clip-daemon window)
  ;; It is assumed that the clip daemon is called before the clipping
  ;; has been performed.  It is also assumed that interrupts are
  ;; disabled.
  (lambda (group start end)
    (if (not (%window-force-redraw? window))
	(begin
	  (if (%window-debug-trace window)
	      ((%window-debug-trace window) 'window window 'clip-daemon
					    group start end))
	  (if (not (%window-start-clip-mark window))
	      (begin
		(%set-window-start-clip-mark!
		 window
		 (make-permanent-mark group
				      (group-display-start-index group)
				      #t))
		(%set-window-end-clip-mark!
		 window
		 (make-permanent-mark group
				      (group-display-end-index group)
				      #f))))
	  (begin
	    (if (fix:> start (%window-start-clip-index window))
		(set-mark-index! (%window-start-clip-mark window) start))
	    (if (fix:< end (%window-end-clip-index window))
		(set-mark-index! (%window-end-clip-mark window) end)))
	  (if (and (not (window-needs-redisplay? window))
		   (or (fix:>= (%window-start-clip-index window)
			       (%window-current-start-index window))
		       (fix:<= (%window-end-clip-index window)
			       (%window-current-end-index window))))
	      (window-needs-redisplay! window))))
    (if (and (%window-start-line-mark window)
	     (or (fix:>= start (%window-start-line-index window))
		 (fix:< end (%window-start-index window))))
	(begin
	  (clear-window-start! window)
	  (window-needs-redisplay! window)))
    (let ((point (%window-point-index window)))
      (cond ((fix:< point start)
	     (set-window-point-index! window start)
	     (%set-window-point-moved?! window 'SINCE-START-SET))
	    ((fix:< end point)
	     (set-window-point-index! window end)
	     (%set-window-point-moved?! window 'SINCE-START-SET))))))

;;;; Update

(define (update-outlines! window)
  ;; This procedure sets FORCE-REDRAW? if any cached variable has changed.
  (%recache-window-buffer-local-variables! window)
  (%guarantee-start-mark! window)
  (if (%window-force-redraw? window)
      (begin
	(%set-window-force-redraw?! window #f)
	(preserve-nothing! window))
      (let ((start (%window-current-start-index window))
	    (end (%window-current-end-index window)))
	(cond ((or (not start)
		   (and (%window-start-clip-mark window)
			(or (fix:< start (%window-group-start-index window))
			    (fix:< (%window-group-start-index window)
				   (%window-start-clip-index window))
			    (fix:< (%window-group-end-index window) end)
			    (fix:< (%window-end-clip-index window)
				   (%window-group-end-index window)))))
	       (preserve-nothing! window))
	      ((and (fix:> (group-modified-tick (%window-group window))
			   (%window-modified-tick window))
		    (fix:<= start (%window-end-changes-index window))
		    (fix:<= (%window-start-changes-index window) end))
	       (let ((start-changes
		      (let ((start-changes
			     (%window-start-changes-index window)))
			(if (%window-group-start-index? window start-changes)
			    (%window-group-start-index window)
			    (%window-line-start-index window start-changes))))
		     (end-changes
		      (let ((end-changes (%window-end-changes-index window)))
			(if (%window-group-end-index? window end-changes)
			    (%window-group-end-index window)
			    (%window-line-end-index window end-changes)))))
		 (if (fix:<= start-changes start)
		     (if (fix:< end-changes end)
			 (preserve-bottom! window end-changes end)
			 (preserve-nothing! window))
		     (if (fix:< end-changes end)
			 (preserve-top-and-bottom! window
						   start start-changes
						   end-changes end)
			 (preserve-top! window start start-changes)))))
	      (else
	       (preserve-all! window start end)))))
  (%clear-window-outstanding-changes! window))

(define (preserve-top! window start start-changes)
  (let ((start-outline (%window-start-outline window))
	(start-y (%window-current-start-y window)))
    (let ((last-unchanged
	   (last-unchanged-outline start-outline
				   start
				   start-changes)))
      (deallocate-outlines! window
			    (outline-next last-unchanged)
			    (%window-end-outline window))
      (preserve-contiguous-region! window
				   (make-o3 window start-outline start start-y)
				   (make-o3 window
					    last-unchanged
					    (fix:- start-changes 1)
					    (outline-end-y start-outline
							   start-y))))))

(define (preserve-bottom! window end-changes end)
  (let ((end-outline (%window-end-outline window))
	(end-y (%window-current-end-y window)))
    (let ((first-unchanged
	   (first-unchanged-outline end-outline end end-changes)))
      (if (not (eq? first-unchanged (%window-start-outline window)))
	  (deallocate-outlines! window
				(%window-start-outline window)
				(outline-previous first-unchanged)))
      (preserve-contiguous-region! window
				   (make-o3 window
					    first-unchanged
					    (fix:+ end-changes 1)
					    (outline-start-y end-outline
							     end-y))
				   (make-o3 window end-outline end end-y)))))

(define (preserve-contiguous-region! window start end)
  (let ((wlstart (%window-start-line-index window))
	(wlsy (%window-start-line-y window)))
    (if (maybe-scroll window start end wlstart wlsy)
	(fill-edges window start end)
	(regenerate-outlines window wlstart wlsy))))

(define (preserve-top-and-bottom! window start start-changes end-changes end)
  (let ((wlstart (%window-start-line-index window))
	(wlsy (%window-start-line-y window))
	(top-head (%window-start-outline window))
	(bot-tail (%window-end-outline window))
	(top-start-y (%window-current-start-y window))
	(bot-end-y (%window-current-end-y window)))
    (let ((top-tail (last-unchanged-outline top-head start start-changes))
	  (bot-head (first-unchanged-outline bot-tail end end-changes)))
      (deallocate-outlines! window
			    (outline-next top-tail)
			    (outline-previous bot-head))
      (let ((top-start (make-o3 window top-head start top-start-y))
	    (top-end
	     (make-o3 window
		      top-tail
		      (fix:- start-changes 1)
		      (outline-end-y top-head top-start-y)))
	    (bot-start
	     (make-o3 window
		      bot-head
		      (fix:+ end-changes 1)
		      (outline-start-y bot-tail bot-end-y)))
	    (bot-end (make-o3 window bot-tail end bot-end-y)))
	(if (maybe-scroll window top-start top-end wlstart wlsy)
	    (if (maybe-scroll window bot-start bot-end wlstart wlsy)
		(begin
		  (fill-middle window top-end bot-start)
		  (deallocate-o3! window top-end)
		  (deallocate-o3! window bot-start)
		  (fill-edges window top-start bot-end))
		(fill-edges window top-start top-end))
	    (if (maybe-scroll window bot-start bot-end wlstart wlsy)
		(fill-edges window bot-start bot-end)
		(regenerate-outlines window wlstart wlsy)))))))

(define (preserve-all! window start-index end-index)
  (let ((wlstart (%window-start-line-index window))
	(wlsy (%window-start-line-y window))
	(start-y (%window-current-start-y window))
	(end-y (%window-current-end-y window)))
    (let ((scroll-down
	   (lambda (y)
	     (let ((start
		    (make-o3 window
			     (%window-start-outline window)
			     start-index
			     start-y))
		   (end
		    (make-o3 window
			     (%window-end-outline window)
			     end-index
			     end-y)))
	       (if (scroll-lines-down window start end y)
		   (begin
		     (fill-top window start)
		     (set-outlines! window start end))
		   (regenerate-outlines window wlstart wlsy)))))
	  (scroll-up
	   (lambda (y)
	     (let ((start
		    (make-o3 window
			     (%window-start-outline window)
			     start-index
			     start-y))
		   (end
		    (make-o3 window
			     (%window-end-outline window)
			     end-index
			     end-y)))
	       (if (scroll-lines-up window start end y)
		   (begin
		     (fill-bottom window end)
		     (set-outlines! window start end))
		   (regenerate-outlines window wlstart wlsy))))))
      (cond ((fix:= wlstart start-index)
	     (cond ((fix:= wlsy start-y)
		    (if (%window-point-moved? window)
			(update-cursor! window)
			(%window-modeline-event! window 'PRESERVE-ALL!)))
		   ((fix:< wlsy start-y)
		    (scroll-up wlsy))
		   (else
		    (scroll-down wlsy))))
	    ((fix:< wlstart start-index)
	     (let ((y
		    (predict-y-limited window wlstart wlsy start-index start-y
				       (window-y-size window))))
	       (if (not y)
		   (regenerate-outlines window wlstart wlsy)
		   (scroll-down y))))
	    (else
	     (let ((y
		    (predict-y-limited window wlstart wlsy start-index
				       (fix:- 1 (fix:- end-y start-y))
				       1)))
	       (if (not y)
		   (regenerate-outlines window wlstart wlsy)
		   (scroll-up y))))))))

(define-integrable (preserve-nothing! window)
  (regenerate-outlines window
		       (%window-start-line-index window)
		       (%window-start-line-y window)))

(define (first-unchanged-outline end-outline end end-changes)
  (let loop ((outline end-outline) (end end))
    (let ((end-next (fix:- end (fix:+ (outline-index-length outline) 1))))
      (if (fix:> end-next end-changes)
	  (begin
	    (if (not (outline-previous outline))
		(error "can't find END-CHANGES"))
	    (loop (outline-previous outline) end-next))
	  (begin
	    (if (not (fix:= end-next end-changes))
		(error "overshot END-CHANGES" end-next end-changes))
	    outline)))))

(define (last-unchanged-outline start-outline start start-changes)
  (let loop ((outline start-outline) (start start))
    (let ((start-next (fix:+ start (fix:+ (outline-index-length outline) 1))))
      (if (fix:< start-next start-changes)
	  (begin
	    (if (not (outline-next outline))
		(error "can't find START-CHANGES"))
	    (loop (outline-next outline) start-next))
	  (begin
	    (if (not (fix:= start-next start-changes))
		(error "overshot START-CHANGES" start-next start-changes))
	    outline)))))

(define (regenerate-outlines window wlstart wlsy)
  (let ((start (make-o3 window #f wlstart wlsy))
	(end (make-o3 window #f #f #f)))
    (generate-outlines window start end)
    (set-outlines! window start end)))

(define-integrable (fill-edges window start end)
  (fill-top window start)
  (fill-bottom window end)
  (set-outlines! window start end))

(define (maybe-scroll window start end wlstart wlsy)
  (let ((y
	 (predict-y-limited window wlstart wlsy
			    (o3-index start)
			    (fix:- 1 (fix:- (o3-y end) (o3-y start)))
			    (window-y-size window))))
    (cond ((not y)
	   (deallocate-outlines! window (o3-outline start) (o3-outline end))
	   (deallocate-o3! window start)
	   (deallocate-o3! window end)
	   #f)
	  ((fix:= (o3-y start) y)
	   #t)
	  ((fix:< (o3-y start) y)
	   (scroll-lines-down window start end y))
	  (else
	   (scroll-lines-up window start end y)))))

;;;; Direct Output

;;; The direct output procedures are hairy and should be used only
;;; under restricted conditions.  In particular, the cursor may not be
;;; at the right margin (for insert and forward) or the left margin
;;; (for backward), and the character being inserted must be an
;;; ordinary graphic character.  For insert, the buffer must be
;;; modifiable, and the modeline must already show that it has been
;;; modified.  None of the procedures may be used if the window needs
;;; redisplay.

(define (buffer-window/needs-redisplay? window)
  (%notice-window-changes! window)
  (or (window-needs-redisplay? window)
      (not (%window-saved-screen window))
      (screen-needs-update? (%window-saved-screen window))))

(define (buffer-window/direct-output-forward-char! window)
  (if (%window-debug-trace window)
      ((%window-debug-trace window) 'window window
				    'direct-output-forward-char!))
  (let ((mask (set-interrupt-enables! interrupt-mask/gc-ok)))
    (set-window-point-index! window (fix:+ (%window-point-index window) 1))
    (let ((x-start
	   (fix:+ (inferior-x-start (%window-cursor-inferior window)) 1))
	  (y-start (inferior-y-start (%window-cursor-inferior window))))
      (screen-direct-output-move-cursor
       (%window-saved-screen window)
       (fix:+ (%window-saved-x-start window) x-start)
       (fix:+ (%window-saved-y-start window) y-start))
      (%set-inferior-x-start! (%window-cursor-inferior window) x-start))
    (set-interrupt-enables! mask)
    unspecific))

(define (buffer-window/direct-output-backward-char! window)
  (if (%window-debug-trace window)
      ((%window-debug-trace window) 'window window
				    'direct-output-backward-char!))
  (let ((mask (set-interrupt-enables! interrupt-mask/gc-ok)))
    (set-window-point-index! window (fix:- (%window-point-index window) 1))
    (let ((x-start
	   (fix:- (inferior-x-start (%window-cursor-inferior window)) 1))
	  (y-start (inferior-y-start (%window-cursor-inferior window))))
      (screen-direct-output-move-cursor
       (%window-saved-screen window)
       (fix:+ (%window-saved-x-start window) x-start)
       (fix:+ (%window-saved-y-start window) y-start))
      (%set-inferior-x-start! (%window-cursor-inferior window) x-start))
    (set-interrupt-enables! mask)
    unspecific))

(define (buffer-window/home-cursor! window)
  (if (%window-debug-trace window)
      ((%window-debug-trace window) 'window window 'home-cursor!))
  (if (and (%window-saved-screen window)
	   (fix:<= (%window-saved-xl window) 0)
	   (fix:< 0 (%window-saved-xu window))
	   (fix:<= (%window-saved-yl window) 0)
	   (fix:< 0 (%window-saved-yu window)))
      (let ((mask (set-interrupt-enables! interrupt-mask/gc-ok)))
	(screen-direct-output-move-cursor (%window-saved-screen window)
					  (%window-saved-x-start window)
					  (%window-saved-y-start window))
	(set-interrupt-enables! mask)
	unspecific)))

(define (buffer-window/direct-output-insert-char! window char)
  (if (%window-debug-trace window)
      ((%window-debug-trace window) 'window window
				    'direct-output-insert-char! char))
  (let ((mask (set-interrupt-enables! interrupt-mask/gc-ok)))
    (let ((x-start (inferior-x-start (%window-cursor-inferior window)))
	  (y-start (inferior-y-start (%window-cursor-inferior window))))
      (screen-direct-output-char
       (%window-saved-screen window)
       (fix:+ (%window-saved-x-start window) x-start)
       (fix:+ (%window-saved-y-start window) y-start)
       char
       #f)
      (let ((outline (direct-output-outline window y-start)))
	(set-outline-index-length! outline
				   (fix:+ (outline-index-length outline) 1)))
      (%set-inferior-x-start! (%window-cursor-inferior window)
			      (fix:+ x-start 1)))
    (update-modified-tick! window)
    (set-interrupt-enables! mask)
    unspecific))

(define (buffer-window/direct-output-insert-substring! window string start end)
  (if (%window-debug-trace window)
      ((%window-debug-trace window) 'window window
				    'direct-output-insert-substring!
				    (string-copy string) start end))
  (let ((mask (set-interrupt-enables! interrupt-mask/gc-ok)))
    (group-insert-substring! (%window-group window)
			     (%window-point-index window)
			     string start end)
    (let ((x-start (inferior-x-start (%window-cursor-inferior window)))
	  (y-start (inferior-y-start (%window-cursor-inferior window)))
	  (length (fix:- end start)))
      (screen-direct-output-substring
       (%window-saved-screen window)
       (fix:+ (%window-saved-x-start window) x-start)
       (fix:+ (%window-saved-y-start window) y-start)
       string start end
       #f)
      (let ((outline (direct-output-outline window y-start)))
	(set-outline-index-length! outline
				   (fix:+ (outline-index-length outline)
					  length)))
      (%set-inferior-x-start! (%window-cursor-inferior window)
			      (fix:+ x-start length)))
    (update-modified-tick! window)
    (set-interrupt-enables! mask)
    unspecific))

(define (direct-output-outline window y)
  (let loop
      ((outline (%window-start-outline window))
       (start-y (%window-current-start-y window)))
    (let ((end-y (fix:+ start-y (outline-y-size outline))))
      (if (fix:< y end-y)
	  outline
	  (loop (outline-next outline) end-y)))))

(define (buffer-window/direct-output-insert-newline! window)
  (if (%window-debug-trace window)
      ((%window-debug-trace window) 'window window
				    'direct-output-insert-newline!))
  (let ((mask (set-interrupt-enables! interrupt-mask/gc-ok)))
    (group-insert-char! (%window-group window)
			(%window-point-index window)
			#\newline)
    (let ((end-y (%window-current-end-y window)))
      (screen-direct-output-move-cursor (%window-saved-screen window)
					(%window-saved-x-start window)
					(fix:+ (%window-saved-y-start window)
					       end-y))
      (%set-window-end-outline!
       window
       (make-outline window 0 1 (%window-end-outline window) #f))
      (%set-window-current-end-y! window (fix:+ end-y 1))
      (update-blank-inferior! window #f)
      (%set-inferior-x-start! (%window-cursor-inferior window) 0)
      (%set-inferior-y-start! (%window-cursor-inferior window) end-y))
    (update-modified-tick! window)
    (set-interrupt-enables! mask)
    unspecific))