source: tags/pre_1_0_pre_hash_modifications/ccl/hemlock/src/bit-display.lisp @ 2475

Last change on this file since 2475 was 2475, checked in by anonymous, 14 years ago

This commit was manufactured by cvs2svn to create tag
'pre_1_0_pre_hash_modifications'.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 10.9 KB
Line 
1;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
2;;;
3;;; **********************************************************************
4;;; This code was written as part of the CMU Common Lisp project at
5;;; Carnegie Mellon University, and has been placed in the public domain.
6;;;
7#+CMU (ext:file-comment
8  "$Header$")
9;;;
10;;; **********************************************************************
11;;;
12;;;    Written by Rob MacLachlan
13;;;    Modified by Bill Chiles to run under X on IBM RT's.
14;;;
15
16(in-package :hemlock-internals)
17
18
19;;; prepare-window-for-redisplay  --  Internal
20;;;
21;;;    Called by make-window to do whatever redisplay wants to set up
22;;; a new window.
23;;;
24(defun prepare-window-for-redisplay (window)
25  (setf (window-old-lines window) 0))
26
27
28
29;;;; Dumb window redisplay.
30
31;;; DUMB-WINDOW-REDISPLAY redraws an entire window using dumb-line-redisplay.
32;;; This assumes the cursor has been lifted if necessary.
33;;;
34(defun dumb-window-redisplay (window)
35  (let* ((hunk (window-hunk window))
36         (first (window-first-line window)))
37    (hunk-reset hunk)
38    (do ((i 0 (1+ i))
39         (dl (cdr first) (cdr dl)))
40        ((eq dl *the-sentinel*)
41         (setf (window-old-lines window) (1- i)))
42      (dumb-line-redisplay hunk (car dl)))
43    (setf (window-first-changed window) *the-sentinel*
44          (window-last-changed window) first)
45    (when (window-modeline-buffer window)
46      (hunk-replace-modeline hunk)
47      (setf (dis-line-flags (window-modeline-dis-line window))
48            unaltered-bits))
49    (setf (bitmap-hunk-start hunk) (cdr (window-first-line window)))))
50
51
52;;; DUMB-LINE-REDISPLAY is used when the line is known to be cleared already.
53;;;
54(defun dumb-line-redisplay (hunk dl)
55  (hunk-write-line hunk dl)
56  (setf (dis-line-flags dl) unaltered-bits (dis-line-delta dl) 0))
57
58
59
60;;;; Smart window redisplay.
61
62;;; We scan through the changed dis-lines, and condense the information
63;;; obtained into five categories: Unchanged lines moved down, unchanged
64;;; lines moved up, lines that need to be cleared, lines that are in the
65;;; same place (but changed), and new or moved-and-changed lines to write.
66;;; Each such instance of a thing that needs to be done is remembered be
67;;; throwing needed information on a stack specific to the thing to be
68;;; done.  We cannot do any of these things right away because each may
69;;; confict with the previous.
70;;;
71;;; Each stack is represented by a simple-vector big enough to hold the
72;;; worst-case number of entries and a pointer to the next free entry.  The
73;;; pointers are local variables returned from COMPUTE-CHANGES and used by
74;;; SMART-WINDOW-REDISPLAY.  Note that the order specified in these tuples
75;;; is the order in which they were pushed.
76;;;
77(defvar *display-down-move-stack* (make-array (* hunk-height-limit 2))
78  "This is the vector that we stash info about which lines moved down in
79  as (Start, End, Count) triples.")
80(defvar *display-up-move-stack* (make-array (* hunk-height-limit 2))
81  "This is the vector that we stash info about which lines moved up in
82  as (Start, End, Count) triples.")
83(defvar *display-erase-stack* (make-array hunk-height-limit)
84  "This is the vector that we stash info about which lines need to be erased
85  as (Start, Count) pairs.")
86(defvar *display-write-stack* (make-array hunk-height-limit)
87  "This is the vector that we stash dis-lines in that need to be written.")
88(defvar *display-rewrite-stack* (make-array hunk-height-limit)
89  "This is the vector that we stash dis-lines in that need to be written.
90  with clear-to-end.")
91
92;;; Accessor macros to push and pop on the stacks:
93;;;
94(eval-when (:compile-toplevel :execute)
95
96(defmacro spush (thing stack stack-pointer)
97  `(progn
98    (setf (svref ,stack ,stack-pointer) ,thing)
99    (incf ,stack-pointer)))
100
101(defmacro spop (stack stack-pointer)
102  `(svref ,stack (decf ,stack-pointer)))
103
104(defmacro snext (stack stack-pointer)
105  `(prog1 (svref ,stack ,stack-pointer) (incf ,stack-pointer)))
106
107); eval-when
108
109
110;;; SMART-WINDOW-REDISPLAY only re-writes lines which may have been changed,
111;;; and updates them with smart-line-redisplay if not very much has changed.
112;;; Lines which have moved are copied.  We must be careful not to redisplay
113;;; the window with the cursor down since it is not guaranteed to be out of
114;;; the way just because we are in redisplay; LIFT-CURSOR is called just before
115;;; the screen may be altered, and it takes care to know whether the cursor
116;;; is lifted already or not.  At the end, if the cursor had been down,
117;;; DROP-CURSOR puts it back; it doesn't matter if LIFT-CURSOR was never called
118;;; since it does nothing if the cursor is already down.
119;;;
120(defun smart-window-redisplay (window)
121  ;; This isn't actually called --GB
122  (let* ((hunk (window-hunk window))
123         (liftp (and (eq *cursor-hunk* hunk) *cursor-dropped*)))
124    (when (bitmap-hunk-trashed hunk)
125      (when liftp (lift-cursor))
126      (dumb-window-redisplay window)
127      (when liftp (drop-cursor))
128      (return-from smart-window-redisplay nil))
129    (let ((first-changed (window-first-changed window))
130          (last-changed (window-last-changed window)))
131      ;; Is there anything to do?
132      (unless (eq first-changed *the-sentinel*)
133        (when liftp (lift-cursor))
134        (if (and (eq first-changed last-changed)
135                 (zerop (dis-line-delta (car first-changed))))
136            ;; One line changed.
137            (smart-line-redisplay hunk (car first-changed))
138            ;; More than one line changed.
139            (multiple-value-bind (up down erase write rewrite)
140                                 (compute-changes first-changed last-changed)
141              (do-down-moves hunk down)
142              (do-up-moves hunk up)
143              (do-erases hunk erase)
144              (do-writes hunk write)
145              (do-rewrites hunk rewrite)))
146        ;; Set the bounds so we know we displayed...
147        (setf (window-first-changed window) *the-sentinel*
148              (window-last-changed window) (window-first-line window))))
149    ;;
150    ;; Clear any extra lines at the end of the window.
151    (let ((pos (dis-line-position (car (window-last-line window)))))
152      (when (< pos (window-old-lines window))
153        (when liftp (lift-cursor))
154        (hunk-clear-lines hunk (1+ pos) (- (window-height window) pos 1)))
155      (setf (window-old-lines window) pos))
156    ;;
157    ;; Update the modeline if needed.
158    (when (window-modeline-buffer window)
159      (when (/= (dis-line-flags (window-modeline-dis-line window))
160                unaltered-bits)
161        (hunk-replace-modeline hunk)
162        (setf (dis-line-flags (window-modeline-dis-line window))
163              unaltered-bits)))
164    ;;
165    (setf (bitmap-hunk-start hunk) (cdr (window-first-line window)))
166    (when liftp (drop-cursor))))
167
168;;; COMPUTE-CHANGES is used once in smart-window-redisplay, and it scans
169;;; through the changed dis-lines in a window, computes the changes needed
170;;; to bring the screen into corespondence, and throws the information
171;;; needed to do the change onto the apropriate stack.  The pointers into
172;;; the stacks (up, down, erase, write, and rewrite) are returned.
173;;;
174;;; The algorithm is as follows:
175;;; 1] If the line is moved-and-changed or new then throw the line on
176;;; the write stack and increment the clear count.  Repeat until no more
177;;; such lines are found.
178;;; 2] If the line is moved then flush any pending clear, find how many
179;;; consecutive lines are moved the same amount, and put the numbers
180;;; on the correct move stack.
181;;; 3] If the line is changed and unmoved throw it on a write stack.
182;;; If a clear is pending throw it in the write stack and bump the clear
183;;; count, otherwise throw it on the rewrite stack.
184;;; 4] The line is unchanged, do nothing.
185;;;
186(defun compute-changes (first-changed last-changed)
187  (let* ((dl first-changed)
188         (flags (dis-line-flags (car dl)))
189         (up 0) (down 0) (erase 0) (write 0) (rewrite 0) ;return values.
190         (clear-count 0)
191         prev clear-start)
192    (declare (fixnum up down erase write rewrite clear-count))
193    (loop
194      (cond
195       ;; Line moved-and-changed or new.
196       ((> flags moved-bit)
197        (when (zerop clear-count)
198          (setq clear-start (dis-line-position (car dl))))
199        (loop
200          (setf (dis-line-delta (car dl)) 0)
201          (spush (car dl) *display-write-stack* write)
202          (incf clear-count)
203          (setq prev dl  dl (cdr dl)  flags (dis-line-flags (car dl)))
204          (when (<= flags moved-bit) (return nil))))
205       ;; Line moved, unchanged.
206       ((= flags moved-bit)
207        (unless (zerop clear-count)
208          (spush clear-count *display-erase-stack* erase)
209          (spush clear-start *display-erase-stack* erase)
210          (setq clear-count 0))
211        (do ((delta (dis-line-delta (car dl)))
212             (end (dis-line-position (car dl)))
213             (count 1 (1+ count)))
214            (())
215          (setf (dis-line-delta (car dl)) 0
216                (dis-line-flags (car dl)) unaltered-bits)
217          (setq prev dl  dl (cdr dl)  flags (dis-line-flags (car dl)))
218          (when (or (/= (dis-line-delta (car dl)) delta) (/= flags moved-bit))
219            ;; We push in different order because we pop in different order.
220            (cond
221             ((minusp delta)
222              (spush (- end delta) *display-up-move-stack* up)
223              (spush end *display-up-move-stack* up)
224              (spush count *display-up-move-stack* up))
225             (t
226              (spush count *display-down-move-stack* down)
227              (spush end *display-down-move-stack* down)
228              (spush (- end delta) *display-down-move-stack* down)))
229            (return nil))))
230       ;; Line changed, unmoved.
231       ((= flags changed-bit)
232        (cond ((zerop clear-count)
233               (spush (car dl) *display-rewrite-stack* rewrite))
234              (t
235               (spush (car dl) *display-write-stack* write)
236               (incf clear-count)))
237        (setq prev dl  dl (cdr dl)  flags (dis-line-flags (car dl))))
238       ;; Line unmoved, unchanged.
239       (t
240        (unless (zerop clear-count)
241          (spush clear-count *display-erase-stack* erase)
242          (spush clear-start *display-erase-stack* erase)
243          (setq clear-count 0))
244        (setq prev dl  dl (cdr dl)  flags (dis-line-flags (car dl)))))
245     
246     (when (eq prev last-changed)
247       ;; If done flush any pending clear.
248       (unless (zerop clear-count)
249         (spush clear-count *display-erase-stack* erase)
250         (spush clear-start *display-erase-stack* erase))
251       (return (values up down erase write rewrite))))))
252
253(defun do-up-moves (hunk up)
254  (do ((i 0))
255      ((= i up))
256    (hunk-copy-lines hunk (snext *display-up-move-stack* i)
257                     (snext *display-up-move-stack* i)
258                     (snext *display-up-move-stack* i))))
259
260(defun do-down-moves (hunk down)
261  (do ()
262      ((zerop down))
263    (hunk-copy-lines hunk (spop *display-down-move-stack* down)
264                     (spop *display-down-move-stack* down)
265                     (spop *display-down-move-stack* down))))
266
267(defun do-erases (hunk erase)
268  (do ()
269      ((zerop erase))
270    (hunk-clear-lines hunk (spop *display-erase-stack* erase)
271                      (spop *display-erase-stack* erase))))
272
273(defun do-writes (hunk write)
274  (do ((i 0))
275      ((= i write))
276    (dumb-line-redisplay hunk (snext *display-write-stack* i))))
277
278(defun do-rewrites (hunk rewrite)
279  (do ()
280      ((zerop rewrite))
281    (smart-line-redisplay hunk (spop *display-rewrite-stack* rewrite))))
282
283
284;;; SMART-LINE-REDISPLAY is called when the screen is mostly the same,
285;;; clear to eol after we write it to avoid annoying flicker.
286;;;
287(defun smart-line-redisplay (hunk dl)
288  (hunk-replace-line hunk dl)
289  (setf (dis-line-flags dl) unaltered-bits (dis-line-delta dl) 0))
Note: See TracBrowser for help on using the repository browser.