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

  ViewVC Help
Powered by ViewVC 1.1.5