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

  ViewVC Help
Powered by ViewVC 1.1.5