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

  ViewVC Help
Powered by ViewVC 1.1.5