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

Contents of /src/hemlock/cursor.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5