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

  ViewVC Help
Powered by ViewVC 1.1.5