source: trunk/ccl/hemlock/src/cursor.lisp @ 775

Last change on this file since 775 was 775, checked in by gb, 16 years ago

Remove a few CLXisms.

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