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