/[cmucl]/src/hemlock/tty-display.lisp
ViewVC logotype

Contents of /src/hemlock/tty-display.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1.1.2 - (show annotations) (vendor branch)
Fri Jul 13 14:56:25 1990 UTC (23 years, 9 months ago) by ram
Changes since 1.1.1.1: +5 -5 lines
*** empty log message ***
1 ;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the Spice Lisp project at
5 ;;; Carnegie-Mellon University, and has been placed in the public domain.
6 ;;; Spice Lisp is currently incomplete and under active development.
7 ;;; If you want to use this code or any part of Spice Lisp, please contact
8 ;;; Scott Fahlman (FAHLMAN@CMUC).
9 ;;; **********************************************************************
10 ;;;
11 ;;; Written by Bill Chiles.
12 ;;;
13
14 (in-package "HEMLOCK-INTERNALS")
15
16 (export '(redisplay redisplay-all))
17
18
19
20 ;;;; Macros.
21
22 (eval-when (compile eval)
23 (defmacro tty-hunk-modeline-pos (hunk)
24 `(tty-hunk-text-height ,hunk))
25 ) ;eval-when
26
27
28 (defvar *currently-selected-hunk* nil)
29 (defvar *hunk-top-line*)
30
31 (proclaim '(fixnum *hunk-top-line*))
32
33 (eval-when (compile eval)
34 (defmacro select-hunk (hunk)
35 `(unless (eq ,hunk *currently-selected-hunk*)
36 (setf *currently-selected-hunk* ,hunk)
37 (setf *hunk-top-line*
38 (the fixnum
39 (1+ (the fixnum
40 (- (the fixnum
41 (tty-hunk-text-position ,hunk))
42 (the fixnum
43 (tty-hunk-text-height ,hunk)))))))))
44 ) ;eval-when
45
46
47 ;;; Screen image lines.
48 ;;;
49 (defstruct (si-line (:print-function print-screen-image-line)
50 (:constructor %make-si-line (chars)))
51 chars
52 (length 0))
53
54 (defun make-si-line (n)
55 (%make-si-line (make-string n)))
56
57 (defun print-screen-image-line (obj str n)
58 (declare (ignore n))
59 (write-string "#<Screen Image Line \"" str)
60 (write-string (si-line-chars obj) str :end (si-line-length obj))
61 (write-string "\">" str))
62
63
64 (defmacro si-line (screen-image n)
65 `(svref ,screen-image ,n))
66
67
68
69 ;;;; Dumb window redisplay.
70
71 (defmacro tty-dumb-line-redisplay (device hunk dis-line &optional y)
72 (let ((dl (gensym)) (dl-chars (gensym)) (dl-len (gensym))
73 (dl-pos (gensym)) (screen-image-line (gensym)))
74 `(let* ((,dl ,dis-line)
75 (,dl-chars (dis-line-chars ,dl))
76 (,dl-len (dis-line-length ,dl))
77 (,dl-pos ,(or y `(dis-line-position ,dl))))
78 (funcall (tty-device-display-string ,device)
79 ,hunk 0 ,dl-pos ,dl-chars 0 ,dl-len)
80 (setf (dis-line-flags ,dl) unaltered-bits)
81 (setf (dis-line-delta ,dl) 0)
82 (select-hunk ,hunk)
83 (let ((,screen-image-line (si-line (tty-device-screen-image ,device)
84 (+ *hunk-top-line* ,dl-pos))))
85 (replace-si-line (si-line-chars ,screen-image-line) ,dl-chars
86 0 0 ,dl-len)
87 (setf (si-line-length ,screen-image-line) ,dl-len)))))
88
89 (defun tty-dumb-window-redisplay (window)
90 (let* ((first (window-first-line window))
91 (hunk (window-hunk window))
92 (device (device-hunk-device hunk))
93 (screen-image (tty-device-screen-image device)))
94 (funcall (tty-device-clear-to-eow device) hunk 0 0)
95 (do ((i 0 (1+ i))
96 (dl (cdr first) (cdr dl)))
97 ((eq dl the-sentinel)
98 (setf (window-old-lines window) (1- i))
99 (select-hunk hunk)
100 (do ((last (tty-hunk-text-position hunk))
101 (i (+ *hunk-top-line* i) (1+ i)))
102 ((> i last))
103 (declare (fixnum i last))
104 (setf (si-line-length (si-line screen-image i)) 0)))
105 (tty-dumb-line-redisplay device hunk (car dl) i))
106 (setf (window-first-changed window) the-sentinel
107 (window-last-changed window) first)
108 (when (window-modeline-buffer window)
109 (let ((dl (window-modeline-dis-line window))
110 (y (tty-hunk-modeline-pos hunk)))
111 (funcall (tty-device-standout-init device) hunk)
112 (funcall (tty-device-clear-to-eol device) hunk 0 y)
113 (tty-dumb-line-redisplay device hunk dl y)
114 (funcall (tty-device-standout-end device) hunk)
115 (setf (dis-line-flags dl) unaltered-bits)))))
116
117
118
119 ;;;; Dumb redisplay top n lines of a window.
120
121 (defun tty-redisplay-n-lines (window n)
122 (let* ((hunk (window-hunk window))
123 (device (device-hunk-device hunk)))
124 (funcall (tty-device-clear-lines device) hunk 0 0 n)
125 (do ((n n (1- n))
126 (dl (cdr (window-first-line window)) (cdr dl)))
127 ((or (zerop n) (eq dl the-sentinel)))
128 (tty-dumb-line-redisplay device hunk (car dl)))))
129
130
131
132 ;;;; Semi dumb window redisplay
133
134 ;;; This is for terminals without opening and deleting lines.
135
136 ;;; TTY-SEMI-DUMB-WINDOW-REDISPLAY is a lot like TTY-SMART-WINDOW-REDISPLAY,
137 ;;; but it calls different line redisplay functions.
138 ;;;
139 (defun tty-semi-dumb-window-redisplay (window)
140 (let* ((hunk (window-hunk window))
141 (device (device-hunk-device hunk)))
142 (let ((first-changed (window-first-changed window))
143 (last-changed (window-last-changed window)))
144 ;; Is there anything to do?
145 (unless (eq first-changed the-sentinel)
146 (if ;; One line-changed.
147 (and (eq first-changed last-changed)
148 (zerop (dis-line-delta (car first-changed))))
149 (tty-semi-dumb-line-redisplay device hunk (car first-changed))
150 ;; More lines changed.
151 (do-semi-dumb-line-writes first-changed last-changed hunk))
152 ;; Set the bounds so we know we displayed...
153 (setf (window-first-changed window) the-sentinel
154 (window-last-changed window) (window-first-line window))))
155 ;;
156 ;; Clear any extra lines at the end of the window.
157 (let ((pos (dis-line-position (car (window-last-line window)))))
158 (when (< pos (window-old-lines window))
159 (tty-smart-clear-to-eow hunk (1+ pos)))
160 (setf (window-old-lines window) pos))
161 ;;
162 ;; Update the modeline if needed.
163 (when (window-modeline-buffer window)
164 (let ((dl (window-modeline-dis-line window)))
165 (when (/= (dis-line-flags dl) unaltered-bits)
166 (funcall (tty-device-standout-init device) hunk)
167 (unwind-protect
168 (tty-smart-line-redisplay device hunk dl
169 (tty-hunk-modeline-pos hunk))
170 (funcall (tty-device-standout-end device) hunk)))))))
171
172 ;;; NEXT-DIS-LINE is used in DO-SEMI-DUMB-LINE-WRITES and
173 ;;; COMPUTE-TTY-CHANGES.
174 ;;;
175 (eval-when (compile eval)
176 (defmacro next-dis-line ()
177 `(progn
178 (setf prev dl)
179 (setf dl (cdr dl))
180 (setf flags (dis-line-flags (car dl)))))
181 ) ;eval-when
182
183 ;;; DO-SEMI-DUMB-LINE-WRITES does what it says until it hits the last
184 ;;; changed line. The commented out code was a gratuitous optimization,
185 ;;; especially if the first-changed line really is the first changes line.
186 ;;; Anyway, this had to be removed because of this function's use in
187 ;;; TTY-SMART-WINDOW-REDISPLAY, which was punting line moves due to
188 ;;; "Scroll Redraw Ratio". However, these supposedly moved lines had their
189 ;;; bits set to unaltered bits in COMPUTE-TTY-CHANGES because it was
190 ;;; assuming TTY-SMART-WINDOW-REDISPLAY guaranteed to do line moves.
191 ;;;
192 (defun do-semi-dumb-line-writes (first-changed last-changed hunk)
193 (let* ((dl first-changed)
194 flags ;(dis-line-flags (car dl))) flags bound for NEXT-DIS-LINE.
195 prev)
196 ;;
197 ;; Skip old, unchanged, unmoved lines.
198 ;; (loop
199 ;; (unless (zerop flags) (return))
200 ;; (next-dis-line))
201 ;;
202 ;; Write every remaining line.
203 (let* ((device (device-hunk-device hunk))
204 (force-output (device-force-output device)))
205 (loop
206 (tty-semi-dumb-line-redisplay device hunk (car dl))
207 (when force-output (funcall force-output))
208 (next-dis-line)
209 (when (eq prev last-changed) (return))))))
210
211 ;;; TTY-SEMI-DUMB-LINE-REDISPLAY finds the first different character
212 ;;; comparing the display line and the screen image line, writes out the
213 ;;; rest of the display line, and clears to end-of-line as necessary.
214 ;;;
215 (defun tty-semi-dumb-line-redisplay (device hunk dl
216 &optional (dl-pos (dis-line-position dl)))
217 (declare (fixnum dl-pos))
218 (let* ((dl-chars (dis-line-chars dl))
219 (dl-len (dis-line-length dl)))
220 (declare (fixnum dl-len) (simple-string dl-chars))
221 (when (listen *editor-input*) (throw 'redisplay-catcher :editor-input))
222 (select-hunk hunk)
223 (let* ((screen-image-line (si-line (tty-device-screen-image device)
224 (+ *hunk-top-line* dl-pos)))
225 (si-line-chars (si-line-chars screen-image-line))
226 (si-line-length (si-line-length screen-image-line))
227 (findex (string/= dl-chars si-line-chars
228 :end1 dl-len :end2 si-line-length)))
229 (declare (type (or fixnum null) findex) (simple-string si-line-chars))
230 ;;
231 ;; When the dis-line and screen chars are not string=.
232 (when findex
233 (cond
234 ;; See if the screen shows an initial substring of the dis-line.
235 ((= findex si-line-length)
236 (funcall (tty-device-display-string device)
237 hunk findex dl-pos dl-chars findex dl-len)
238 (replace-si-line si-line-chars dl-chars findex findex dl-len))
239 ;; When the dis-line is an initial substring of what's on the screen.
240 ((= findex dl-len)
241 (funcall (tty-device-clear-to-eol device) hunk dl-len dl-pos))
242 ;; Otherwise, blast dl-chars and clear to eol as necessary.
243 (t (funcall (tty-device-display-string device)
244 hunk findex dl-pos dl-chars findex dl-len)
245 (when (< dl-len si-line-length)
246 (funcall (tty-device-clear-to-eol device) hunk dl-len dl-pos))
247 (replace-si-line si-line-chars dl-chars findex findex dl-len)))
248 (setf (si-line-length screen-image-line) dl-len)))
249 (setf (dis-line-flags dl) unaltered-bits)
250 (setf (dis-line-delta dl) 0)))
251
252
253
254 ;;;; Smart window redisplay -- operation queues and internal screen image.
255
256 ;;; This is used for creating temporary smart redisplay structures.
257 ;;;
258 (defconstant tty-hunk-height-limit 100)
259
260
261 ;;; Queues for redisplay operations and access macros.
262 ;;;
263 (defvar *tty-line-insertions* (make-array (* 2 tty-hunk-height-limit)))
264
265 (defvar *tty-line-deletions* (make-array (* 2 tty-hunk-height-limit)))
266
267 (defvar *tty-line-writes* (make-array tty-hunk-height-limit))
268
269 (eval-when (compile eval)
270
271 (defmacro queue (value queue ptr)
272 `(progn
273 (setf (svref ,queue ,ptr) ,value)
274 (the fixnum (incf (the fixnum ,ptr)))))
275
276 (defmacro dequeue (queue ptr)
277 `(prog1
278 (svref ,queue ,ptr)
279 (the fixnum (incf (the fixnum ,ptr)))))
280
281 ) ;eval-when
282
283 ;;; INSERT-LINE-COUNT is used in TTY-SMART-WINDOW-REDISPLAY. The counting is
284 ;;; based on calls to QUEUE in COMPUTE-TTY-CHANGES.
285 ;;;
286 (defun insert-line-count (ins)
287 (do ((i 1 (+ i 2))
288 (count 0 (+ count (svref *tty-line-insertions* i))))
289 ((> i ins) count)))
290
291
292 ;;; Temporary storage for screen-image lines and accessing macros.
293 ;;;
294 (defvar *screen-image-temp* (make-array tty-hunk-height-limit))
295
296 (eval-when (compile eval)
297
298 ;;; DELETE-SI-LINES is used in DO-LINE-DELETIONS to simulate what's
299 ;;; happening to the screen in a device's screen-image. At y, num
300 ;;; lines are deleted and saved in *screen-image-temp*; fsil is the
301 ;;; end of the free screen image lines saved here. Also, we must
302 ;;; move lines up in the screen-image structure. In the outer loop
303 ;;; we save lines in the temp storage and move lines up at the same
304 ;;; time. In the termination/inner loop we move any lines that still
305 ;;; need to be moved up. The screen-length is adjusted by the fsil
306 ;;; because any time a deletion is in progress, there are fsil bogus
307 ;;; lines at the bottom of the screen image from lines being moved
308 ;;; up previously.
309 ;;;
310 (defmacro delete-si-lines (screen-image y num fsil screen-length)
311 (let ((do-screen-image (gensym)) (delete-index (gensym))
312 (free-lines (gensym)) (source-index (gensym)) (target-index (gensym))
313 (n (gensym)) (do-screen-length (gensym)) (do-y (gensym)))
314 `(let ((,do-screen-image ,screen-image)
315 (,do-screen-length (- ,screen-length fsil))
316 (,do-y ,y))
317 (declare (fixnum ,do-screen-length ,do-y))
318 (do ((,delete-index ,do-y (1+ ,delete-index))
319 (,free-lines ,fsil (1+ ,free-lines))
320 (,source-index (+ ,do-y ,num) (1+ ,source-index))
321 (,n ,num (1- ,n)))
322 ((zerop ,n)
323 (do ((,target-index ,delete-index (1+ ,target-index))
324 (,source-index ,source-index (1+ ,source-index)))
325 ((>= ,source-index ,do-screen-length))
326 (declare (fixnum ,target-index ,source-index))
327 (setf (si-line ,do-screen-image ,target-index)
328 (si-line ,do-screen-image ,source-index))))
329 (declare (fixnum ,delete-index ,free-lines ,source-index ,n))
330 (setf (si-line *screen-image-temp* ,free-lines)
331 (si-line ,do-screen-image ,delete-index))
332 (when (< ,source-index ,do-screen-length)
333 (setf (si-line ,do-screen-image ,delete-index)
334 (si-line ,do-screen-image ,source-index)))))))
335
336
337 ;;; INSERT-SI-LINES is used in DO-LINE-INSERTIONS to simulate what's
338 ;;; happening to the screen in a device's screen-image. At y, num free
339 ;;; lines are inserted from *screen-image-temp*; fsil is the end of the
340 ;;; free lines. When copying lines down in screen-image, we must start
341 ;;; with the lower lines and end with the higher ones, so we don't trash
342 ;;; any lines. The outer loop does all the copying, and the termination/
343 ;;; inner loop inserts the free screen image lines, setting their length
344 ;;; to zero.
345 ;;;
346 (defmacro insert-si-lines (screen-image y num fsil screen-length)
347 (let ((do-screen-image (gensym)) (source-index (gensym))
348 (target-index (gensym)) (target-terminus (gensym))
349 (do-screen-length (gensym)) (temp (gensym)) (do-y (gensym))
350 (insert-index (gensym)) (free-lines-index (gensym))
351 (n (gensym)))
352 `(let ((,do-screen-length ,screen-length)
353 (,do-screen-image ,screen-image)
354 (,do-y ,y))
355 (do ((,target-terminus (1- (+ ,do-y ,num))) ; (1- target-start)
356 (,source-index (- ,do-screen-length ,fsil 1) ; (1- source-end)
357 (1- ,source-index))
358 (,target-index (- (+ ,do-screen-length ,num)
359 ,fsil 1) ; (1- target-end)
360 (1- ,target-index)))
361 ((= ,target-index ,target-terminus)
362 (do ((,insert-index ,do-y (1+ ,insert-index))
363 (,free-lines-index (1- ,fsil) (1- ,free-lines-index))
364 (,n ,num (1- ,n)))
365 ((zerop ,n))
366 (declare (fixnum ,insert-index ,free-lines-index ,n))
367 (let ((,temp (si-line *screen-image-temp* ,free-lines-index)))
368 (setf (si-line-length ,temp) 0)
369 (setf (si-line ,do-screen-image ,insert-index) ,temp)))
370 (decf ,fsil ,num))
371 (declare (fixnum ,target-terminus ,source-index ,target-index))
372 (setf (si-line ,do-screen-image ,target-index)
373 (si-line ,do-screen-image ,source-index))))))
374
375 ) ;eval-when
376
377
378
379 ;;;; Smart window redisplay -- the function.
380
381 ;;; TTY-SMART-WINDOW-REDISPLAY sees if only one line changed after
382 ;;; some preliminary processing. If more than one line changed,
383 ;;; then we compute changes to make to the screen in the form of
384 ;;; line insertions, deletions, and writes. Deletions must be done
385 ;;; first, so lines are not lost off the bottom of the screen by
386 ;;; inserting lines.
387 ;;;
388 (defun tty-smart-window-redisplay (window)
389 (let* ((hunk (window-hunk window))
390 (device (device-hunk-device hunk)))
391 (let ((first-changed (window-first-changed window))
392 (last-changed (window-last-changed window)))
393 ;; Is there anything to do?
394 (unless (eq first-changed the-sentinel)
395 (if (and (eq first-changed last-changed)
396 (zerop (dis-line-delta (car first-changed))))
397 ;; One line-changed.
398 (tty-smart-line-redisplay device hunk (car first-changed))
399 ;; More lines changed.
400 (multiple-value-bind (ins outs writes)
401 (compute-tty-changes
402 first-changed last-changed
403 (tty-hunk-modeline-pos hunk))
404 (let ((ratio (variable-value 'ed::scroll-redraw-ratio)))
405 (cond ((and ratio
406 (> (/ (insert-line-count ins)
407 (tty-hunk-text-height hunk))
408 ratio))
409 (do-semi-dumb-line-writes first-changed last-changed
410 hunk))
411 (t
412 (do-line-insertions hunk ins
413 (do-line-deletions hunk outs))
414 (do-line-writes hunk writes))))))
415 ;; Set the bounds so we know we displayed...
416 (setf (window-first-changed window) the-sentinel
417 (window-last-changed window) (window-first-line window))))
418 ;;
419 ;; Clear any extra lines at the end of the window.
420 (let ((pos (dis-line-position (car (window-last-line window)))))
421 (when (< pos (window-old-lines window))
422 (tty-smart-clear-to-eow hunk (1+ pos)))
423 (setf (window-old-lines window) pos))
424 ;;
425 ;; Update the modeline if needed.
426 (when (window-modeline-buffer window)
427 (let ((dl (window-modeline-dis-line window)))
428 (when (/= (dis-line-flags dl) unaltered-bits)
429 (funcall (tty-device-standout-init device) hunk)
430 (unwind-protect
431 (tty-smart-line-redisplay device hunk dl
432 (tty-hunk-modeline-pos hunk))
433 (funcall (tty-device-standout-end device) hunk)))))))
434
435
436
437 ;;;; Smart window redisplay -- computing changes to the display.
438
439 ;;; There is a lot of documentation here to help since this code is not
440 ;;; obviously correct. The code is not that cryptic, but the correctness
441 ;;; of the algorithm is somewhat. Most of the complexity is in handling
442 ;;; lines that moved on the screen which the introduction deals with.
443 ;;; Also, the block of documentation immediately before the function
444 ;;; COMPUTE-TTY-CHANGES has its largest portion dedicated to this part of
445 ;;; the function which is the largest block of code in the function.
446
447 ;;; The window image dis-lines are annotated with the difference between
448 ;;; their current intended locations and their previous locations in the
449 ;;; window. This delta (distance moved) is negative for an upward move and
450 ;;; positive for a downward move. To determine what to do with moved
451 ;;; groups of lines, we consider the transition (or difference in deltas)
452 ;;; between two adjacent groups as we look at the window's dis-lines moving
453 ;;; down the window image, disregarding whether they are contiguous (having
454 ;;; moved only by a different delta) or separated by some lines (such as
455 ;;; lines that are new and unmoved).
456 ;;;
457 ;;; Considering the transition between moved groups makes sense because a
458 ;;; given group's delta affects all the lines below it since the dis-lines
459 ;;; reflect the window's buffer's actual lines which are all connected in
460 ;;; series. Therefore, if the previous group moved up some delta number of
461 ;;; lines because of line deletions, then the lines below this group (down
462 ;;; to the last line of the window image) moved up by the same delta too,
463 ;;; unless one of the following is true:
464 ;;; 1] The lines below the group moved up by a greater delta, possibly
465 ;;; due to multiple disjoint buffer line deletions.
466 ;;; 2] The lines below the group moved up by a lesser delta, possibly
467 ;;; due to a number (less than the previous delta) of new line
468 ;;; insertions below the group that moved up.
469 ;;; 3] The lines below the group moved down, possibly due to a number
470 ;;; (greater than the previous delta) of new line insertions below
471 ;;; the group that moved up.
472 ;;; Similarly, if the previous group moved down some delta number of lines
473 ;;; because of new line insertions, then the lines below this group (down
474 ;;; to the last line of the window image not to fall off the window's lower
475 ;;; edge) moved down by the same delta too, unless one of the following is
476 ;;; true:
477 ;;; 1] The lines below the group moved down by a greater delta, possibly
478 ;;; due to multiple disjoint buffer line insertions.
479 ;;; 2] The lines below the group moved down by a lesser delta, possibly
480 ;;; due to a number (less than the previous delta) of line deletions
481 ;;; below the group that moved down.
482 ;;; 3] The lines below the group moved up, possibly due to a number
483 ;;; (greater than the previous delta) of line deletions below the
484 ;;; group that moved down.
485 ;;;
486 ;;; Now we can see how the first moved group affects the window image below
487 ;;; it except where there is a lower group of lines that have moved a
488 ;;; different delta due to separate operations on the buffer's lines viewed
489 ;;; through a window. We can see that this different delta is the expected
490 ;;; effect throughout the window image below the second group, unless
491 ;;; something lower down again has affected the window image. Also, in the
492 ;;; case of a last group of lines that moved up, the group will never
493 ;;; reflect all of the lines in the window image from the first line to
494 ;;; move down to the bottom of the window image because somewhere down below
495 ;;; the group that moved up are some new lines that have just been drawn up
496 ;;; into the window's image.
497 ;;;
498
499 ;;; COMPUTE-TTY-CHANGES is used once in TTY-SMART-WINDOW-REDISPLAY.
500 ;;; It goes through all the display lines for a window recording where
501 ;;; lines need to be inserted, deleted, or written to make the screen
502 ;;; consistent with the internal image of the screen. Pointers to
503 ;;; the insertions, deletions, and writes that have to be done are
504 ;;; returned.
505 ;;;
506 ;;; If a line is new, then simply queue it to be written.
507 ;;;
508 ;;; If a line is moved and/or changed, then we compute the difference
509 ;;; between the last block of lines that moved with the same delta and the
510 ;;; current block of lines that moved with the current delta. If this
511 ;;; difference is positive, then some lines need to be deleted. Since we
512 ;;; do all the line deletions first to prevent line insertions from
513 ;;; dropping lines off the bottom of the screen, we have to compute the
514 ;;; position of line deletions using the cumulative insertions
515 ;;; (cum-inserts). Without any insertions, deletions may be done right at
516 ;;; the dis-line's new position. With insertions needed above a given
517 ;;; deletion point combined with the fact that deletions are all done
518 ;;; first, the location for the deletion is higher than it would be without
519 ;;; the insertions being done above the deletions. The location of the
520 ;;; deletion is higher by the number of insertions we have currently put
521 ;;; off. When computing the position of line insertions (a negative delta
522 ;;; transition), we do not need to consider the cumulative insertions or
523 ;;; cumulative deletions since everything above the point of insertion
524 ;;; (both deletions and insertions) has been done. Because of the screen
525 ;;; state being correct above the point of an insertion, the screen is only
526 ;;; off by the delta transition number of lines. After determining the
527 ;;; line insertions or deletions, loop over contiguous lines with the same
528 ;;; delta queuing any changed ones to be written. The delta and flag
529 ;;; fields are initialized according to the need to be written; since
530 ;;; redisplay may be interrupted by more user input after moves have been
531 ;;; done to the screen, we save the changed bit on, so the line will be
532 ;;; queued to be written after redisplay is re-entered.
533 ;;;
534 ;;; If the line is changed or new, then queue it to be written. Note
535 ;;; before that we checked the flags for equality with the new bits, and
536 ;;; it is possible that updating the window image will yield lines that
537 ;;; are both new and changed.
538 ;;;
539 ;;; Otherwise, get the next display line, loop, and see if it's
540 ;;; interesting.
541 ;;;
542 (defun compute-tty-changes (first-changed last-changed modeline-pos)
543 (declare (fixnum modeline-pos))
544 (let* ((dl first-changed)
545 (flags (dis-line-flags (car dl)))
546 (ins 0) (outs 0) (writes 0)
547 (prev-delta 0) (cum-deletes 0) (net-delta 0) (cum-inserts 0)
548 prev)
549 (declare (fixnum flags ins outs writes prev-delta cum-deletes net-delta
550 cum-inserts))
551 (loop
552 (cond
553 ((= flags new-bit)
554 (queue (car dl) *tty-line-writes* writes)
555 (next-dis-line))
556 ((not (zerop (the fixnum (logand flags moved-bit))))
557 (let* ((start-dl (car dl))
558 (start-pos (dis-line-position start-dl))
559 (curr-delta (dis-line-delta start-dl))
560 (delta-delta (- prev-delta curr-delta))
561 (car-dl start-dl))
562 (declare (fixnum start-pos curr-delta delta-delta))
563 (cond ((plusp delta-delta)
564 (queue (the fixnum (- start-pos cum-inserts))
565 *tty-line-deletions* outs)
566 (queue delta-delta *tty-line-deletions* outs)
567 (incf cum-deletes delta-delta)
568 (decf net-delta delta-delta))
569 ((minusp delta-delta)
570 (let ((eff-pos (the fixnum (+ start-pos delta-delta)))
571 (num (the fixnum (- delta-delta))))
572 (queue eff-pos *tty-line-insertions* ins)
573 (queue num *tty-line-insertions* ins)
574 (incf net-delta num)
575 (incf cum-inserts num)))
576 (t (error "Internal error -- unexpected zero transition delta ~
577 in redisplay.")))
578 (loop
579 (cond ((and (zerop (the fixnum (logand flags changed-bit)))
580 (zerop (the fixnum (logand flags new-bit))))
581 (setf (dis-line-flags car-dl) unaltered-bits))
582 (t (queue car-dl *tty-line-writes* writes)
583 ;; keep just the changed-bit on.
584 (setf (dis-line-flags car-dl) changed-bit)))
585 (setf (dis-line-delta car-dl) 0)
586 (next-dis-line)
587 (setf car-dl (car dl))
588 (when (/= (the fixnum (dis-line-delta car-dl)) curr-delta)
589 (setf prev-delta curr-delta)
590 (return)))))
591 ((not (and (zerop (logand (the fixnum flags) changed-bit))
592 (zerop (logand (the fixnum flags) new-bit))))
593 (queue (car dl) *tty-line-writes* writes)
594 (next-dis-line))
595 (t (next-dis-line)))
596 (when (eq prev last-changed)
597 (unless (zerop net-delta)
598 (cond ((plusp net-delta)
599 (queue (the fixnum (- modeline-pos cum-deletes net-delta))
600 *tty-line-deletions* outs)
601 (queue net-delta *tty-line-deletions* outs))
602 (t (queue (the fixnum (+ modeline-pos net-delta))
603 *tty-line-insertions* ins)
604 (queue (the fixnum (- net-delta))
605 *tty-line-insertions* ins))))
606 (return (values ins outs writes))))))
607
608
609
610 ;;;; Smart window redisplay -- operation methods.
611
612 ;;; TTY-SMART-CLEAR-TO-EOW clears lines y through the last text line of hunk.
613 ;;; It takes care not to clear a line unless it really has some characters
614 ;;; displayed on it. It also maintains the device's screen image lines.
615 ;;;
616 (defun tty-smart-clear-to-eow (hunk y)
617 (let* ((device (device-hunk-device hunk))
618 (screen-image (tty-device-screen-image device))
619 (clear-to-eol (tty-device-clear-to-eol device)))
620 (select-hunk hunk)
621 (do ((y y (1+ y))
622 (si-idx (+ *hunk-top-line* y) (1+ si-idx))
623 (last (tty-hunk-text-position hunk)))
624 ((> si-idx last))
625 (declare (fixnum y si-idx last))
626 (let ((si-line (si-line screen-image si-idx)))
627 (unless (zerop (si-line-length si-line))
628 (funcall clear-to-eol hunk 0 y)
629 (setf (si-line-length si-line) 0))))))
630
631 ;;; DO-LINE-DELETIONS pops elements off the *tty-lines-deletions* queue,
632 ;;; deleting lines from hunk's area of the screen. The internal screen
633 ;;; image is updated, and the total number of lines deleted is returned.
634 ;;;
635 (defun do-line-deletions (hunk outs)
636 (declare (fixnum outs))
637 (let* ((i 0)
638 (device (device-hunk-device hunk))
639 (fun (tty-device-delete-line device))
640 (fsil 0)) ;free-screen-image-lines
641 (declare (fixnum i fsil))
642 (loop
643 (when (= i outs) (return fsil))
644 (let ((y (dequeue *tty-line-deletions* i))
645 (num (dequeue *tty-line-deletions* i)))
646 (declare (fixnum y num))
647 (funcall fun hunk 0 y num)
648 (select-hunk hunk)
649 (delete-si-lines (tty-device-screen-image device)
650 (+ *hunk-top-line* y) num fsil
651 (tty-device-lines device))
652 (incf fsil num)))))
653
654 ;;; DO-LINE-INSERTIONS pops elements off the *tty-line-insertions* queue,
655 ;;; inserting lines into hunk's area of the screen. The internal screen
656 ;;; image is updated using free screen image lines pointed to by fsil.
657 ;;;
658 (defun do-line-insertions (hunk ins fsil)
659 (declare (fixnum ins fsil))
660 (let* ((i 0)
661 (device (device-hunk-device hunk))
662 (fun (tty-device-open-line device)))
663 (declare (fixnum i))
664 (loop
665 (when (= i ins) (return))
666 (let ((y (dequeue *tty-line-insertions* i))
667 (num (dequeue *tty-line-insertions* i)))
668 (declare (fixnum y num))
669 (funcall fun hunk 0 y num)
670 (select-hunk hunk)
671 (insert-si-lines (tty-device-screen-image device)
672 (+ *hunk-top-line* y) num fsil
673 (tty-device-lines device))))))
674
675 ;;; DO-LINE-WRITES pops elements off the *tty-line-writes* queue, displaying
676 ;;; these dis-lines with TTY-SMART-LINE-REDISPLAY. We force output after
677 ;;; each line, so the user can see how far we've gotten in case he chooses
678 ;;; to give more editor commands which will abort redisplay until there's no
679 ;;; more input.
680 ;;;
681 (defun do-line-writes (hunk writes)
682 (declare (fixnum writes))
683 (let* ((i 0)
684 (device (device-hunk-device hunk))
685 (force-output (device-force-output device)))
686 (declare (fixnum i))
687 (loop
688 (when (= i writes) (return))
689 (tty-smart-line-redisplay device hunk (dequeue *tty-line-writes* i))
690 (when force-output (funcall force-output)))))
691
692 ;;; TTY-SMART-LINE-REDISPLAY uses an auxiliary screen image structure to
693 ;;; try to do minimal character shipping to the terminal. Roughly, we find
694 ;;; the first different character when comparing what's on the screen and
695 ;;; what should be there; we will start altering the line after this same
696 ;;; initial substring. Then we find, from the end, the first character
697 ;;; that is different, blasting out characters to the lesser of the two
698 ;;; indexes. If the dis-line index is lesser, we have some characters to
699 ;;; delete from the screen, and if the screen index is lesser, we have some
700 ;;; additional dis-line characters to insert. There are a few special
701 ;;; cases that allow us to punt out of the above algorithm sketch. If the
702 ;;; terminal doesn't have insert mode or delete mode, we have blast out to
703 ;;; the end of the dis-line and possibly clear to the end of the screen's
704 ;;; line, as appropriate. Sometimes we don't use insert or delete mode
705 ;;; because of the overhead cost in characters; it simply is cheaper to
706 ;;; blast out characters and clear to eol.
707 ;;;
708 (defun tty-smart-line-redisplay (device hunk dl
709 &optional (dl-pos (dis-line-position dl)))
710 (declare (fixnum dl-pos))
711 (let* ((dl-chars (dis-line-chars dl))
712 (dl-len (dis-line-length dl)))
713 (declare (fixnum dl-len) (simple-string dl-chars))
714 (when (listen *editor-input*) (throw 'redisplay-catcher :editor-input))
715 (select-hunk hunk)
716 (let* ((screen-image-line (si-line (tty-device-screen-image device)
717 (+ *hunk-top-line* dl-pos)))
718 (si-line-chars (si-line-chars screen-image-line))
719 (si-line-length (si-line-length screen-image-line))
720 (findex (string/= dl-chars si-line-chars
721 :end1 dl-len :end2 si-line-length)))
722 (declare (type (or fixnum null) findex) (simple-string si-line-chars))
723 ;;
724 ;; When the dis-line and screen chars are not string=.
725 (when findex
726 (block tslr-main-body
727 ;;
728 ;; See if the screen shows an initial substring of the dis-line.
729 (when (= findex si-line-length)
730 (funcall (tty-device-display-string device)
731 hunk findex dl-pos dl-chars findex dl-len)
732 (replace-si-line si-line-chars dl-chars findex findex dl-len)
733 (return-from tslr-main-body t))
734 ;;
735 ;; When the dis-line is an initial substring of what's on the screen.
736 (when (= findex dl-len)
737 (funcall (tty-device-clear-to-eol device) hunk dl-len dl-pos)
738 (return-from tslr-main-body t))
739 ;;
740 ;; Find trailing substrings that are the same.
741 (multiple-value-bind (sindex dindex)
742 (do ((sindex (1- si-line-length) (1- sindex))
743 (dindex (1- dl-len) (1- dindex)))
744 ((or (= sindex -1)
745 (= dindex -1)
746 (char/= (schar dl-chars dindex)
747 (schar si-line-chars sindex)))
748 (values (1+ sindex) (1+ dindex))))
749 (declare (fixnum sindex dindex))
750 ;;
751 ;; No trailing substrings -- blast and clear to eol.
752 (when (= dindex dl-len)
753 (funcall (tty-device-display-string device)
754 hunk findex dl-pos dl-chars findex dl-len)
755 (when (< dindex sindex)
756 (funcall (tty-device-clear-to-eol device)
757 hunk dl-len dl-pos))
758 (replace-si-line si-line-chars dl-chars findex findex dl-len)
759 (return-from tslr-main-body t))
760 (let ((lindex (min sindex dindex)))
761 (cond ((< lindex findex)
762 ;; This can happen in funny situations -- believe me!
763 (setf lindex findex))
764 (t
765 (funcall (tty-device-display-string device)
766 hunk findex dl-pos dl-chars findex lindex)
767 (replace-si-line si-line-chars dl-chars
768 findex findex lindex)))
769 (cond
770 ((= dindex sindex))
771 ((< dindex sindex)
772 (let ((delete-char-num (- sindex dindex)))
773 (cond ((and (tty-device-delete-char device)
774 (worth-using-delete-mode
775 device delete-char-num (- si-line-length dl-len)))
776 (funcall (tty-device-delete-char device)
777 hunk dindex dl-pos delete-char-num))
778 (t
779 (funcall (tty-device-display-string device)
780 hunk dindex dl-pos dl-chars dindex dl-len)
781 (funcall (tty-device-clear-to-eol device)
782 hunk dl-len dl-pos)))))
783 (t
784 (if (and (tty-device-insert-string device)
785 (worth-using-insert-mode device (- dindex sindex)))
786 (funcall (tty-device-insert-string device)
787 hunk sindex dl-pos dl-chars sindex dindex)
788 (funcall (tty-device-display-string device)
789 hunk sindex dl-pos dl-chars sindex dl-len))))
790 (replace-si-line si-line-chars dl-chars
791 lindex lindex dl-len))))
792 (setf (si-line-length screen-image-line) dl-len)))
793 (setf (dis-line-flags dl) unaltered-bits)
794 (setf (dis-line-delta dl) 0)))
795
796
797
798 ;;;; Device methods
799
800 ;;; Initializing and exiting the device (DEVICE-INIT and DEVICE-EXIT functions).
801 ;;; These can be found in Tty-Display-Rt.Lisp.
802
803
804 ;;; Clearing the device (DEVICE-CLEAR functions).
805
806 (defun clear-device (device)
807 (device-write-string (tty-device-clear-string device))
808 (cursor-motion device 0 0)
809 (setf (tty-device-cursor-x device) 0)
810 (setf (tty-device-cursor-y device) 0))
811
812
813 ;;; Moving the cursor around (DEVICE-PUT-CURSOR)
814
815 ;;; TTY-PUT-CURSOR makes sure the coordinates are mapped from the hunk's
816 ;;; axis to the screen's and determines the minimal cost cursor motion
817 ;;; sequence. Currently, it does no cost analysis of relative motion
818 ;;; compared to absolute motion but simply makes sure the cursor isn't
819 ;;; already where we want it.
820 ;;;
821 (defun tty-put-cursor (hunk x y)
822 (declare (fixnum x y))
823 (select-hunk hunk)
824 (let ((y (the fixnum (+ *hunk-top-line* y)))
825 (device (device-hunk-device hunk)))
826 (declare (fixnum y))
827 (unless (and (= (the fixnum (tty-device-cursor-x device)) x)
828 (= (the fixnum (tty-device-cursor-y device)) y))
829 (cursor-motion device x y)
830 (setf (tty-device-cursor-x device) x)
831 (setf (tty-device-cursor-y device) y))))
832
833 ;;; UPDATE-CURSOR is used in device redisplay methods to make sure the
834 ;;; cursor is where it should be.
835 ;;;
836 (eval-when (compile eval)
837 (defmacro update-cursor (hunk x y)
838 `(funcall (device-put-cursor (device-hunk-device ,hunk)) ,hunk ,x ,y))
839 ) ;eval-when
840
841 ;;; CURSOR-MOTION takes two coordinates on the screen's axis,
842 ;;; moving the cursor to that location. X is the column index,
843 ;;; and y is the line index, but Unix and Termcap believe that
844 ;;; the default order of indexes is first the line and then the
845 ;;; column or (y,x). Because of this, when reversep is non-nil,
846 ;;; we send first x and then y.
847 ;;;
848 (defun cursor-motion (device x y)
849 (let ((x-add-char (tty-device-cm-x-add-char device))
850 (y-add-char (tty-device-cm-y-add-char device))
851 (x-condx-add (tty-device-cm-x-condx-char device))
852 (y-condx-add (tty-device-cm-y-condx-char device))
853 (one-origin (tty-device-cm-one-origin device)))
854 (when x-add-char (incf x x-add-char))
855 (when (and x-condx-add (> x x-condx-add))
856 (incf x (tty-device-cm-x-condx-add-char device)))
857 (when y-add-char (incf y y-add-char))
858 (when (and y-condx-add (> y y-condx-add))
859 (incf y (tty-device-cm-y-condx-add-char device)))
860 (when one-origin (incf x) (incf y)))
861 (device-write-string (tty-device-cm-string1 device))
862 (let ((reversep (tty-device-cm-reversep device))
863 (x-pad (tty-device-cm-x-pad device))
864 (y-pad (tty-device-cm-y-pad device)))
865 (if reversep
866 (cm-output-coordinate x x-pad)
867 (cm-output-coordinate y y-pad))
868 (device-write-string (tty-device-cm-string2 device))
869 (if reversep
870 (cm-output-coordinate y y-pad)
871 (cm-output-coordinate x x-pad))
872 (device-write-string (tty-device-cm-string3 device))))
873
874 ;;; CM-OUTPUT-COORDINATE outputs the coordinate with respect to the pad. If
875 ;;; there is a pad, then the coordinate needs to be sent as digit-char's (for
876 ;;; each digit in the coordinate), and if there is no pad, the coordinate needs
877 ;;; to be converted into a character. Using CODE-CHAR here is not really
878 ;;; portable. With a pad, the coordinate buffer is filled from the end as we
879 ;;; truncate the coordinate by 10, generating ones digits.
880 ;;;
881 (defconstant cm-coordinate-buffer-len 5)
882 (defvar *cm-coordinate-buffer* (make-string cm-coordinate-buffer-len))
883 ;;;
884 (defun cm-output-coordinate (coordinate pad)
885 (cond (pad
886 (let ((i (1- cm-coordinate-buffer-len)))
887 (loop
888 (when (= i -1) (error "Terminal has too many lines!"))
889 (multiple-value-bind (tens ones)
890 (truncate coordinate 10)
891 (setf (schar *cm-coordinate-buffer* i) (digit-char ones))
892 (when (zerop tens)
893 (dotimes (n (- pad (- cm-coordinate-buffer-len i)))
894 (decf i)
895 (setf (schar *cm-coordinate-buffer* i) #\0))
896 (device-write-string *cm-coordinate-buffer* i
897 cm-coordinate-buffer-len)
898 (return))
899 (decf i)
900 (setf coordinate tens)))))
901 (t (tty-write-char (code-char coordinate)))))
902
903
904 ;;; Writing strings (TTY-DEVICE-DISPLAY-STRING functions)
905
906 ;;; DISPLAY-STRING is used to put a string at (x,y) on the device.
907 ;;;
908 (defun display-string (hunk x y string
909 &optional (start 0) (end (strlen string)))
910 (declare (fixnum x y start end))
911 (update-cursor hunk x y)
912 (device-write-string string start end)
913 (setf (tty-device-cursor-x (device-hunk-device hunk))
914 (the fixnum (+ x (the fixnum (- end start))))))
915
916 ;;; DISPLAY-STRING-CHECKING-UNDERLINES is used for terminals that special
917 ;;; case underlines doing an overstrike when they don't otherwise overstrike.
918 ;;; Note: we do not know in this code whether the terminal can backspace (or
919 ;;; what the sequence is), whether the terminal has insert-mode, or whether
920 ;;; the terminal has delete-mode.
921 ;;;
922 (defun display-string-checking-underlines (hunk x y string
923 &optional (start 0)
924 (end (strlen string)))
925 (declare (fixnum x y start end) (simple-string string))
926 (update-cursor hunk x y)
927 (let ((upos (position #\_ string :test #'char= :start start :end end))
928 (device (device-hunk-device hunk)))
929 (if upos
930 (let ((previous start)
931 (after-pos 0))
932 (declare (fixnum previous after-pos))
933 (loop (device-write-string string previous upos)
934 (setf after-pos (do ((i (1+ upos) (1+ i)))
935 ((or (= i end)
936 (char/= (schar string i) #\_)) i)
937 (declare (fixnum i))))
938 (let ((ulen (the fixnum (- after-pos upos)))
939 (cursor-x (the fixnum (+ x (the fixnum
940 (- after-pos start))))))
941 (declare (fixnum ulen))
942 (dotimes (i ulen) (tty-write-char #\space))
943 (setf (tty-device-cursor-x device) cursor-x)
944 (update-cursor hunk upos y)
945 (dotimes (i ulen) (tty-write-char #\_))
946 (setf (tty-device-cursor-x device) cursor-x))
947 (setf previous after-pos)
948 (setf upos (position #\_ string :test #'char=
949 :start previous :end end))
950 (unless upos
951 (device-write-string string previous end)
952 (return))))
953 (device-write-string string start end))
954 (setf (tty-device-cursor-x device)
955 (the fixnum (+ x (the fixnum (- end start)))))))
956
957
958 ;;; DEVICE-WRITE-STRING is used to shove a string at the terminal regardless
959 ;;; of cursor position.
960 ;;;
961 (defun device-write-string (string &optional (start 0) (end (strlen string)))
962 (declare (fixnum start end))
963 (unless (= start end)
964 (tty-write-string string start (the fixnum (- end start)))))
965
966
967 ;;; Clearing lines (TTY-DEVICE-CLEAR-TO-EOL, DEVICE-CLEAR-LINES, and
968 ;;; TTY-DEVICE-CLEAR-TO-EOW functions.)
969
970 (defun clear-to-eol (hunk x y)
971 (update-cursor hunk x y)
972 (device-write-string
973 (tty-device-clear-to-eol-string (device-hunk-device hunk))))
974
975 (defun space-to-eol (hunk x y)
976 (declare (fixnum x))
977 (update-cursor hunk x y)
978 (let* ((device (device-hunk-device hunk))
979 (num (- (the fixnum (tty-device-columns device))
980 x)))
981 (declare (fixnum num))
982 (dotimes (i num) (tty-write-char #\space))
983 (setf (tty-device-cursor-x device) (+ x num))))
984
985 (defun clear-lines (hunk x y n)
986 (let* ((device (device-hunk-device hunk))
987 (clear-to-eol (tty-device-clear-to-eol device)))
988 (funcall clear-to-eol hunk x y)
989 (do ((y (1+ y) (1+ y))
990 (count (1- n) (1- count)))
991 ((zerop count)
992 (setf (tty-device-cursor-x device) 0)
993 (setf (tty-device-cursor-y device) (1- y)))
994 (declare (fixnum count y))
995 (funcall clear-to-eol hunk 0 y))))
996
997 (defun clear-to-eow (hunk x y)
998 (declare (fixnum x y))
999 (funcall (tty-device-clear-lines (device-hunk-device hunk))
1000 hunk x y
1001 (the fixnum (- (the fixnum (tty-hunk-text-height hunk)) y))))
1002
1003
1004 ;;; Opening and Deleting lines (TTY-DEVICE-OPEN-LINE and TTY-DEVICE-DELETE-LINE)
1005
1006 (defun open-tty-line (hunk x y &optional (n 1))
1007 (update-cursor hunk x y)
1008 (dotimes (i n)
1009 (device-write-string (tty-device-open-line-string (device-hunk-device hunk)))))
1010
1011 (defun delete-tty-line (hunk x y &optional (n 1))
1012 (update-cursor hunk x y)
1013 (dotimes (i n)
1014 (device-write-string (tty-device-delete-line-string (device-hunk-device hunk)))))
1015
1016
1017 ;;; Insert and Delete modes (TTY-DEVICE-INSERT-STRING and TTY-DEVICE-DELETE-CHAR)
1018
1019 (defun tty-insert-string (hunk x y string
1020 &optional (start 0) (end (strlen string)))
1021 (declare (fixnum x y start end))
1022 (update-cursor hunk x y)
1023 (let* ((device (device-hunk-device hunk))
1024 (init-string (tty-device-insert-init-string device))
1025 (char-init-string (tty-device-insert-char-init-string device))
1026 (cis-len (if char-init-string (length char-init-string)))
1027 (char-end-string (tty-device-insert-char-end-string device))
1028 (ces-len (if char-end-string (length char-end-string)))
1029 (end-string (tty-device-insert-end-string device)))
1030 (declare (type (or simple-string null) char-init-string char-end-string))
1031 (when init-string (device-write-string init-string))
1032 (if char-init-string
1033 (do ((i start (1+ i)))
1034 ((= i end))
1035 (device-write-string char-init-string 0 cis-len)
1036 (tty-write-char (schar string i))
1037 (when char-end-string
1038 (device-write-string char-end-string 0 ces-len)))
1039 (device-write-string string start end))
1040 (when end-string (device-write-string end-string))
1041 (setf (tty-device-cursor-x device)
1042 (the fixnum (+ x (the fixnum (- end start)))))))
1043
1044 (defun worth-using-insert-mode (device insert-char-num)
1045 (let* ((init-string (tty-device-insert-init-string device))
1046 (char-init-string (tty-device-insert-char-init-string device))
1047 (char-end-string (tty-device-insert-char-end-string device))
1048 (end-string (tty-device-insert-end-string device))
1049 (cost 0))
1050 (when init-string (incf cost (length (the simple-string init-string))))
1051 (when char-init-string
1052 (incf cost (* insert-char-num (+ (length (the simple-string
1053 char-init-string))
1054 (if char-end-string
1055 (length (the simple-string
1056 char-end-string))
1057 0)))))
1058 (when end-string (incf cost (length (the simple-string end-string))))
1059 (< cost insert-char-num)))
1060
1061 (defun delete-char (hunk x y &optional (n 1))
1062 (declare (fixnum x y n))
1063 (update-cursor hunk x y)
1064 (let* ((device (device-hunk-device hunk))
1065 (init-string (tty-device-delete-init-string device))
1066 (end-string (tty-device-delete-end-string device))
1067 (delete-char-string (tty-device-delete-char-string device)))
1068 (when init-string (device-write-string init-string))
1069 (dotimes (i n)
1070 (device-write-string delete-char-string))
1071 (when end-string (device-write-string end-string))))
1072
1073 (defun worth-using-delete-mode (device delete-char-num clear-char-num)
1074 (declare (fixnum delete-char-num clear-char-num))
1075 (let ((init-string (tty-device-delete-init-string device))
1076 (end-string (tty-device-delete-end-string device))
1077 (delete-char-string (tty-device-delete-char-string device))
1078 (clear-to-eol-string (tty-device-clear-to-eol-string device))
1079 (cost 0))
1080 (declare (type (or simple-string null) init-string end-string
1081 delete-char-string)
1082 (fixnum cost))
1083 (when init-string (incf cost (the fixnum (length init-string))))
1084 (when end-string (incf cost (the fixnum (length end-string))))
1085 (incf cost (the fixnum
1086 (* (the fixnum (length delete-char-string))
1087 delete-char-num)))
1088 (< cost (+ delete-char-num
1089 (if clear-to-eol-string
1090 (length clear-to-eol-string)
1091 clear-char-num)))))
1092
1093
1094 ;;; Standout mode (TTY-DEVICE-STANDOUT-INIT and TTY-DEVICE-STANDOUT-END)
1095
1096 (defun standout-init (hunk)
1097 (device-write-string
1098 (tty-device-standout-init-string (device-hunk-device hunk))))
1099
1100 (defun standout-end (hunk)
1101 (device-write-string
1102 (tty-device-standout-end-string (device-hunk-device hunk))))

  ViewVC Help
Powered by ViewVC 1.1.5