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