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

  ViewVC Help
Powered by ViewVC 1.1.5