/[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.7 - (show annotations) (vendor branch)
Fri Mar 15 22:17:36 1991 UTC (23 years, 1 month ago) by ram
Changes since 1.1.1.6: +40 -19 lines
Changed standout mode start for the modeline to be inside the protected
form, just in case.
Added *TTY-LINE-MOVES*, which is a list of lines that have been moved,
but not otherwise changed.  These lines should have their delta cleared
after display as successfully completed.
In COMPUTE-TTY-CHANGES in the move loop, check for hitting end of the 
window.
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.7 1991/03/15 22:17:36 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 (window-old-lines 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 (window-old-lines 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