/[cmucl]/src/hemlock/cursor.lisp
ViewVC logotype

Contents of /src/hemlock/cursor.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3.2.1 - (show annotations)
Sat Mar 23 18:50:42 2002 UTC (12 years ago) by pw
Branch: RELENG_18
CVS Tags: RELEASE_18d
Changes since 1.3: +2 -2 lines
Mega commit to bring RELENG_18 branch in sync with HEAD in preparation
for release tagging 18d.
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 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/hemlock/cursor.lisp,v 1.3.2.1 2002/03/23 18:50:42 pw Exp $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; Written by Rob MacLachlan
13 ;;;
14 ;;; Cursor: Routines for cursor positioning and recentering
15 ;;;
16 (in-package "HEMLOCK-INTERNALS")
17 (export '(mark-to-cursorpos center-window displayed-p scroll-window
18 mark-column cursorpos-to-mark move-to-column))
19
20
21 ;;;; Mark-To-Cursorpos
22 ;;;
23 ;;; Since performance analysis showed that HALF of the time in the editor
24 ;;; was being spent in this function, I threw all of the tricks in the
25 ;;; book at it to try and make it tenser.
26 ;;;
27 ;;; The algorithm is roughly as follows:
28 ;;;
29 ;;; 1) Eliminate the annoying boundry condition of the mark being
30 ;;; off the end of the window, if it is return NIL now.
31 ;;; 2) If the charpos is on or immediately after the last character
32 ;;; in the line, then find the last dis-line on which the line is
33 ;;; displayed. We know that the mark is at the end of this dis-line
34 ;;; because it is known to be on the screen. X position is trivially
35 ;;; derived from the dis-line-length.
36 ;;; 3) Call Real-Line-Length or Cached-Real-Line-Length to get the
37 ;;; X position and number of times wrapped.
38
39 (declaim (special the-sentinel))
40
41 (eval-when (compile eval)
42 ;;; find-line
43 ;;;
44 ;;; Find a dis-line which line is displayed on which starts before
45 ;;; charpos, setting ypos and dis-line to the dis-line and it's index.
46 ;;; Offset is expected to be the mark-charpos of the display-start for
47 ;;; the window initially, and is set to offset within line that
48 ;;; Dis-Line begins. Charpos is the mark-charpos of the mark we want
49 ;;; to find. Check if same as *redisplay-favorite-line* and then scan
50 ;;; if not.
51 ;;;
52 (defmacro find-line (line offset charpos ypos dis-lines dis-line)
53 (declare (ignore charpos))
54 `(cond
55 ;; No lines at all, fail.
56 ((eq ,dis-lines the-sentinel) nil)
57 ;; On the first line, offset is already set, so just set dis-line and
58 ;; ypos and fall through.
59 ((eq (dis-line-line (car ,dis-lines)) ,line)
60 (setq ,dis-line ,dis-lines ,ypos 0))
61 ;; Look farther down.
62 ((do ((l (cdr ,dis-lines) (cdr l)))
63 ((eq l the-sentinel))
64 (when (eq (dis-line-line (car l)) ,line)
65 (setq ,dis-line l ,ypos (dis-line-position (car l)) ,offset 0)
66 (return t))))
67 (t
68 (error "Horrible flaming lossage, Sorry Man."))))
69
70 ;;; find-last
71 ;;;
72 ;;; Find the last dis-line on which line is displayed, set ypos and
73 ;;; dis-line.
74 ;;;
75 (defmacro find-last (line ypos dis-line)
76 `(do ((trail ,dis-line dl)
77 (dl (cdr ,dis-line) (cdr dl)))
78 ((not (eq (dis-line-line (car dl)) ,line))
79 (setq ,dis-line (car trail) ,ypos (dis-line-position ,dis-line)))))
80
81 ;;; find-charpos
82 ;;;
83 ;;; Special-Case mark at end of line, if not punt out to real-line-length
84 ;;; function. Return the correct values.
85 ;;;
86 (defmacro find-charpos (line offset charpos length ypos dis-line width
87 fun chars)
88 (declare (ignore chars))
89 `(cond
90 ((= ,charpos ,length)
91 (find-last ,line ,ypos ,dis-line)
92 (values (min (dis-line-length ,dis-line) (1- ,width)) ,ypos))
93 ((= ,charpos (1- ,length))
94 (multiple-value-bind (x dy)
95 (,fun ,line (1- ,width) ,offset ,charpos)
96 (if (and (not (zerop dy)) (zerop x))
97 (values (1- ,width) (1- (+ ,ypos dy)))
98 (values x (+ ,ypos dy)))))
99 (t
100 (multiple-value-bind (x dy)
101 (,fun ,line (1- ,width) ,offset ,charpos)
102 (values x (+ ,ypos dy))))))
103
104 ); eval-when (compile eval)
105
106 ;;; real-line-length
107 ;;;
108 ;;; Return as values the X position and the number of times wrapped if
109 ;;; one to display the characters from Start to End of Line starting at an
110 ;;; X position of 0 wrapping Width wide.
111 ;;; %SP-Find-Character-With-Attribute is used to find charaters
112 ;;; with funny representation much as in Compute-Line-Image.
113 ;;;
114 (defun real-line-length (line width start end)
115 (declare (fixnum width start end))
116 (do ((xpos 0)
117 (ypos 0)
118 (chars (line-chars line))
119 (losing 0)
120 (dy 0))
121 ((= start end) (values xpos ypos))
122 (declare (fixnum xpos ypos dy) (simple-string chars)
123 (type (or fixnum null) losing))
124 (setq losing (%fcwa chars start end losing-char))
125 (when (null losing)
126 (multiple-value-setq (dy xpos) (truncate (+ xpos (- end start)) width))
127 (return (values xpos (+ ypos dy))))
128 (multiple-value-setq (dy xpos) (truncate (+ xpos (- losing start)) width))
129 (setq ypos (+ ypos dy) start losing)
130 (do ((last (or (%fcwa chars start end winning-char) end)) str)
131 ((= start last))
132 (declare (fixnum last))
133 (setq str (get-rep (schar chars start)))
134 (incf start)
135 (unless (simple-string-p str) (setq str (funcall str xpos)))
136 (multiple-value-setq (dy xpos) (truncate (+ xpos (strlen str)) width))
137 (setq ypos (+ ypos dy)))))
138
139 ;;; cached-real-line-length
140 ;;;
141 ;;; The same as Real-Line-Length, except does it for the cached line.
142 ;;; the line argument is ignored, but present to make the arglists the
143 ;;; same.
144 ;;;
145 (defun cached-real-line-length (line width start end)
146 (declare (fixnum width start end) (ignore line))
147 (let ((offset (- right-open-pos left-open-pos))
148 (bound 0))
149 (declare (fixnum offset bound))
150 (cond
151 ((>= start left-open-pos)
152 (setq start (+ start offset) bound (setq end (+ end offset))))
153 ((> end left-open-pos)
154 (setq bound left-open-pos end (+ end offset)))
155 (t
156 (setq bound end)))
157
158 (do ((xpos 0)
159 (ypos 0)
160 (losing 0)
161 (dy 0))
162 (())
163 (declare (fixnum xpos ypos dy)
164 (type (or fixnum null) losing))
165 (when (= start bound)
166 (when (= start end) (return (values xpos ypos)))
167 (setq start right-open-pos bound end))
168 (setq losing (%fcwa open-chars start bound losing-char))
169 (cond
170 (losing
171 (multiple-value-setq (dy xpos)
172 (truncate (+ xpos (- losing start)) width))
173 (setq ypos (+ ypos dy) start losing)
174 (do ((last (or (%fcwa open-chars start bound winning-char) bound)) str)
175 ((= start last))
176 (declare (fixnum last))
177 (setq str (get-rep (schar open-chars start)))
178 (incf start)
179 (unless (simple-string-p str) (setq str (funcall str xpos)))
180 (multiple-value-setq (dy xpos)
181 (truncate (+ xpos (strlen str)) width))
182 (setq ypos (+ ypos dy))))
183 (t
184 (multiple-value-setq (dy xpos)
185 (truncate (+ xpos (- bound start)) width))
186 (setq ypos (+ ypos dy) start bound))))))
187
188 ;;; mark-to-cursorpos -- Public
189 ;;;
190 ;;; Return as multiple values the x and y position within window of
191 ;;; mark. NIL is returned if the mark is not displayed in the window given
192 ;;;
193 ;;;
194 (defun mark-to-cursorpos (mark window)
195 "Return the (x, y) position of mark within window, or NIL if not displayed."
196 (maybe-update-window-image window)
197 (let* ((line (mark-line mark))
198 (number (line-number line))
199 (charpos (mark-charpos mark))
200 (dis-lines (cdr (window-first-line window)))
201 (width (window-width window))
202 (start (window-display-start window))
203 (offset (mark-charpos start))
204 (start-number (line-number (mark-line start)))
205 (end (window-display-end window))
206 (end-number (line-number (mark-line end)))
207 (ypos 0)
208 dis-line)
209 (declare (fixnum width charpos ypos number end-number))
210 (cond
211 ((or (< number start-number)
212 (and (= number start-number) (< charpos offset))
213 (> number end-number)
214 (and (= number end-number) (> charpos (mark-charpos end)))) nil)
215 (t
216 (find-line line offset charpos ypos dis-lines dis-line)
217 (cond
218 ((eq line open-line)
219 (let ((len (- line-cache-length (- right-open-pos left-open-pos))))
220 (declare (fixnum len))
221 (find-charpos line offset charpos len ypos dis-line width
222 cached-real-line-length open-chars)))
223 (t
224 (let* ((chars (line-chars line))
225 (len (strlen chars)))
226 (declare (fixnum len) (simple-string chars))
227 (find-charpos line offset charpos len ypos dis-line width
228 real-line-length chars))))))))
229
230 ;;; Dis-Line-Offset-Guess -- Internal
231 ;;;
232 ;;; Move Mark by Offset display lines. The mark is assumed to be at the
233 ;;; beginning of a display line, and we attempt to leave it at one. We assume
234 ;;; all characters print one wide. Width is the width of the window we are
235 ;;; displaying in.
236 ;;;
237 (defun dis-line-offset-guess (mark offset width)
238 (let ((w (1- width)))
239 (if (minusp offset)
240 (dotimes (i (- offset) t)
241 (let ((pos (mark-charpos mark)))
242 (if (>= pos w)
243 (character-offset mark (- w))
244 (let ((prev (line-previous (mark-line mark))))
245 (unless prev (return nil))
246 (multiple-value-bind
247 (lines chars)
248 (truncate (line-length prev) w)
249 (move-to-position mark
250 (cond ((zerop lines) 0)
251 ((< chars 2)
252 (* w (1- lines)))
253 (t
254 (* w lines)))
255 prev))))))
256 (dotimes (i offset t)
257 (let ((left (- (line-length (mark-line mark))
258 (mark-charpos mark))))
259 (if (> left width)
260 (character-offset mark w)
261 (unless (line-offset mark 1 0)
262 (return nil))))))))
263
264 ;;; maybe-recenter-window -- Internal
265 ;;;
266 ;;; Update the dis-lines for Window and recenter if the point is off
267 ;;; the screen.
268 ;;;
269 (defun maybe-recenter-window (window)
270 (unless (%displayed-p (buffer-point (window-buffer window)) window)
271 (center-window window (buffer-point (window-buffer window)))
272 t))
273
274 ;;; center-window -- Public
275 ;;;
276 ;;; Try to move the start of window so that Mark is on a line in the
277 ;;; center.
278 ;;;
279 (defun center-window (window mark)
280 "Adjust the start of Window so that Mark is displayed on the center line."
281 (let ((height (window-height window))
282 (start (window-display-start window)))
283 (move-mark start mark)
284 (unless (dis-line-offset-guess start (- (truncate height 2))
285 (window-width window))
286 (move-mark start (buffer-start-mark (window-buffer window))))
287 (update-window-image window)
288 ;; If that doesn't work, panic and make the start the point.
289 (unless (%displayed-p mark window)
290 (move-mark start mark)
291 (update-window-image window))))
292
293
294 ;;; %Displayed-P -- Internal
295 ;;;
296 ;;; If Mark is within the displayed bounds in Window, then return true,
297 ;;; otherwise false. We assume the window image is up to date.
298 ;;;
299 (defun %displayed-p (mark window)
300 (let ((start (window-display-start window))
301 (end (window-display-end window)))
302 (not (or (mark< mark start) (mark> mark end)
303 (if (mark= mark end)
304 (let ((ch (next-character end)))
305 (and ch (char/= ch #\newline)))
306 nil)))))
307
308
309 ;;; Displayed-p -- Public
310 ;;;
311 ;;; Update the window image and then check if the mark is displayed.
312 ;;;
313 (defun displayed-p (mark window)
314 "Return true if Mark is displayed on Window, false otherwise."
315 (maybe-update-window-image window)
316 (%displayed-p mark window))
317
318
319 ;;; scroll-window -- Public
320 ;;;
321 ;;; This is not really right, since it uses dis-line-offset-guess.
322 ;;; Probably if there is any screen overlap then we figure it out
323 ;;; exactly.
324 ;;;
325 (defun scroll-window (window n)
326 "Scroll Window down N lines, up if negative."
327 (let ((start (window-display-start window))
328 (point (window-point window))
329 (width (window-width window))
330 (height (window-height window)))
331 (cond ((dis-line-offset-guess start n width))
332 ((minusp n)
333 (buffer-start start))
334 (t
335 (buffer-end start)
336 (let ((fraction (- (truncate height 3) height)))
337 (dis-line-offset-guess start fraction width))))
338 (update-window-image window)
339 (let ((iscurrent (eq window *current-window*))
340 (bpoint (buffer-point (window-buffer window))))
341 (when iscurrent (move-mark point bpoint))
342 (unless (%displayed-p point window)
343 (move-mark point start)
344 (dis-line-offset-guess point (truncate (window-height window) 2)
345 width)
346 (when iscurrent (move-mark bpoint point)))))
347 t)
348
349 ;;; Mark-Column -- Public
350 ;;;
351 ;;; Find the X position of a mark supposing that it were displayed
352 ;;; in an infinitely wide screen.
353 ;;;
354 (defun mark-column (mark)
355 "Find the X position at which Mark would be displayed if it were on
356 an infinitely wide screen. This takes into account tabs and control
357 characters."
358 (let ((charpos (mark-charpos mark))
359 (line (mark-line mark)))
360 (if (eq line open-line)
361 (values (cached-real-line-length line 10000 0 charpos))
362 (values (real-line-length line 10000 0 charpos)))))
363
364 ;;; Find-Position -- Internal
365 ;;;
366 ;;; Return the charpos which corresponds to the specified X position
367 ;;; within Line. If there is no such position between Start and End then
368 ;;; rutne NIL.
369 ;;;
370 (defun find-position (line position start end width)
371 (do* ((cached (eq line open-line))
372 (lo start)
373 (hi (1- end))
374 (probe (truncate (+ lo hi) 2) (truncate (+ lo hi) 2)))
375 ((> lo hi)
376 (if (= lo end) nil hi))
377 (let ((val (if cached
378 (cached-real-line-length line width start probe)
379 (real-line-length line width start probe))))
380 (cond ((= val position) (return probe))
381 ((< val position) (setq lo (1+ probe)))
382 (t (setq hi (1- probe)))))))
383
384 ;;; Cursorpos-To-Mark -- Public
385 ;;;
386 ;;; Find the right dis-line, then zero in on the correct position
387 ;;; using real-line-length.
388 ;;;
389 (defun cursorpos-to-mark (x y window)
390 (check-type window window)
391 (let ((width (window-width window))
392 (first (window-first-line window)))
393 (when (>= x width)
394 (return-from cursorpos-to-mark nil))
395 (do* ((prev first dl)
396 (dl (cdr first) (cdr dl))
397 (ppos (mark-charpos (window-display-start window))
398 (if (eq (dis-line-line (car dl)) (dis-line-line (car prev)))
399 (dis-line-end (car prev)) 0)))
400 ((eq dl the-sentinel)
401 (copy-mark (window-display-end window) :temporary))
402 (when (= (dis-line-position (car dl)) y)
403 (let* ((line (dis-line-line (car dl)))
404 (end (dis-line-end (car dl))))
405 (return (mark line (or (find-position line x ppos end width) end))))))))
406
407 ;;; Move-To-Column -- Public
408 ;;;
409 ;;; Just look up the charpos using find-position...
410 ;;;
411 (defun move-to-column (mark column &optional (line (mark-line mark)))
412 "Move Mark to the specified Column on Line. This function is analogous
413 to Move-To-Position, but it deals with the physical screen position
414 as returned by Mark-Column; the mark is moved to before the character
415 which would be displayed in Column if the line were displayed on
416 an infinitely wide screen. If the column specified is greater than
417 the column of the last character, then Nil is returned and the mark
418 is not modified."
419 (let ((res (find-position line column 0 (line-length line) 10000)))
420 (if res
421 (move-to-position mark res line))))

  ViewVC Help
Powered by ViewVC 1.1.5