/[cmucl]/src/hemlock/tty-display.lisp
ViewVC logotype

Contents of /src/hemlock/tty-display.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5