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

  ViewVC Help
Powered by ViewVC 1.1.5