;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of CMU Common Lisp, please contact
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(ext:file-comment
  "$Header: tty-display.lisp,v 1.1.1.10 91/10/30 08:22:37 wlott Exp $")
;;;
;;; **********************************************************************
;;;
;;;    Written by Bill Chiles.
;;;

(in-package "HEMLOCK-INTERNALS")

(export '(redisplay redisplay-all define-tty-font))



;;;; Macros.

(eval-when (compile eval)
(defmacro tty-hunk-modeline-pos (hunk)
  `(tty-hunk-text-height ,hunk))
) ;eval-when


(defvar *currently-selected-hunk* nil)
(defvar *hunk-top-line*)

(proclaim '(fixnum *hunk-top-line*))

(eval-when (compile eval)
(defmacro select-hunk (hunk)
  `(unless (eq ,hunk *currently-selected-hunk*)
     (setf *currently-selected-hunk* ,hunk)
     (setf *hunk-top-line*
	   (the fixnum
		(1+ (the fixnum
			 (- (the fixnum
				 (tty-hunk-text-position ,hunk))
			    (the fixnum
				 (tty-hunk-text-height ,hunk)))))))))
) ;eval-when


;;; Screen image lines.
;;; 
(defstruct (si-line (:print-function print-screen-image-line)
		    (:constructor %make-si-line (chars)))
  (chars nil :type simple-string)
  (length 0)
  (fonts nil :type list))

(defun make-si-line (n)
  (%make-si-line (make-string n)))

(defun print-screen-image-line (obj str n)
  (declare (ignore n))
  (write-string "#<Screen Image Line \"" str)
  (write-string (si-line-chars obj) str :end (si-line-length obj))
  (write-string "\">" str))


(defun find-identical-prefix (dis-line dis-line-fonts si-line)
  (declare (type dis-line dis-line)
	   (type list dis-line-fonts)
	   (type si-line si-line))
  (let* ((dl-chars (dis-line-chars dis-line))
	 (dl-len (dis-line-length dis-line))
	 (si-chars (si-line-chars si-line))
	 (si-len (si-line-length si-line))
	 (okay-until 0))
    (declare (type simple-string dl-chars si-chars)
	     (type (and unsigned-byte fixnum) dl-len si-len)
	     (type (and unsigned-byte fixnum) okay-until))
    (do ((dl-fonts dis-line-fonts (cdr dis-line-fonts))
	 (si-fonts (si-line-fonts si-line) (cdr si-fonts)))
	((or (null dl-fonts) (null si-fonts))
	 (let ((next-font (car (or dl-fonts si-fonts))))
	   (if next-font
	       (let ((end (min dl-len si-len (cadr next-font))))
		 (or (string/= dl-chars si-chars
			       :start1 okay-until :start2 okay-until
			       :end1 end :end2 end)
		     end))
	       (let ((end (min dl-len si-len)))
		 (or (string/= dl-chars si-chars
			       :start1 okay-until :start2 okay-until
			       :end1 end :end2 end)
		     (if (= dl-len si-len) nil end))))))
      (let ((dl-font (caar dl-fonts))
	    (dl-start (cadar dl-fonts))
	    (dl-stop (cddar dl-fonts))
	    (si-font (caar si-fonts))
	    (si-start (cadar si-fonts))
	    (si-stop (cddar si-fonts)))
	(unless (and (= dl-font si-font)
		     (= dl-start si-start))
	  (let ((font-lossage (min dl-start si-start)))
	    (return (or (string/= dl-chars si-chars
				  :start1 okay-until :start2 okay-until
				  :end1 font-lossage :end2 font-lossage)
			font-lossage))))
	(unless (= dl-stop si-stop)
	  (let ((font-lossage (min dl-stop si-stop)))
	    (return (or (string/= dl-chars si-chars
				  :start1 okay-until :start2 okay-until
				  :end1 font-lossage :end2 font-lossage)
			font-lossage))))
	(let ((mismatch (string/= dl-chars si-chars
				  :start1 okay-until :start2 okay-until
				  :end1 dl-stop :end2 si-stop)))
	  (if mismatch
	      (return mismatch)
	      (setf okay-until dl-stop)))))))


(defun find-identical-suffix (dis-line dis-line-fonts si-line)
  (declare (type dis-line dis-line)
	   (type list dis-line-fonts)
	   (type si-line si-line))
  (let* ((dl-chars (dis-line-chars dis-line))
	 (dl-len (dis-line-length dis-line))
	 (si-chars (si-line-chars si-line))
	 (si-len (si-line-length si-line))
	 (count (dotimes (i (min dl-len si-len) i)
		  (when (char/= (schar dl-chars (- dl-len i 1))
				(schar si-chars (- si-len i 1)))
		    (return i)))))
    (declare (type simple-string dl-chars si-chars)
	     (type (and unsigned-byte fixnum) dl-len si-len))
    (do ((dl-fonts (reverse dis-line-fonts) (cdr dis-line-fonts))
	 (si-fonts (reverse (si-line-fonts si-line)) (cdr si-fonts)))
	((or (null dl-fonts) (null si-fonts))
	 (cond (dl-fonts
		(min (- dl-len (cddar dl-fonts)) count))
	       (si-fonts
		(min (- si-len (cddar si-fonts)) count))
	       (t
		count)))
      (let ((dl-font (caar dl-fonts))
	    (dl-start (- dl-len (cadar dl-fonts)))
	    (dl-stop (- dl-len (cddar dl-fonts)))
	    (si-font (caar si-fonts))
	    (si-start (- si-len (cadar si-fonts)))
	    (si-stop (- si-len (cddar si-fonts))))
	(unless (and (= dl-font si-font)
		     (= dl-stop si-stop))
	  (return (min dl-stop si-stop count)))
	(unless (= dl-start si-start)
	  (return (min dl-start si-start count)))
	(when (<= count dl-start)
	  (return count))))))


(defmacro si-line (screen-image n)
  `(svref ,screen-image ,n))



;;; Font support.

(defvar *tty-font-strings* (make-array font-map-size :initial-element nil)
  "Array of (start-string . end-string) for fonts, or NIL if no such font.")

(defun define-tty-font (font-id &rest stuff)
  (unless (<= 0 font-id (1- font-map-size))
    (error "Bogus font-id: ~S" font-id))
  (cond ((every #'keywordp stuff)
	 (error "Can't extract font strings from the termcap entry yet."))
	((and (= (length stuff) 2)
	      (stringp (car stuff))
	      (stringp (cadr stuff)))
	 (setf (aref *tty-font-strings* font-id)
	       (cons (car stuff) (cadr stuff))))
	(t
	 (error "Bogus font spec: ~S~%Must be either a list of keywords or ~
		 a list of the start string and end string."))))


(defun compute-font-usages (dis-line)
  (do ((results nil)
       (change (dis-line-font-changes dis-line) (font-change-next change))
       (prev nil change))
      ((null change)
       (when prev
	 (let ((font (font-change-font prev)))
	   (when (and (not (zerop font))
		      (aref *tty-font-strings* font))
	     (push (list* (font-change-font prev)
			  (font-change-x prev)
			  (dis-line-length dis-line))
		   results))))
       (nreverse results))
    (when prev
      (let ((font (font-change-font prev)))
	(when (and (not (zerop font))
		   (aref *tty-font-strings* font))
	  (push (list* (font-change-font prev)
		       (font-change-x prev)
		       (font-change-x change))
		results))))))


;;;; Dumb window redisplay.

(defmacro tty-dumb-line-redisplay (device hunk dis-line &optional y)
  (let ((dl (gensym)) (dl-chars (gensym)) (dl-fonts (gensym)) (dl-len (gensym))
	(dl-pos (gensym)) (screen-image-line (gensym)))
    `(let* ((,dl ,dis-line)
	    (,dl-chars (dis-line-chars ,dl))
	    (,dl-fonts (compute-font-usages ,dis-line))
	    (,dl-len (dis-line-length ,dl))
	    (,dl-pos ,(or y `(dis-line-position ,dl))))
       (funcall (tty-device-display-string ,device)
		,hunk 0 ,dl-pos ,dl-chars ,dl-fonts 0 ,dl-len)
       (setf (dis-line-flags ,dl) unaltered-bits)
       (setf (dis-line-delta ,dl) 0)
       (select-hunk ,hunk)
       (let ((,screen-image-line (si-line (tty-device-screen-image ,device)
					  (+ *hunk-top-line* ,dl-pos))))
	 (replace-si-line (si-line-chars ,screen-image-line) ,dl-chars
			  0 0 ,dl-len)
	 (setf (si-line-length ,screen-image-line) ,dl-len)
	 (setf (si-line-fonts ,screen-image-line) ,dl-fonts)))))

(defun tty-dumb-window-redisplay (window)
  (let* ((first (window-first-line window))
	 (hunk (window-hunk window))
	 (device (device-hunk-device hunk))
	 (screen-image (tty-device-screen-image device)))
    (funcall (tty-device-clear-to-eow device) hunk 0 0)
    (do ((i 0 (1+ i))
	 (dl (cdr first) (cdr dl)))
	((eq dl the-sentinel)
	 (setf (window-old-lines window) (1- i))
	 (select-hunk hunk)
	 (do ((last (tty-hunk-text-position hunk))
	      (i (+ *hunk-top-line* i) (1+ i)))
	     ((> i last))
	   (declare (fixnum i last))
	   (let ((si-line (si-line screen-image i)))
	     (setf (si-line-length si-line) 0)
	     (setf (si-line-fonts si-line) nil))))
      (tty-dumb-line-redisplay device hunk (car dl) i))
    (setf (window-first-changed window) the-sentinel
	  (window-last-changed window) first)
    (when (window-modeline-buffer window)
      (let ((dl (window-modeline-dis-line window))
	    (y (tty-hunk-modeline-pos hunk)))
	(unwind-protect
	    (progn
	      (funcall (tty-device-standout-init device) hunk)
	      (funcall (tty-device-clear-to-eol device) hunk 0 y)
	      (tty-dumb-line-redisplay device hunk dl y))
	  (funcall (tty-device-standout-end device) hunk))
	(setf (dis-line-flags dl) unaltered-bits)))))



;;;; Dumb redisplay top n lines of a window.

(defun tty-redisplay-n-lines (window n)
  (let* ((hunk (window-hunk window))
	 (device (device-hunk-device hunk)))
    (funcall (tty-device-clear-lines device) hunk 0 0 n)
    (do ((n n (1- n))
	 (dl (cdr (window-first-line window)) (cdr dl)))
	((or (zerop n) (eq dl the-sentinel)))
      (tty-dumb-line-redisplay device hunk (car dl)))))



;;;; Semi dumb window redisplay

;;; This is for terminals without opening and deleting lines.

;;; TTY-SEMI-DUMB-WINDOW-REDISPLAY is a lot like TTY-SMART-WINDOW-REDISPLAY,
;;; but it calls different line redisplay functions.
;;; 
(defun tty-semi-dumb-window-redisplay (window)
  (let* ((hunk (window-hunk window))
	 (device (device-hunk-device hunk)))
    (let ((first-changed (window-first-changed window))
	  (last-changed (window-last-changed window)))
      ;; Is there anything to do?
      (unless (eq first-changed the-sentinel)
	(if ;; One line-changed.
	    (and (eq first-changed last-changed)
		 (zerop (dis-line-delta (car first-changed))))
	    (tty-semi-dumb-line-redisplay device hunk (car first-changed))
	    ;; More lines changed.
	    (do-semi-dumb-line-writes first-changed last-changed hunk))
	;; Set the bounds so we know we displayed...
	(setf (window-first-changed window) the-sentinel
	      (window-last-changed window) (window-first-line window))))
    ;;
    ;; Clear any extra lines at the end of the window.
    (let ((pos (dis-line-position (car (window-last-line window)))))
      (when (< pos (1- (window-height window)))
	(tty-smart-clear-to-eow hunk (1+ pos)))
      (setf (window-old-lines window) pos))
    ;;
    ;; Update the modeline if needed.
    (when (window-modeline-buffer window)
      (let ((dl (window-modeline-dis-line window)))
	(when (/= (dis-line-flags dl) unaltered-bits)
	  (unwind-protect
	      (progn
		(funcall (tty-device-standout-init device) hunk)
		(tty-smart-line-redisplay device hunk dl
					  (tty-hunk-modeline-pos hunk)))
	    (funcall (tty-device-standout-end device) hunk)))))))

;;; NEXT-DIS-LINE is used in DO-SEMI-DUMB-LINE-WRITES and
;;; COMPUTE-TTY-CHANGES.
;;; 
(eval-when (compile eval)
(defmacro next-dis-line ()
  `(progn 
    (setf prev dl)
    (setf dl (cdr dl))
    (setf flags (dis-line-flags (car dl)))))
) ;eval-when

;;; DO-SEMI-DUMB-LINE-WRITES does what it says until it hits the last
;;; changed line.  The commented out code was a gratuitous optimization,
;;; especially if the first-changed line really is the first changes line.
;;; Anyway, this had to be removed because of this function's use in
;;; TTY-SMART-WINDOW-REDISPLAY, which was punting line moves due to
;;; "Scroll Redraw Ratio".  However, these supposedly moved lines had their
;;; bits set to unaltered bits in COMPUTE-TTY-CHANGES because it was
;;; assuming TTY-SMART-WINDOW-REDISPLAY guaranteed to do line moves.
;;; 
(defun do-semi-dumb-line-writes (first-changed last-changed hunk)
  (let* ((dl first-changed)
	 flags ;(dis-line-flags (car dl))) flags bound for NEXT-DIS-LINE.
	 prev)
    ;;
    ;; Skip old, unchanged, unmoved lines.
    ;; (loop
    ;;  (unless (zerop flags) (return))
    ;;  (next-dis-line))
    ;;
    ;; Write every remaining line.
    (let* ((device (device-hunk-device hunk))
	   (force-output (device-force-output device)))
      (loop
       (tty-semi-dumb-line-redisplay device hunk (car dl))
       (when force-output (funcall force-output))
       (next-dis-line)
       (when (eq prev last-changed) (return))))))

;;; TTY-SEMI-DUMB-LINE-REDISPLAY finds the first different character
;;; comparing the display line and the screen image line, writes out the
;;; rest of the display line, and clears to end-of-line as necessary.
;;; 
(defun tty-semi-dumb-line-redisplay (device hunk dl
				     &optional (dl-pos (dis-line-position dl)))
  (declare (fixnum dl-pos))
  (let* ((dl-chars (dis-line-chars dl))
	 (dl-len (dis-line-length dl))
	 (dl-fonts (compute-font-usages dl)))
    (declare (fixnum dl-len) (simple-string dl-chars))
    (when (listen-editor-input *editor-input*)
      (throw 'redisplay-catcher :editor-input))
    (select-hunk hunk)
    (let* ((screen-image-line (si-line (tty-device-screen-image device)
				       (+ *hunk-top-line* dl-pos)))
	   (si-line-chars (si-line-chars screen-image-line))
	   (si-line-length (si-line-length screen-image-line))
	   (findex (find-identical-prefix dl dl-fonts screen-image-line)))
      (declare (type (or fixnum null) findex) (simple-string si-line-chars))
      ;;
      ;; When the dis-line and screen chars are not string=.
      (when findex
	(cond
	 ;; See if the screen shows an initial substring of the dis-line.
	 ((= findex si-line-length)
	  (funcall (tty-device-display-string device)
		   hunk findex dl-pos dl-chars dl-fonts findex dl-len)
	  (replace-si-line si-line-chars dl-chars findex findex dl-len))
	 ;; When the dis-line is an initial substring of what's on the screen.
	 ((= findex dl-len)
	  (funcall (tty-device-clear-to-eol device) hunk dl-len dl-pos))
	 ;; Otherwise, blast dl-chars and clear to eol as necessary.
	 (t (funcall (tty-device-display-string device)
		     hunk findex dl-pos dl-chars dl-fonts findex dl-len)
	    (when (< dl-len si-line-length)
	      (funcall (tty-device-clear-to-eol device) hunk dl-len dl-pos))
	    (replace-si-line si-line-chars dl-chars findex findex dl-len)))
	(setf (si-line-length screen-image-line) dl-len)
	(setf (si-line-fonts screen-image-line) dl-fonts)))
    (setf (dis-line-flags dl) unaltered-bits)
    (setf (dis-line-delta dl) 0)))



;;;; Smart window redisplay -- operation queues and internal screen image.

;;; This is used for creating temporary smart redisplay structures.
;;; 
(defconstant tty-hunk-height-limit 100)


;;; Queues for redisplay operations and access macros.
;;; 
(defvar *tty-line-insertions* (make-array (* 2 tty-hunk-height-limit)))

(defvar *tty-line-deletions* (make-array (* 2 tty-hunk-height-limit)))

(defvar *tty-line-writes* (make-array tty-hunk-height-limit))

(defvar *tty-line-moves* (make-array tty-hunk-height-limit))

(eval-when (compile eval)

(defmacro queue (value queue ptr)
  `(progn
    (setf (svref ,queue ,ptr) ,value)
    (the fixnum (incf (the fixnum ,ptr)))))

(defmacro dequeue (queue ptr)
  `(prog1
    (svref ,queue ,ptr)
    (the fixnum (incf (the fixnum ,ptr)))))

) ;eval-when

;;; INSERT-LINE-COUNT is used in TTY-SMART-WINDOW-REDISPLAY.  The counting is
;;; based on calls to QUEUE in COMPUTE-TTY-CHANGES.
;;; 
(defun insert-line-count (ins)
  (do ((i 1 (+ i 2))
       (count 0 (+ count (svref *tty-line-insertions* i))))
      ((> i ins) count)))


;;; Temporary storage for screen-image lines and accessing macros.
;;; 
(defvar *screen-image-temp* (make-array tty-hunk-height-limit))

(eval-when (compile eval)

;;; DELETE-SI-LINES is used in DO-LINE-DELETIONS to simulate what's
;;; happening to the screen in a device's screen-image.  At y, num
;;; lines are deleted and saved in *screen-image-temp*; fsil is the
;;; end of the free screen image lines saved here.  Also, we must
;;; move lines up in the screen-image structure.  In the outer loop
;;; we save lines in the temp storage and move lines up at the same
;;; time.  In the termination/inner loop we move any lines that still
;;; need to be moved up.  The screen-length is adjusted by the fsil
;;; because any time a deletion is in progress, there are fsil bogus
;;; lines at the bottom of the screen image from lines being moved
;;; up previously.
;;; 
(defmacro delete-si-lines (screen-image y num fsil screen-length)
  (let ((do-screen-image (gensym)) (delete-index (gensym))
	(free-lines (gensym)) (source-index (gensym)) (target-index (gensym))
	(n (gensym)) (do-screen-length (gensym)) (do-y (gensym)))
    `(let ((,do-screen-image ,screen-image)
	   (,do-screen-length (- ,screen-length fsil))
	   (,do-y ,y))
       (declare (fixnum ,do-screen-length ,do-y))
       (do ((,delete-index ,do-y (1+ ,delete-index))
	    (,free-lines ,fsil (1+ ,free-lines))
	    (,source-index (+ ,do-y ,num) (1+ ,source-index))
	    (,n ,num (1- ,n)))
	   ((zerop ,n)
	    (do ((,target-index ,delete-index (1+ ,target-index))
		 (,source-index ,source-index (1+ ,source-index)))
		((>= ,source-index ,do-screen-length))
	      (declare (fixnum ,target-index ,source-index))
	      (setf (si-line ,do-screen-image ,target-index)
		    (si-line ,do-screen-image ,source-index))))
	 (declare (fixnum ,delete-index ,free-lines ,source-index ,n))
	 (setf (si-line *screen-image-temp* ,free-lines)
	       (si-line ,do-screen-image ,delete-index))
	 (when (< ,source-index ,do-screen-length)
	   (setf (si-line ,do-screen-image ,delete-index)
		 (si-line ,do-screen-image ,source-index)))))))


;;; INSERT-SI-LINES is used in DO-LINE-INSERTIONS to simulate what's
;;; happening to the screen in a device's screen-image.  At y, num free
;;; lines are inserted from *screen-image-temp*; fsil is the end of the
;;; free lines.  When copying lines down in screen-image, we must start
;;; with the lower lines and end with the higher ones, so we don't trash
;;; any lines.  The outer loop does all the copying, and the termination/
;;; inner loop inserts the free screen image lines, setting their length
;;; to zero.
;;; 
(defmacro insert-si-lines (screen-image y num fsil screen-length)
  (let ((do-screen-image (gensym)) (source-index (gensym))
	(target-index (gensym)) (target-terminus (gensym))
	(do-screen-length (gensym)) (temp (gensym)) (do-y (gensym))
	(insert-index (gensym)) (free-lines-index (gensym))
	(n (gensym)))
    `(let ((,do-screen-length ,screen-length)
	   (,do-screen-image ,screen-image)
	   (,do-y ,y))
       (do ((,target-terminus (1- (+ ,do-y ,num)))	 ; (1- target-start)
	    (,source-index (- ,do-screen-length ,fsil 1) ; (1- source-end)
			   (1- ,source-index))
	    (,target-index (- (+ ,do-screen-length ,num)
			      ,fsil 1)			 ; (1- target-end)
		(1- ,target-index)))
	   ((= ,target-index ,target-terminus)
	    (do ((,insert-index ,do-y (1+ ,insert-index))
		 (,free-lines-index (1- ,fsil) (1- ,free-lines-index))
		 (,n ,num (1- ,n)))
		((zerop ,n))
	      (declare (fixnum ,insert-index ,free-lines-index ,n))
	      (let ((,temp (si-line *screen-image-temp* ,free-lines-index)))
		(setf (si-line-length ,temp) 0)
		(setf (si-line-fonts ,temp) nil)
		(setf (si-line ,do-screen-image ,insert-index) ,temp)))
	    (decf ,fsil ,num))
	 (declare (fixnum ,target-terminus ,source-index ,target-index))
	 (setf (si-line ,do-screen-image ,target-index)
	       (si-line ,do-screen-image ,source-index))))))

) ;eval-when



;;;; Smart window redisplay -- the function.

;;; TTY-SMART-WINDOW-REDISPLAY sees if only one line changed after
;;; some preliminary processing.  If more than one line changed,
;;; then we compute changes to make to the screen in the form of
;;; line insertions, deletions, and writes.  Deletions must be done
;;; first, so lines are not lost off the bottom of the screen by
;;; inserting lines.
;;; 
(defun tty-smart-window-redisplay (window)
  (let* ((hunk (window-hunk window))
	 (device (device-hunk-device hunk)))
    (let ((first-changed (window-first-changed window))
	  (last-changed (window-last-changed window)))
      ;; Is there anything to do?
      (unless (eq first-changed the-sentinel)
	(if (and (eq first-changed last-changed)
		 (zerop (dis-line-delta (car first-changed))))
	    ;; One line-changed.
	    (tty-smart-line-redisplay device hunk (car first-changed))
	    ;; More lines changed.
	    (multiple-value-bind (ins outs writes moves)
				 (compute-tty-changes
				  first-changed last-changed
				  (tty-hunk-modeline-pos hunk))
	      (let ((ratio (variable-value 'ed::scroll-redraw-ratio)))
		(cond ((and ratio
			    (> (/ (insert-line-count ins)
				  (tty-hunk-text-height hunk))
			       ratio))
		       (do-semi-dumb-line-writes first-changed last-changed
						 hunk))
		      (t
		       (do-line-insertions hunk ins
					   (do-line-deletions hunk outs))
		       (note-line-moves moves)
		       (do-line-writes hunk writes))))))
	;; Set the bounds so we know we displayed...
	(setf (window-first-changed window) the-sentinel
	      (window-last-changed window) (window-first-line window))))
    ;;
    ;; Clear any extra lines at the end of the window.
    (let ((pos (dis-line-position (car (window-last-line window)))))
      (when (< pos (1- (window-height window)))
	(tty-smart-clear-to-eow hunk (1+ pos)))
      (setf (window-old-lines window) pos))
    ;;
    ;; Update the modeline if needed.
    (when (window-modeline-buffer window)
      (let ((dl (window-modeline-dis-line window)))
	(when (/= (dis-line-flags dl) unaltered-bits)
	  (unwind-protect
	      (progn
		(funcall (tty-device-standout-init device) hunk)
		(tty-smart-line-redisplay device hunk dl
					  (tty-hunk-modeline-pos hunk)))
	    (funcall (tty-device-standout-end device) hunk)))))))



;;;; Smart window redisplay -- computing changes to the display.

;;; There is a lot of documentation here to help since this code is not
;;; obviously correct.  The code is not that cryptic, but the correctness
;;; of the algorithm is somewhat.  Most of the complexity is in handling
;;; lines that moved on the screen which the introduction deals with.
;;; Also, the block of documentation immediately before the function
;;; COMPUTE-TTY-CHANGES has its largest portion dedicated to this part of
;;; the function which is the largest block of code in the function.

;;; The window image dis-lines are annotated with the difference between
;;; their current intended locations and their previous locations in the
;;; window.  This delta (distance moved) is negative for an upward move and
;;; positive for a downward move.  To determine what to do with moved
;;; groups of lines, we consider the transition (or difference in deltas)
;;; between two adjacent groups as we look at the window's dis-lines moving
;;; down the window image, disregarding whether they are contiguous (having
;;; moved only by a different delta) or separated by some lines (such as
;;; lines that are new and unmoved).
;;;
;;; Considering the transition between moved groups makes sense because a
;;; given group's delta affects all the lines below it since the dis-lines
;;; reflect the window's buffer's actual lines which are all connected in
;;; series.  Therefore, if the previous group moved up some delta number of
;;; lines because of line deletions, then the lines below this group (down
;;; to the last line of the window image) moved up by the same delta too,
;;; unless one of the following is true:
;;;    1] The lines below the group moved up by a greater delta, possibly
;;;       due to multiple disjoint buffer line deletions.
;;;    2] The lines below the group moved up by a lesser delta, possibly
;;;       due to a number (less than the previous delta) of new line
;;;       insertions below the group that moved up.
;;;    3] The lines below the group moved down, possibly due to a number
;;;       (greater than the previous delta) of new line insertions below
;;;       the group that moved up.
;;; Similarly, if the previous group moved down some delta number of lines
;;; because of new line insertions, then the lines below this group (down
;;; to the last line of the window image not to fall off the window's lower
;;; edge) moved down by the same delta too, unless one of the following is
;;; true:
;;;    1] The lines below the group moved down by a greater delta, possibly
;;;       due to multiple disjoint buffer line insertions.
;;;    2] The lines below the group moved down by a lesser delta, possibly
;;;       due to a number (less than the previous delta) of line deletions
;;;       below the group that moved down.
;;;    3] The lines below the group moved up, possibly due to a number
;;;       (greater than the previous delta) of line deletions below the
;;;       group that moved down.
;;;
;;; Now we can see how the first moved group affects the window image below
;;; it except where there is a lower group of lines that have moved a
;;; different delta due to separate operations on the buffer's lines viewed
;;; through a window.  We can see that this different delta is the expected
;;; effect throughout the window image below the second group, unless
;;; something lower down again has affected the window image.  Also, in the
;;; case of a last group of lines that moved up, the group will never
;;; reflect all of the lines in the window image from the first line to
;;; move down to the bottom of the window image because somewhere down below
;;; the group that moved up are some new lines that have just been drawn up
;;; into the window's image.
;;;

;;; COMPUTE-TTY-CHANGES is used once in TTY-SMART-WINDOW-REDISPLAY.
;;; It goes through all the display lines for a window recording where
;;; lines need to be inserted, deleted, or written to make the screen
;;; consistent with the internal image of the screen.  Pointers to
;;; the insertions, deletions, and writes that have to be done are
;;; returned.
;;; 
;;; If a line is new, then simply queue it to be written.
;;; 
;;; If a line is moved and/or changed, then we compute the difference
;;; between the last block of lines that moved with the same delta and the
;;; current block of lines that moved with the current delta.  If this
;;; difference is positive, then some lines need to be deleted.  Since we
;;; do all the line deletions first to prevent line insertions from
;;; dropping lines off the bottom of the screen, we have to compute the
;;; position of line deletions using the cumulative insertions
;;; (cum-inserts).  Without any insertions, deletions may be done right at
;;; the dis-line's new position.  With insertions needed above a given
;;; deletion point combined with the fact that deletions are all done
;;; first, the location for the deletion is higher than it would be without
;;; the insertions being done above the deletions.  The location of the
;;; deletion is higher by the number of insertions we have currently put
;;; off.  When computing the position of line insertions (a negative delta
;;; transition), we do not need to consider the cumulative insertions or
;;; cumulative deletions since everything above the point of insertion
;;; (both deletions and insertions) has been done.  Because of the screen
;;; state being correct above the point of an insertion, the screen is only
;;; off by the delta transition number of lines.  After determining the
;;; line insertions or deletions, loop over contiguous lines with the same
;;; delta queuing any changed ones to be written.  The delta and flag
;;; fields are initialized according to the need to be written; since
;;; redisplay may be interrupted by more user input after moves have been
;;; done to the screen, we save the changed bit on, so the line will be
;;; queued to be written after redisplay is re-entered.
;;; 
;;; If the line is changed or new, then queue it to be written.  Since we can
;;; abort out of the actual dislpay at any time (due to pending input), we
;;; don't clear the flags or delta here.  A dis-line may be groveled many times
;;; by this function before it actually makes it to the screen, so we may have
;;; odd combinations of bits such as both new and changed.
;;; 
;;; Otherwise, get the next display line, loop, and see if it's
;;; interesting.
;;; 
(defun compute-tty-changes (first-changed last-changed modeline-pos)
  (declare (fixnum modeline-pos))
  (let* ((dl first-changed)
	 (flags (dis-line-flags (car dl)))
	 (ins 0) (outs 0) (writes 0) (moves 0)
	 (prev-delta 0) (cum-deletes 0) (net-delta 0) (cum-inserts 0)
	 prev)
    (declare (fixnum flags ins outs writes moves prev-delta cum-deletes
		     net-delta cum-inserts))
    (loop
      (cond
       ((logtest flags new-bit)
	(queue (car dl) *tty-line-writes* writes)
	(next-dis-line))
       ((logtest flags moved-bit)
	(let* ((start-dl (car dl))
	       (start-pos (dis-line-position start-dl))
	       (curr-delta (dis-line-delta start-dl))
	       (delta-delta (- prev-delta curr-delta))
	       (car-dl start-dl))
	  (declare (fixnum start-pos curr-delta delta-delta))
	  (cond ((plusp delta-delta)
		 (queue (the fixnum (- start-pos cum-inserts))
			*tty-line-deletions* outs)
		 (queue delta-delta *tty-line-deletions* outs)
		 (incf cum-deletes delta-delta)
		 (decf net-delta delta-delta))
		((minusp delta-delta)
		 (let ((eff-pos (the fixnum (+ start-pos delta-delta)))
		       (num (the fixnum (- delta-delta))))
		   (queue eff-pos *tty-line-insertions* ins)
		   (queue num *tty-line-insertions* ins)
		   (incf net-delta num)
		   (incf cum-inserts num))))
	  (loop
	    (if (logtest flags (logior changed-bit new-bit))
		(queue car-dl *tty-line-writes* writes)
		(queue car-dl *tty-line-moves* moves))
	    (next-dis-line)
	    (setf car-dl (car dl))
	    (when (or (eq prev last-changed)
		      (/= (the fixnum (dis-line-delta car-dl)) curr-delta))
	      (setf prev-delta curr-delta)
	      (return)))))
       ((logtest flags (logior changed-bit new-bit))
	(queue (car dl) *tty-line-writes* writes)
	(next-dis-line))
       (t
	(next-dis-line)))

      (when (eq prev last-changed)
	(unless (zerop net-delta)
	  (cond ((plusp net-delta)
		 (queue (the fixnum (- modeline-pos cum-deletes net-delta))
			*tty-line-deletions* outs)
		 (queue net-delta *tty-line-deletions* outs))
		(t (queue (the fixnum (+ modeline-pos net-delta))
			  *tty-line-insertions* ins)
		   (queue (the fixnum (- net-delta))
			  *tty-line-insertions* ins))))
	(return (values ins outs writes moves))))))


;;;; Smart window redisplay -- operation methods.

;;; TTY-SMART-CLEAR-TO-EOW clears lines y through the last text line of hunk.
;;; It takes care not to clear a line unless it really has some characters
;;; displayed on it.  It also maintains the device's screen image lines.
;;; 
(defun tty-smart-clear-to-eow (hunk y)
  (let* ((device (device-hunk-device hunk))
	 (screen-image (tty-device-screen-image device))
	 (clear-to-eol (tty-device-clear-to-eol device)))
    (select-hunk hunk)
    (do ((y y (1+ y))
	 (si-idx (+ *hunk-top-line* y) (1+ si-idx))
	 (last (tty-hunk-text-position hunk)))
	((> si-idx last))
      (declare (fixnum y si-idx last))
      (let ((si-line (si-line screen-image si-idx)))
	(unless (zerop (si-line-length si-line))
	  (funcall clear-to-eol hunk 0 y)
	  (setf (si-line-length si-line) 0)
	  (setf (si-line-fonts si-line) nil))))))

;;; NOTE-LINE-MOVES  --  Internal
;;;
;;;    Clear out the flags and delta of lines that have been moved.
;;;
(defun note-line-moves (moves)
  (let ((i 0))
    (loop
      (when (= i moves) (return))
      (let ((dl (dequeue *tty-line-moves* i)))
	(setf (dis-line-flags dl) unaltered-bits)
	(setf (dis-line-delta dl) 0)))))

;;; DO-LINE-DELETIONS pops elements off the *tty-lines-deletions* queue,
;;; deleting lines from hunk's area of the screen.  The internal screen
;;; image is updated, and the total number of lines deleted is returned.
;;; 
(defun do-line-deletions (hunk outs)
  (declare (fixnum outs))
  (let* ((i 0)
	 (device (device-hunk-device hunk))
	 (fun (tty-device-delete-line device))
	 (fsil 0)) ;free-screen-image-lines
    (declare (fixnum i fsil))
    (loop
     (when (= i outs) (return fsil))
     (let ((y (dequeue *tty-line-deletions* i))
	   (num (dequeue *tty-line-deletions* i)))
       (declare (fixnum y num))
       (funcall fun hunk 0 y num)
       (select-hunk hunk)
       (delete-si-lines (tty-device-screen-image device)
			(+ *hunk-top-line* y) num fsil
			(tty-device-lines device))
       (incf fsil num)))))

;;; DO-LINE-INSERTIONS pops elements off the *tty-line-insertions* queue,
;;; inserting lines into hunk's area of the screen.  The internal screen
;;; image is updated using free screen image lines pointed to by fsil.
;;; 
(defun do-line-insertions (hunk ins fsil)
  (declare (fixnum ins fsil))
  (let* ((i 0)
	 (device (device-hunk-device hunk))
	 (fun (tty-device-open-line device)))
    (declare (fixnum i))
    (loop
     (when (= i ins) (return))
     (let ((y (dequeue *tty-line-insertions* i))
	   (num (dequeue *tty-line-insertions* i)))
       (declare (fixnum y num))
       (funcall fun hunk 0 y num)
       (select-hunk hunk)
       (insert-si-lines (tty-device-screen-image device)
			(+ *hunk-top-line* y) num fsil
			(tty-device-lines device))))))

;;; DO-LINE-WRITES pops elements off the *tty-line-writes* queue, displaying
;;; these dis-lines with TTY-SMART-LINE-REDISPLAY.  We force output after
;;; each line, so the user can see how far we've gotten in case he chooses
;;; to give more editor commands which will abort redisplay until there's no
;;; more input.
;;; 
(defun do-line-writes (hunk writes)
  (declare (fixnum writes))
  (let* ((i 0)
	 (device (device-hunk-device hunk))
	 (force-output (device-force-output device)))
    (declare (fixnum i))
    (loop
     (when (= i writes) (return))
     (tty-smart-line-redisplay device hunk (dequeue *tty-line-writes* i))
     (when force-output (funcall force-output)))))

;;; TTY-SMART-LINE-REDISPLAY uses an auxiliary screen image structure to
;;; try to do minimal character shipping to the terminal.  Roughly, we find
;;; the first different character when comparing what's on the screen and
;;; what should be there; we will start altering the line after this same
;;; initial substring.  Then we find, from the end, the first character
;;; that is different, blasting out characters to the lesser of the two
;;; indexes.  If the dis-line index is lesser, we have some characters to
;;; delete from the screen, and if the screen index is lesser, we have some
;;; additional dis-line characters to insert.  There are a few special
;;; cases that allow us to punt out of the above algorithm sketch.  If the
;;; terminal doesn't have insert mode or delete mode, we have blast out to
;;; the end of the dis-line and possibly clear to the end of the screen's
;;; line, as appropriate.  Sometimes we don't use insert or delete mode
;;; because of the overhead cost in characters; it simply is cheaper to
;;; blast out characters and clear to eol.
;;; 
(defun tty-smart-line-redisplay (device hunk dl
				 &optional (dl-pos (dis-line-position dl)))
  (declare (fixnum dl-pos))
  (let* ((dl-chars (dis-line-chars dl))
	 (dl-len (dis-line-length dl))
	 (dl-fonts (compute-font-usages dl)))
    (declare (fixnum dl-len) (simple-string dl-chars))
    (when (listen-editor-input *editor-input*)
      (throw 'redisplay-catcher :editor-input))
    (select-hunk hunk)
    (let* ((screen-image-line (si-line (tty-device-screen-image device)
				       (+ *hunk-top-line* dl-pos)))
	   (si-line-chars (si-line-chars screen-image-line))
	   (si-line-length (si-line-length screen-image-line))
	   (findex (find-identical-prefix dl dl-fonts screen-image-line)))
      (declare (type (or fixnum null) findex) (simple-string si-line-chars))
      ;;
      ;; When the dis-line and screen chars are not string=.
      (when findex
	(block tslr-main-body
	  ;;
	  ;; See if the screen shows an initial substring of the dis-line.
	  (when (= findex si-line-length)
	    (funcall (tty-device-display-string device)
		     hunk findex dl-pos dl-chars dl-fonts findex dl-len)
	    (replace-si-line si-line-chars dl-chars findex findex dl-len)
	    (return-from tslr-main-body t))
	  ;;
	  ;; When the dis-line is an initial substring of what's on the screen.
	  (when (= findex dl-len)
	    (funcall (tty-device-clear-to-eol device) hunk dl-len dl-pos)
	    (return-from tslr-main-body t))
	  ;;
	  ;; Find trailing substrings that are the same.
	  (multiple-value-bind
	      (sindex dindex)
	      (let ((count (find-identical-suffix dl dl-fonts
						  screen-image-line)))
		(values (- si-line-length count)
			(- dl-len count)))
	    (declare (fixnum sindex dindex))
	    ;;
	    ;; No trailing substrings -- blast and clear to eol.
	    (when (= dindex dl-len)
	      (funcall (tty-device-display-string device)
		       hunk findex dl-pos dl-chars dl-fonts findex dl-len)
	      (when (< dindex sindex)
		(funcall (tty-device-clear-to-eol device)
			 hunk dl-len dl-pos))
	      (replace-si-line si-line-chars dl-chars findex findex dl-len)
	      (return-from tslr-main-body t))
	    (let ((lindex (min sindex dindex)))
	      (cond ((< lindex findex)
		     ;; This can happen in funny situations -- believe me!
		     (setf lindex findex))
		    (t
		     (funcall (tty-device-display-string device)
			      hunk findex dl-pos dl-chars dl-fonts
			      findex lindex)
		     (replace-si-line si-line-chars dl-chars
				      findex findex lindex)))
	      (cond
	       ((= dindex sindex))
	       ((< dindex sindex)
		(let ((delete-char-num (- sindex dindex)))
		  (cond ((and (tty-device-delete-char device)
			      (worth-using-delete-mode
			       device delete-char-num (- si-line-length dl-len)))
			 (funcall (tty-device-delete-char device)
				  hunk dindex dl-pos delete-char-num))
			(t 
			 (funcall (tty-device-display-string device)
				  hunk dindex dl-pos dl-chars dl-fonts
				  dindex dl-len)
			 (funcall (tty-device-clear-to-eol device)
				  hunk dl-len dl-pos)))))
	       (t
		(if (and (tty-device-insert-string device)
			 (worth-using-insert-mode device (- dindex sindex)
						  (- dl-len sindex)))
		    (funcall (tty-device-insert-string device)
			     hunk sindex dl-pos dl-chars sindex dindex)
		    (funcall (tty-device-display-string device)
			     hunk sindex dl-pos dl-chars dl-fonts
			     sindex dl-len))))
	      (replace-si-line si-line-chars dl-chars
			       lindex lindex dl-len))))
	(setf (si-line-length screen-image-line) dl-len)
	(setf (si-line-fonts screen-image-line) dl-fonts)))
    (setf (dis-line-flags dl) unaltered-bits)
    (setf (dis-line-delta dl) 0)))



;;;; Device methods

;;; Initializing and exiting the device (DEVICE-INIT and DEVICE-EXIT functions).
;;; These can be found in Tty-Display-Rt.Lisp.


;;; Clearing the device (DEVICE-CLEAR functions).

(defun clear-device (device)
  (device-write-string (tty-device-clear-string device))
  (cursor-motion device 0 0)
  (setf (tty-device-cursor-x device) 0)
  (setf (tty-device-cursor-y device) 0))


;;; Moving the cursor around (DEVICE-PUT-CURSOR)

;;; TTY-PUT-CURSOR makes sure the coordinates are mapped from the hunk's
;;; axis to the screen's and determines the minimal cost cursor motion
;;; sequence.  Currently, it does no cost analysis of relative motion
;;; compared to absolute motion but simply makes sure the cursor isn't
;;; already where we want it.
;;;
(defun tty-put-cursor (hunk x y)
  (declare (fixnum x y))
  (select-hunk hunk)
  (let ((y (the fixnum (+ *hunk-top-line* y)))
	(device (device-hunk-device hunk)))
    (declare (fixnum y))
    (unless (and (= (the fixnum (tty-device-cursor-x device)) x)
		 (= (the fixnum (tty-device-cursor-y device)) y))
      (cursor-motion device x y)
      (setf (tty-device-cursor-x device) x)
      (setf (tty-device-cursor-y device) y))))

;;; UPDATE-CURSOR is used in device redisplay methods to make sure the
;;; cursor is where it should be.
;;; 
(eval-when (compile eval)
  (defmacro update-cursor (hunk x y)
    `(funcall (device-put-cursor (device-hunk-device ,hunk)) ,hunk ,x ,y))
) ;eval-when

;;; CURSOR-MOTION takes two coordinates on the screen's axis,
;;; moving the cursor to that location.  X is the column index,
;;; and y is the line index, but Unix and Termcap believe that
;;; the default order of indexes is first the line and then the
;;; column or (y,x).  Because of this, when reversep is non-nil,
;;; we send first x and then y.
;;; 
(defun cursor-motion (device x y)
  (let ((x-add-char (tty-device-cm-x-add-char device))
	(y-add-char (tty-device-cm-y-add-char device))
	(x-condx-add (tty-device-cm-x-condx-char device))
	(y-condx-add (tty-device-cm-y-condx-char device))
	(one-origin (tty-device-cm-one-origin device)))
    (when x-add-char (incf x x-add-char))
    (when (and x-condx-add (> x x-condx-add))
      (incf x (tty-device-cm-x-condx-add-char device)))
    (when y-add-char (incf y y-add-char))
    (when (and y-condx-add (> y y-condx-add))
      (incf y (tty-device-cm-y-condx-add-char device)))
    (when one-origin (incf x) (incf y)))
  (device-write-string (tty-device-cm-string1 device))
  (let ((reversep (tty-device-cm-reversep device))
	(x-pad (tty-device-cm-x-pad device))
	(y-pad (tty-device-cm-y-pad device)))
    (if reversep
	(cm-output-coordinate x x-pad)
	(cm-output-coordinate y y-pad))
    (device-write-string (tty-device-cm-string2 device))
    (if reversep
	(cm-output-coordinate y y-pad)
	(cm-output-coordinate x x-pad))
    (device-write-string (tty-device-cm-string3 device))))

;;; CM-OUTPUT-COORDINATE outputs the coordinate with respect to the pad.  If
;;; there is a pad, then the coordinate needs to be sent as digit-char's (for
;;; each digit in the coordinate), and if there is no pad, the coordinate needs
;;; to be converted into a character.  Using CODE-CHAR here is not really
;;; portable.  With a pad, the coordinate buffer is filled from the end as we
;;; truncate the coordinate by 10, generating ones digits.
;;;
(defconstant cm-coordinate-buffer-len 5)
(defvar *cm-coordinate-buffer* (make-string cm-coordinate-buffer-len))
;;;
(defun cm-output-coordinate (coordinate pad)
  (cond (pad
	 (let ((i (1- cm-coordinate-buffer-len)))
	   (loop
	     (when (= i -1) (error "Terminal has too many lines!"))
	     (multiple-value-bind (tens ones)
				  (truncate coordinate 10)
	       (setf (schar *cm-coordinate-buffer* i) (digit-char ones))
	       (when (zerop tens)
		 (dotimes (n (- pad (- cm-coordinate-buffer-len i)))
		   (decf i)
		   (setf (schar *cm-coordinate-buffer* i) #\0))
		 (device-write-string *cm-coordinate-buffer* i
				      cm-coordinate-buffer-len)
		 (return))
	       (decf i)
	       (setf coordinate tens)))))
	(t (tty-write-char (code-char coordinate)))))


;;; Writing strings (TTY-DEVICE-DISPLAY-STRING functions)

;;; DISPLAY-STRING is used to put a string at (x,y) on the device.
;;; 
(defun display-string (hunk x y string font-info
			    &optional (start 0) (end (strlen string)))
  (declare (fixnum x y start end))
  (update-cursor hunk x y)
  ;; Ignore font info for chars before the start of the string.
  (loop
    (if (or (null font-info)
	    (< start (cddar font-info)))
	(return)
	(pop font-info)))
  (let ((posn start))
    (dolist (next-font font-info)
      (let ((font (car next-font))
	    (start (cadr next-font))
	    (stop (cddr next-font)))
	(when (<= end start)
	  (return))
	(when (< posn start)
	  (device-write-string string posn start)
	  (setf posn start))
	(let ((new-posn (min stop end))
	      (font-strings (aref *tty-font-strings* font)))
	  (unwind-protect
	      (progn
		(device-write-string (car font-strings))
		(device-write-string string posn new-posn))
	    (device-write-string (cdr font-strings)))
	  (setf posn new-posn))))
    (when (< posn end)
      (device-write-string string posn end)))
  (setf (tty-device-cursor-x (device-hunk-device hunk))
	(the fixnum (+ x (the fixnum (- end start))))))

;;; DISPLAY-STRING-CHECKING-UNDERLINES is used for terminals that special
;;; case underlines doing an overstrike when they don't otherwise overstrike.
;;; Note: we do not know in this code whether the terminal can backspace (or
;;; what the sequence is), whether the terminal has insert-mode, or whether
;;; the terminal has delete-mode.
;;; 
(defun display-string-checking-underlines (hunk x y string font-info
						&optional (start 0)
						          (end (strlen string)))
  (declare (ignore font-info))
  (declare (fixnum x y start end) (simple-string string))
  (update-cursor hunk x y)
  (let ((upos (position #\_ string :test #'char= :start start :end end))
	(device (device-hunk-device hunk)))
    (if upos
	(let ((previous start)
	      (after-pos 0))
	  (declare (fixnum previous after-pos))
	  (loop (device-write-string string previous upos)
		(setf after-pos (do ((i (1+ upos) (1+ i)))
				    ((or (= i end)
					 (char/= (schar string i) #\_)) i)
				  (declare (fixnum i))))
		(let ((ulen (the fixnum (- after-pos upos)))
		      (cursor-x (the fixnum (+ x (the fixnum
						      (- after-pos start))))))
		  (declare (fixnum ulen))
		  (dotimes (i ulen) (tty-write-char #\space))
		  (setf (tty-device-cursor-x device) cursor-x)
		  (update-cursor hunk upos y)
		  (dotimes (i ulen) (tty-write-char #\_))
		  (setf (tty-device-cursor-x device) cursor-x))
		(setf previous after-pos)
		(setf upos (position #\_ string :test #'char=
				     :start previous :end end))
		(unless upos
		  (device-write-string string previous end)
		  (return))))
	(device-write-string string start end))
    (setf (tty-device-cursor-x device)
	  (the fixnum (+ x (the fixnum (- end start)))))))
	   

;;; DEVICE-WRITE-STRING is used to shove a string at the terminal regardless
;;; of cursor position.
;;; 
(defun device-write-string (string &optional (start 0) (end (strlen string)))
  (declare (fixnum start end))
  (unless (= start end)
    (tty-write-string string start (the fixnum (- end start)))))


;;; Clearing lines (TTY-DEVICE-CLEAR-TO-EOL, DEVICE-CLEAR-LINES, and
;;; TTY-DEVICE-CLEAR-TO-EOW functions.)

(defun clear-to-eol (hunk x y)
  (update-cursor hunk x y)
  (device-write-string
   (tty-device-clear-to-eol-string (device-hunk-device hunk))))

(defun space-to-eol (hunk x y)
  (declare (fixnum x))
  (update-cursor hunk x y)
  (let* ((device (device-hunk-device hunk))
	 (num (- (the fixnum (tty-device-columns device))
		 x)))
    (declare (fixnum num))
    (dotimes (i num) (tty-write-char #\space))
    (setf (tty-device-cursor-x device) (+ x num))))

(defun clear-lines (hunk x y n)
  (let* ((device (device-hunk-device hunk))
	 (clear-to-eol (tty-device-clear-to-eol device)))
    (funcall clear-to-eol hunk x y)
    (do ((y (1+ y) (1+ y))
	 (count (1- n) (1- count)))
	((zerop count)
	 (setf (tty-device-cursor-x device) 0)
	 (setf (tty-device-cursor-y device) (1- y)))
      (declare (fixnum count y))
      (funcall clear-to-eol hunk 0 y))))

(defun clear-to-eow (hunk x y)
  (declare (fixnum x y))
  (funcall (tty-device-clear-lines (device-hunk-device hunk))
	   hunk x y
	   (the fixnum (- (the fixnum (tty-hunk-text-height hunk)) y))))


;;; Opening and Deleting lines (TTY-DEVICE-OPEN-LINE and TTY-DEVICE-DELETE-LINE)

(defun open-tty-line (hunk x y &optional (n 1))
  (update-cursor hunk x y)
  (dotimes (i n)
    (device-write-string (tty-device-open-line-string (device-hunk-device hunk)))))

(defun delete-tty-line (hunk x y &optional (n 1))
  (update-cursor hunk x y)
  (dotimes (i n)
    (device-write-string (tty-device-delete-line-string (device-hunk-device hunk)))))


;;; Insert and Delete modes (TTY-DEVICE-INSERT-STRING and TTY-DEVICE-DELETE-CHAR)

(defun tty-insert-string (hunk x y string
			   &optional (start 0) (end (strlen string)))
  (declare (fixnum x y start end))
  (update-cursor hunk x y)
  (let* ((device (device-hunk-device hunk))
	 (init-string (tty-device-insert-init-string device))
	 (char-init-string (tty-device-insert-char-init-string device))
	 (cis-len (if char-init-string (length char-init-string)))
	 (char-end-string (tty-device-insert-char-end-string device))
	 (ces-len (if char-end-string (length char-end-string)))
	 (end-string (tty-device-insert-end-string device)))
    (declare (type (or simple-string null) char-init-string char-end-string))
    (when init-string (device-write-string init-string))
    (if char-init-string
	(do ((i start (1+ i)))
	    ((= i end))
	  (device-write-string char-init-string 0 cis-len)
	  (tty-write-char (schar string i))
	  (when char-end-string
	    (device-write-string char-end-string 0 ces-len)))
	(device-write-string string start end))
    (when end-string (device-write-string end-string))
    (setf (tty-device-cursor-x device)
	  (the fixnum (+ x (the fixnum (- end start)))))))

(defun worth-using-insert-mode (device insert-char-num chars-saved)
  (let* ((init-string (tty-device-insert-init-string device))
	 (char-init-string (tty-device-insert-char-init-string device))
	 (char-end-string (tty-device-insert-char-end-string device))
	 (end-string (tty-device-insert-end-string device))
	 (cost 0))
    (when init-string (incf cost (length (the simple-string init-string))))
    (when char-init-string
      (incf cost (* insert-char-num (+ (length (the simple-string
						    char-init-string))
				       (if char-end-string
					   (length (the simple-string
							char-end-string))
					   0)))))
    (when end-string (incf cost (length (the simple-string end-string))))
    (< cost chars-saved)))

(defun delete-char (hunk x y &optional (n 1))
  (declare (fixnum x y n))
  (update-cursor hunk x y)
  (let* ((device (device-hunk-device hunk))
	 (init-string (tty-device-delete-init-string device))
	 (end-string (tty-device-delete-end-string device))
	 (delete-char-string (tty-device-delete-char-string device)))
    (when init-string (device-write-string init-string))
    (dotimes (i n)
      (device-write-string delete-char-string))
    (when end-string (device-write-string end-string))))

(defun worth-using-delete-mode (device delete-char-num clear-char-num)
  (declare (fixnum delete-char-num clear-char-num))
  (let ((init-string (tty-device-delete-init-string device))
	(end-string (tty-device-delete-end-string device))
	(delete-char-string (tty-device-delete-char-string device))
	(clear-to-eol-string (tty-device-clear-to-eol-string device))
	(cost 0))
    (declare (type (or simple-string null) init-string end-string
		   delete-char-string)
	     (fixnum cost))
    (when init-string (incf cost (the fixnum (length init-string))))
    (when end-string (incf cost (the fixnum (length end-string))))
    (incf cost (the fixnum
		    (* (the fixnum (length delete-char-string))
		       delete-char-num)))
    (< cost (+ delete-char-num
	       (if clear-to-eol-string
		   (length clear-to-eol-string)
		   clear-char-num)))))


;;; Standout mode (TTY-DEVICE-STANDOUT-INIT and TTY-DEVICE-STANDOUT-END)

(defun standout-init (hunk)
  (device-write-string
   (tty-device-standout-init-string (device-hunk-device hunk))))

(defun standout-end (hunk)
  (device-write-string
   (tty-device-standout-end-string (device-hunk-device hunk))))