/[mcclim]/mcclim/Drei/drei-redisplay.lisp
ViewVC logotype

Contents of /mcclim/Drei/drei-redisplay.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.71 - (show annotations)
Sat May 3 07:47:17 2008 UTC (5 years, 11 months ago) by thenriksen
Branch: MAIN
CVS Tags: HEAD
Changes since 1.70: +0 -5 lines
Moved defvar to remove warnings.
1 ;;; -*- Mode: Lisp; Package: DREI -*-
2
3 ;;; (c) copyright 2005 by
4 ;;; Robert Strandh (strandh@labri.fr)
5 ;;; (c) copyright 2005 by
6 ;;; Matthieu Villeneuve (matthieu.villeneuve@free.fr)
7 ;;; (c) copyright 2005 by
8 ;;; Aleksandar Bakic (a_bakic@yahoo.com)
9 ;;; (c) copyright 2006 by
10 ;;; Troels Henriksen (athas@sigkill.dk)
11
12 ;;; This library is free software; you can redistribute it and/or
13 ;;; modify it under the terms of the GNU Library General Public
14 ;;; License as published by the Free Software Foundation; either
15 ;;; version 2 of the License, or (at your option) any later version.
16 ;;;
17 ;;; This library is distributed in the hope that it will be useful,
18 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
20 ;;; Library General Public License for more details.
21 ;;;
22 ;;; You should have received a copy of the GNU Library General Public
23 ;;; License along with this library; if not, write to the
24 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
25 ;;; Boston, MA 02111-1307 USA.
26
27 ;;; Declarations and definitions of the generic functions and helper
28 ;;; utilities needed for the Drei redisplay engine
29
30 (in-package :drei)
31
32 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
33 ;;;
34 ;;; Display of Drei instances.
35 ;;;
36 ;;; The basic Drei redisplay functions:
37
38 (defgeneric display-drei-view-contents (stream view)
39 (:documentation "The purpose of this function is to display the
40 contents of a Drei view to some output surface. `Stream' is the
41 CLIM output stream that redisplay should be performed on, `view'
42 is the Drei view instance that is being displayed. Methods
43 defined for this generic function can draw whatever they want,
44 but they should not assume that they are the only user of
45 `stream', unless the `stream' argument has been specialized to
46 some application-specific pane class that can guarantee this. For
47 example, when accepting multiple values using the
48 `accepting-values' macro, several Drei instances will be
49 displayed simultaneously on the same stream. It is permitted to
50 only specialise `stream' on `clim-stream-pane' and not
51 `extended-output-stream'. When writing methods for this function,
52 be aware that you cannot assume that the buffer will contain only
53 characters, and that any subsequence of the buffer is coercable
54 to a string. Drei buffers can contain arbitrary objects, and
55 redisplay methods are required to handle this (though they are
56 not required to handle it nicely, they can just ignore the
57 object, or display the `princ'ed representation.)")
58 (:method :around ((stream extended-output-stream) (view drei-view))
59 (letf (((stream-default-view stream) view))
60 (call-next-method))))
61
62 (defgeneric display-drei-view-cursor (stream view cursor)
63 (:documentation "The purpose of this function is to display a
64 visible indication of a cursor of a Drei view to some output
65 surface. `Stream' is the CLIM output stream that drawing should
66 be performed on, `view' is the Drei view object that is being
67 redisplayed, `cursor' is the cursor object to be displayed (a
68 subclass of `drei-cursor') and `syntax' is the syntax object of
69 `view'. Methods on this generic function can draw whatever they
70 want, but they should not assume that they are the only user of
71 `stream', unless the `stream' argument has been specialized to
72 some application-specific pane class that can guarantee this. It
73 is permitted to only specialise `stream' on `clim-stream-pane'
74 and not `extended-output-stream'. It is recommended to use the
75 function `offset-to-screen-position' to determine where to draw
76 the visual representation for the cursor. It is also recommended
77 to use the ink specified by `cursor' to perform the drawing, if
78 applicable. This method will only be called by the Drei redisplay
79 engine when the cursor is active and the buffer position it
80 refers to is on display - therefore, `offset-to-screen-position'
81 is *guaranteed* to not return NIL or T.")
82 (:method :around ((stream extended-output-stream) (view drei-view)
83 (cursor drei-cursor))
84 (when (visible-p cursor)
85 (letf (((stream-default-view stream) view))
86 (call-next-method)))))
87
88 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
89 ;;;
90 ;;; The standard redisplay implementation for buffer views.
91
92 (defstruct face
93 "A face is a description of how to draw (primarily) text, it
94 consists of an ink (a colour) and a text style. The text style
95 may be incomplete, in which case it is merged with the default
96 text style whenever it needs to be used."
97 (ink +foreground-ink+)
98 (style nil))
99
100 (defconstant +default-stroke-drawer-dispatcher+
101 #'(lambda (stream view stroke cursor-x cursor-y default-drawing-fn draw)
102 (funcall default-drawing-fn stream view stroke cursor-x cursor-y draw))
103 "A simple function of seven arguments that simply calls the
104 first argument as a function with the remaining sex
105 arguments. Used as the default drawing-function of
106 `drawing-options' objects.")
107
108 (defstruct drawing-options
109 "A set of options for how to display a stroke."
110 (face (make-face))
111 (function +default-stroke-drawer-dispatcher+))
112
113 (defun drawing-options-equal (o1 o2)
114 "Return true if `o1' and `o2' are equal, that is, they specify
115 the same options. Does not take the drawing-function into account
116 due to the halting problem (and also, for more practical
117 reasons), with the exception that no `drawing-options' object
118 with a non-`stroke-drawing-fn' drawing function is equivalent to
119 a `drawing-options' with a `stroke-drawing-fn' drawing function."
120 (let ((f1 (drawing-options-face o1))
121 (f2 (drawing-options-face o2)))
122 (and (equal (face-ink f1) (face-ink f2))
123 (equal (face-style f1) (face-style f2))
124 (or (not (eq (drawing-options-function o1)
125 +default-stroke-drawer-dispatcher+))
126 (eq (drawing-options-function o2)
127 +default-stroke-drawer-dispatcher+))
128 (or (not (eq (drawing-options-function o2)
129 +default-stroke-drawer-dispatcher+))
130 (eq (drawing-options-function o1)
131 +default-stroke-drawer-dispatcher+)))))
132
133 (defvar +default-drawing-options+ (make-drawing-options)
134 "The default set of drawing options used for strokes when
135 nothing else has been specified, or when the default is good
136 enough. Under these options, the region will be printed as a
137 string with the default foreground color.")
138
139 (defstruct (dimensions :conc-name)
140 "A simple mutable rectangle structure. The coordinates should
141 be absolute coordinates in the coordinate system of a sheet. A
142 special `center' slot is also provided to enable the recording of
143 what might be considered a *logical* centre of the dimensions on
144 the vertical axis. `Center' should be relative to `y1'."
145 (x1 0)
146 (y1 0)
147 (x2 0)
148 (y2 0)
149 (center 0))
150
151 (defun dimensions-height (dimensions)
152 "Return the width of the provided `dimensions' object."
153 (- (y2 dimensions) (y1 dimensions)))
154
155 (defun dimensions-width (dimensions)
156 "Return the width of the provided `dimensions' object."
157 (- (x2 dimensions) (x1 dimensions)))
158
159 (defun coordinates-intersects-dimensions (dimensions x1 y1 x2 y2)
160 "Return true if the rectangle defined by (x1, y1), (x2, y2)
161 intersects with the rectangle defined by `dimensions'."
162 (and (or (<= x1 (x1 dimensions) x2)
163 (<= x1 (x2 dimensions) x2)
164 (<= (x1 dimensions) x1 (x2 dimensions))
165 (<= (x1 dimensions) x2 (x2 dimensions)))
166 (or (<= y1 (y1 dimensions) y2)
167 (<= y1 (y2 dimensions) y2)
168 (<= (y1 dimensions) y1 (y2 dimensions))
169 (<= (y1 dimensions) y2 (y2 dimensions)))))
170
171 (defstruct (displayed-stroke (:conc-name stroke-))
172 "A stroke is a description of how a buffer region (`start-offset',
173 `end-offset') is displayed on the screen. If `dirty' is true,
174 something has obscured or scribbled over the part of the screen
175 area taken up by the stroke. If `modified' is true, this stroke
176 object might output something different than the last time it was
177 redisplayed, and should thus update any caches or similar. When
178 `modified' is set, `dirty' probably also should be set.
179 `widths' is an array of cumulative screen-resolution widths of
180 the `parts', being a run of characters or a non-graphic character:
181 see ANALYSE-STROKE-STRING."
182 (start-offset)
183 (end-offset)
184 (drawing-options +default-drawing-options+)
185 (dirty t)
186 (modified t)
187 (dimensions (make-dimensions))
188 (widths)
189 (parts))
190
191 (defun stroke-at-end-of-line (buffer stroke)
192 "Return true if the end offset of `stroke' is at the end of a
193 line in `buffer'. Otherwise, return nil. The end offset of
194 `stroke' must be a valid offset for `buffer' or an error will be
195 signalled."
196 (offset-end-of-line-p buffer (stroke-end-offset stroke)))
197
198 (defstruct (displayed-line (:conc-name line-))
199 "A line on display. A line delimits a buffer region (always
200 bounded by newline objects or border beginning/end) and contains
201 strokes. `Stroke-count' tells how many of the stroke objects in
202 `stroke' are actually live, and how many are old, stale objects
203 to prevent the need for consing if new strokes are added to the
204 line."
205 (start-offset 0)
206 (end-offset)
207 (dimensions (make-dimensions))
208 (strokes (make-array 0 :adjustable t))
209 (stroke-count 0))
210
211 (defgeneric pump-state-for-offset (view offset)
212 (:documentation "Return a pump state that will enable pumping
213 strokes from `offset' in the buffer of `view' (via
214 `stroke-pump'). The pump state is not guaranteed to be valid past
215 the next call to `stroke-pump' or `synchronize-view'. The results
216 are undefined if `offset' is not at the beginning of a line.")
217 (:method ((view drei-syntax-view) (offset integer))
218 (pump-state-for-offset-with-syntax view (syntax view) offset)))
219
220 (defgeneric stroke-pump (view stroke pump-state)
221 (:documentation "Put stroke information in `stroke', returns
222 new pump-state. `Pump-state' must either be the result of a call
223 to `pump-state-for-offset' or be the return value of an earlier
224 call to `stroke-pump'. A pump state is not guaranteed to be
225 valid past the next call to `stroke-pump' or
226 `synchronize-view'. It is permissible for `pump-state' to be
227 destructively modified by this function.")
228 (:method ((view drei-syntax-view) stroke pump-state)
229 (stroke-pump-with-syntax view (syntax view) stroke pump-state)))
230
231 (defun clear-rectangle* (stream x1 y1 x2 y2)
232 "Draw on `stream' from (x1,y1) to (x2,y2) with the background
233 ink for the stream."
234 (draw-rectangle* stream x1 y1 x2 y2 :ink +background-ink+))
235
236 (defun invalidate-stroke (stroke &key modified cleared)
237 "Invalidate `stroke' by setting its dirty-bit to true. If
238 `modified' or `cleared' is true, also set the modified-bit to
239 true. If `cleared' is true, inform the stroke that its previous
240 output has been cleared by someone, and that it does not need to
241 clear it itself during its next redisplay."
242 (setf (stroke-dirty stroke) t
243 (stroke-modified stroke)
244 (or (stroke-modified stroke)
245 modified
246 cleared))
247 (when cleared
248 (setf (x1 (stroke-dimensions stroke)) 0
249 (y1 (stroke-dimensions stroke)) 0
250 (x2 (stroke-dimensions stroke)) 0
251 (y2 (stroke-dimensions stroke)) 0)))
252
253 (defun invalidate-line-strokes (line &key modified cleared)
254 "Invalidate all the strokes of `line' by setting their
255 dirty-bit to true. If `modified' or `cleared' is true, also set
256 their modified-bit to true. If `cleared' is true, inform the
257 strokes that their previous output has been cleared by someone,
258 and that they do not need to clear it themselves during their
259 next redisplay."
260 (loop for stroke across (line-strokes line)
261 do (invalidate-stroke stroke :modified modified
262 :cleared cleared)))
263
264 (defun invalidate-all-strokes (view &key modified cleared)
265 "Invalidate all the strokes of `view' by setting their
266 dirty-bit to true. If `modified' or `cleared' is true, also set
267 their modified-bit to true. If `cleared' is true, inform the
268 strokes that their previous output has been cleared by someone,
269 and that they do not need to clear it themselves during their
270 next redisplay."
271 (loop for line across (displayed-lines view)
272 do (invalidate-line-strokes line
273 :modified modified :cleared cleared)))
274
275 (defmacro do-displayed-lines ((line-sym view) &body body)
276 "Loop over lines on display for `view', evaluating `body' with
277 `line-sym' bound to the `displayed-line' object for each line."
278 (check-type line-sym symbol)
279 (with-gensyms (line-index)
280 (once-only (view)
281 `(dotimes (,line-index (displayed-lines-count ,view))
282 (let ((,line-sym (aref (displayed-lines ,view) ,line-index)))
283 ,@body)))))
284
285 (defmacro do-undisplayed-lines ((line-sym view) &body body)
286 "Loop over lines not on display for `view', evaluating `body'
287 with `line-sym' bound to the `displayed-line' object for each
288 line."
289 (check-type line-sym symbol)
290 (with-gensyms (line-index)
291 (once-only (view)
292 `(dotimes (,line-index (- (length (displayed-lines ,view)) (displayed-lines-count ,view)))
293 (let ((,line-sym (aref (displayed-lines ,view)
294 (+ (displayed-lines-count ,view) ,line-index))))
295 ,@body)))))
296
297 (defmacro do-displayed-line-strokes ((stroke-sym line &optional) &body body)
298 "Loop over the displayed strokes of `line', evaluating `body'
299 with `stroke-sym' bound to the `displayed-stroke' object for each
300 line."
301 (check-type stroke-sym symbol)
302 (with-gensyms (stroke-index)
303 (once-only (line)
304 `(dotimes (,stroke-index (line-stroke-count ,line))
305 (let* ((,stroke-sym (aref (line-strokes ,line) ,stroke-index)))
306 ,@body)))))
307
308 (defmacro do-undisplayed-line-strokes ((stroke-sym line &optional) &body body)
309 "Loop over the undisplayed strokes of `line', evaluating `body'
310 with `stroke-sym' bound to the `displayed-stroke' object for each
311 line."
312 (check-type stroke-sym symbol)
313 (with-gensyms (stroke-index)
314 (once-only (line)
315 `(dotimes (,stroke-index (- (length (line-strokes ,line)) (line-stroke-count ,line)))
316 (let* ((,stroke-sym (aref (line-strokes ,line)
317 (+ (line-stroke-count ,line) ,stroke-index))))
318 ,@body)))))
319
320 (defun invalidate-strokes-in-region (view start-offset end-offset
321 &key modified cleared to-line-end)
322 "Invalidate all the strokes of `view' that overlap the region
323 `start-offset'/`end-offset' by setting their dirty-bit to
324 true. If `modified' or `cleared' is true, also set their
325 modified-bit to true. If `cleared' is true, inform the strokes
326 that their previous output has been cleared by someone, and that
327 they do not need to clear it themselves during their next
328 redisplay. If `to-line-end' is true, if a line is in the region,
329 strokes in it will be invalidated until the end, even if line-end
330 is beyond the region."
331 (as-region (start-offset end-offset)
332 ;; If the region is outside the visible region, no-op.
333 (when (and (plusp (displayed-lines-count view)) ; If there is any display...
334 (overlaps start-offset end-offset
335 (offset (top view)) (offset (bot view))))
336 (let ((line1-index (index-of-displayed-line-containing-offset view start-offset))
337 (line2-index (index-of-displayed-line-containing-offset view end-offset)))
338 (loop for line = (line-information view line1-index)
339 when (<= start-offset
340 (line-start-offset line) (line-end-offset line)
341 end-offset)
342 ;; The entire line is within the region.
343 do (invalidate-line-strokes line :modified modified
344 :cleared cleared)
345 ;; Only part of the line is within the region.
346 else do (do-displayed-line-strokes (stroke line)
347 (when (overlaps start-offset
348 (if to-line-end (line-end-offset line) end-offset)
349 (stroke-start-offset stroke)
350 (stroke-end-offset stroke))
351 (invalidate-stroke stroke :modified modified
352 :cleared cleared)))
353 if (= line1-index line2-index) do (loop-finish)
354 else do (incf line1-index))))))
355
356 (defun find-stroke-containing-offset (view offset)
357 "Find the stroke of `view' that displays the buffer offset
358 `offset'. If no such stroke can be found, this function returns
359 NIL."
360 (do-displayed-lines (line view)
361 (when (<= (line-start-offset line) offset (line-end-offset line))
362 (do-displayed-line-strokes (stroke line)
363 (when (and (<= (stroke-start-offset stroke) offset
364 (end-offset (stroke-end-offset stroke))))
365 (return stroke))))))
366
367 (defun index-of-displayed-line-containing-offset (view offset)
368 "Return the index of the `displayed-line' object containing
369 `offset'. If `offset' is before the displayed lines, return 0. If
370 `offset' is after the displayed lines, return the index of the
371 last line."
372 (with-accessors ((lines displayed-lines)) view
373 (cond ((< offset (line-start-offset (aref lines 0)))
374 0)
375 ((> offset (line-end-offset (last-displayed-line view)))
376 (1- (displayed-lines-count view)))
377 (t
378 ;; Binary search for the line.
379 (loop with low-index = 0
380 with high-index = (displayed-lines-count view)
381 for middle = (floor (+ low-index high-index) 2)
382 for this-line = (aref lines middle)
383 for line-start = (line-start-offset this-line)
384 for line-end = (line-end-offset this-line)
385 do (cond ((<= line-start offset line-end)
386 (loop-finish))
387 ((> offset line-start)
388 (setf low-index (1+ middle)))
389 ((< offset line-start)
390 (setf high-index middle)))
391 finally (return middle))))))
392
393 (defun ensure-line-information-size (view min-size)
394 "Ensure that the array of lines for `view' contains at least
395 `min-size' elements."
396 (with-accessors ((displayed-lines displayed-lines)) view
397 (setf displayed-lines
398 (ensure-array-size displayed-lines min-size
399 #'make-displayed-line))))
400
401 (defun line-information (view index)
402 "Return the `index'th `displayed-line' object of `view'."
403 (ensure-line-information-size view (1+ index))
404 (elt (displayed-lines view) index))
405
406 (defun last-displayed-line (view)
407 "Return the last line on display for `view', will result in an
408 error if there is no such line (note that even an empty buffer
409 consists of a single line on display, as long as it has been
410 redislayed at some point)."
411 (elt (displayed-lines view) (1- (displayed-lines-count view))))
412
413 (defun ensure-line-stroke-information-size (line min-size)
414 "Ensure that the array of strokes in `line' contains at least
415 `min-size' elements."
416 (with-accessors ((line-strokes line-strokes)) line
417 (setf line-strokes
418 (ensure-array-size line-strokes min-size
419 #'make-displayed-stroke))))
420
421 (defun line-stroke-information (line stroke-number)
422 "Return the `index'th `displayed-stroke' object of `line'."
423 (ensure-line-stroke-information-size line (1+ stroke-number))
424 (aref (line-strokes line) stroke-number))
425
426 (defun line-last-stroke (line)
427 "Return the last stroke in `line', will result in an error if
428 there is no such stroke (note that even an empty line consists of
429 a single stroke on display, as long as it has been redislayed at
430 some point)."
431 (aref (line-strokes line) (1- (line-stroke-count line))))
432
433 (defun put-stroke (view line pump-state line-change offset)
434 "Use `stroke-pump' with `pump-state' to get a new stroke for
435 `view', and add it to the sequence of displayed strokes in
436 `line'. `Line-change' should be a relative offset specifying how
437 much the start-offset of `line' has changed since the last time
438 it was redisplayed. `Offset' is the offset at which the next
439 stroke will start."
440 (let ((stroke (line-stroke-information line (line-stroke-count line))))
441 (unless (stroke-modified stroke)
442 (incf (stroke-start-offset stroke) line-change)
443 (incf (stroke-end-offset stroke) line-change)
444 (when (/= (stroke-start-offset stroke) offset)
445 (invalidate-stroke stroke :modified t)))
446 (prog1 (stroke-pump view stroke pump-state)
447 (incf (line-stroke-count line))
448 (setf (line-end-offset line) (stroke-end-offset stroke)))))
449
450 (defun record-stroke (stroke parts widths x1 y1 x2 y2
451 &optional (drawn t) (center (/ (- y2 y1) 2)))
452 "Record the fact that `stroke' has been drawn (if `drawn' is
453 true), that it consists of parts `parts' with the widths
454 `widths', and that it covers the specified area on screen. Sets
455 the dirty-bit of `stroke' to false if `drawn' is true, and always
456 sets the modified-bit of `stroke' to false, as it updates the
457 dimensions."
458 (let ((dimensions (stroke-dimensions stroke)))
459 (setf (stroke-dirty stroke) (and (stroke-dirty stroke) (not drawn))
460 (stroke-modified stroke) nil
461 (stroke-parts stroke) parts
462 (stroke-widths stroke) widths
463 (x1 dimensions) x1
464 (y1 dimensions) y1
465 (x2 dimensions) x2
466 (y2 dimensions) y2
467 (center dimensions) center)))
468
469 (defun non-graphic-char-rep (object)
470 "Return the appropriate representation of `object', a non-graphic char.
471 This will be a string of the format \"^[letter]\" for non-graphic chars
472 with a char-code of less than #o200, \"\\[octal code]\" for those above
473 #o200, and the #\\Tab character in the case of a #\\Tab.
474 NOTE: Assumes an ASCII/Unicode character encoding."
475 (let ((code (char-code object)))
476 (cond ((eql object #\Tab)
477 object)
478 ((< code #o200)
479 (format nil "^~C" (code-char (+ code (char-code #\@)))))
480 (t
481 (format nil "\\~O" code)))))
482
483 (defun analyse-stroke-string (string)
484 "Return a list of parts of `string', where each part is a continuous
485 run of graphic characters or a single non-graphic character. Each element
486 in the list is of the form START, END, and one of NIL (meaning a run
487 of graphic characters) or an object representing the non-graphic char."
488 (loop with len = (length string)
489 for left = 0 then (+ right 1)
490 for right = (or (position-if-not #'graphic-char-p string :start left)
491 len)
492 unless (= left right)
493 collect (list left right)
494 into parts
495 until (>= right len)
496 collect (list right
497 (+ right 1)
498 (non-graphic-char-rep (aref string right)))
499 into parts
500 finally (return parts)))
501
502 (defun calculate-stroke-width (stroke-string text-style stream x-position)
503 "Calculate the width information of `stroke-string' when
504 displayed with `text-style' (which must be fully specified) on
505 `stream', starting at the horizontal device unit offset
506 `x-position'. Three values will be returned: the total width of
507 the stroke, the parts of the stroke and the widths of the parts
508 of the stroke."
509 (loop with parts = (analyse-stroke-string stroke-string)
510 with width = 0
511 with widths = (make-array 1 :adjustable t :fill-pointer t :initial-element 0)
512 for (start end object) in parts
513 do (cond ((eql object #\Tab)
514 (incf width
515 (next-tab-stop stream (stream-default-view stream)
516 (+ width x-position)))
517 (vector-push-extend width widths))
518 (object
519 (multiple-value-bind (w)
520 (text-size stream object
521 :text-style text-style)
522 (incf width w)
523 (vector-push-extend width widths)))
524 (t
525 (multiple-value-bind (w)
526 (text-size stream stroke-string
527 :start start :end end
528 :text-style text-style)
529 (incf width w)
530 (vector-push-extend width widths))))
531 finally (return (values width parts widths))))
532
533 (defvar +roman-face-style+ (make-text-style nil :roman nil)
534 "A text style specifying a roman face, but with unspecified
535 family and size.")
536
537 (defun stroke-drawing-fn (stream view stroke cursor-x cursor-y draw)
538 "Draw `stroke' to `stream' baseline-adjusted at the position (`cursor-x',
539 `cursor-y'). `View' is the view object that `stroke' belongs
540 to. If `draw' is true, actually draw the stroke to `stream',
541 otherwise, just calculate its size. It is assumed that the buffer
542 region delimited by `stroke' only contains characters. `Stroke'
543 is drawn with face given by the drawing options of `stroke',
544 using the default text style of `stream' to fill out any
545 holes. The screen area beneath `stroke' will be cleared before
546 any actual output takes place."
547 (with-accessors ((start-offset stroke-start-offset)
548 (end-offset stroke-end-offset)
549 (dimensions stroke-dimensions)
550 (drawing-options stroke-drawing-options)
551 (widths stroke-widths)
552 (parts stroke-parts)) stroke
553 (let* ((stroke-string (in-place-buffer-substring
554 (buffer view) (cache-string view)
555 start-offset end-offset))
556 (merged-text-style (merge-text-styles
557 (face-style (drawing-options-face drawing-options))
558 (medium-merged-text-style (sheet-medium stream))))
559 ;; Ignore face when computing height, otherwise we get
560 ;; bouncy lines when things like parenmatching bolds parts
561 ;; of the line.
562 (roman-text-style (merge-text-styles +roman-face-style+ merged-text-style))
563 (text-style-ascent (text-style-ascent roman-text-style (sheet-medium stream)))
564 (text-style-descent (text-style-descent roman-text-style (sheet-medium stream))))
565 (with-accessors ((x1 x1) (x2 x2) (center center)) dimensions
566 (multiple-value-bind (width stroke-parts part-widths)
567 (if (stroke-modified stroke)
568 (calculate-stroke-width stroke-string merged-text-style stream cursor-x)
569 (values (- x2 x1) parts widths))
570 (when draw
571 (loop for (start end object) in stroke-parts
572 for width across part-widths
573 do (cond ((eql object #\Tab)
574 nil)
575 (object
576 (draw-text* stream object (+ cursor-x width)
577 cursor-y
578 :text-style merged-text-style
579 :ink +darkblue+
580 :align-y :baseline))
581 (t
582 (draw-text* stream stroke-string (+ cursor-x width)
583 cursor-y
584 :start start :end end
585 :text-style merged-text-style
586 :ink (face-ink (drawing-options-face drawing-options))
587 :align-y :baseline)))))
588 (record-stroke stroke stroke-parts part-widths
589 cursor-x (- cursor-y text-style-ascent)
590 (+ width cursor-x) (+ cursor-y text-style-descent)
591 draw text-style-ascent))))))
592
593 (defun update-stroke-dimensions (stream view stroke cursor-x cursor-y)
594 "Calculate the dimensions of `stroke' on `stream'
595 at (`cursor-x', `cursor-y'), but without actually drawing
596 anything. Will use the function specified in the drawing-options
597 of `stroke' to carry out the actual calculations."
598 (unless (and (= cursor-x (x1 (stroke-dimensions stroke)))
599 (= cursor-y (y1 (stroke-dimensions stroke)))
600 (not (stroke-dirty stroke))
601 (mark<= (stroke-end-offset stroke) (bot view)))
602 (invalidate-stroke stroke :modified t))
603 (when (stroke-dirty stroke)
604 (funcall (drawing-options-function (stroke-drawing-options stroke)) stream view stroke
605 cursor-x cursor-y #'stroke-drawing-fn nil)))
606
607 (defvar *highlight-strokes* nil
608 "If true, draw a box around all strokes and a line through
609 their baseline..")
610
611 (defvar *stroke-boundary-ink* +red+
612 "The ink with which stroke boundaries will be highlighted when
613 `*highlight-strokes* is true.")
614
615 (defvar *stroke-baseline-ink* +blue+
616 "The ink with which stroke baselines will be highlighted when
617 `*highlight-strokes* is true.")
618
619 (defun draw-stroke (pane view stroke cursor-x cursor-y)
620 "Draw `stroke' on `pane' with a baseline at
621 `cursor-y'. Drawing starts at the horizontal offset
622 `cursor-x'. Stroke must thus have updated dimensional
623 information. Nothing will be done unless `stroke' is dirty."
624 (when (stroke-dirty stroke)
625 (with-accessors ((x1 x1) (y1 y1) (x2 x2) (y2 y2)
626 (center center)) (stroke-dimensions stroke)
627 (when (> x2 (bounding-rectangle-width pane))
628 (change-space-requirements pane :width x2))
629 (when (> y2 (bounding-rectangle-height pane))
630 (change-space-requirements pane :height y2))
631 (funcall (drawing-options-function (stroke-drawing-options stroke))
632 pane view stroke cursor-x cursor-y #'stroke-drawing-fn t)
633 (when *highlight-strokes*
634 (draw-rectangle* pane x1 y1 (1- x2) (1- y2) :filled nil :ink *stroke-boundary-ink*)
635 (draw-line* pane x1 (+ y1 center) x2 (+ y1 center) :ink *stroke-baseline-ink*)))))
636
637 (defun end-line (line x1 y1 line-width line-height)
638 "End the addition of strokes to `line' for now, and update the
639 dimensions of `line'."
640 (let ((dimensions (line-dimensions line)))
641 (setf (x1 dimensions) x1
642 (y1 dimensions) y1
643 (x2 dimensions) (+ x1 line-width)
644 (y2 dimensions) (+ y1 line-height))))
645
646 (defun end-line-cleaning-up (view line line-x1 line-y1
647 line-width line-height)
648 "End the addition of strokes to `line' for now, and update the
649 dimensions of `line'."
650 (end-line line line-x1 line-y1 line-width line-height)
651 (setf (max-line-width view)
652 (max (max-line-width view)
653 (dimensions-width (line-dimensions line))))
654 ;; This way, strokes that have at one point been left undisplayed
655 ;; will always be considered modified when they are filled
656 ;; again. The return is for optimisation, we know that an unused
657 ;; stroke can only be followed by other unused strokes.
658 (do-undisplayed-line-strokes (stroke line)
659 (if (null (stroke-start-offset stroke))
660 (return)
661 (progn (setf (stroke-start-offset stroke) nil)
662 (invalidate-stroke stroke :modified t)))))
663
664 (defun draw-line-strokes (pane view initial-pump-state
665 start-offset cursor-x cursor-y
666 view-width)
667 "Pump strokes from `view', using `initial-pump-state' to begin
668 with, and draw them on `pane'. The line is set to start at the
669 buffer offset `start-offset', and will be drawn starting
670 at (`cursor-x', `cursor-y'). `View-width' is the width of the
671 view in device units, as calculated by the previous output
672 iteration."
673 (let* ((line (line-information view (displayed-lines-count view)))
674 (orig-x-offset cursor-x)
675 (offset-change (- start-offset (line-start-offset line)))
676 (line-spacing (stream-vertical-spacing pane)))
677 (setf (line-start-offset line) start-offset
678 (line-stroke-count line) 0)
679 ;; So yeah, this is fairly black magic, but it's not actually
680 ;; ugly, just complex.
681 (multiple-value-bind (line-width baseline descent pump-state)
682 ;; Pump all the line strokes and calculate their dimensions.
683 (loop with offset = start-offset
684 for index from 0
685 for stroke = (line-stroke-information line index)
686 for stroke-dimensions = (stroke-dimensions stroke)
687 for pump-state = (put-stroke view line initial-pump-state offset-change offset)
688 then (put-stroke view line pump-state offset-change offset)
689 do (update-stroke-dimensions pane view stroke cursor-x cursor-y)
690 (setf cursor-x (x2 stroke-dimensions))
691 (setf offset (stroke-end-offset stroke))
692 maximizing (- (dimensions-height stroke-dimensions)
693 (center stroke-dimensions)) into descent
694 maximizing (+ (center stroke-dimensions) cursor-y) into baseline
695 summing (dimensions-width stroke-dimensions) into line-width
696 when (stroke-at-end-of-line (buffer view) stroke)
697 return (values line-width baseline descent pump-state))
698 (let ((line-height (- (+ baseline descent) cursor-y)))
699 ;; Loop over the strokes and clear the parts of the pane that
700 ;; has to be redrawn, trying to minimise the number of calls to
701 ;; `clear-rectangle*'..
702 (flet ((maybe-clear (x1 x2)
703 (unless (= x1 x2)
704 (clear-rectangle* pane x1 cursor-y x2
705 (+ cursor-y line-height line-spacing)))))
706 (loop with last-clear-x = orig-x-offset
707 for stroke-index below (line-stroke-count line)
708 for stroke = (aref (line-strokes line) stroke-index)
709 for stroke-dimensions = (stroke-dimensions stroke)
710 do (unless (= baseline (+ cursor-y (center stroke-dimensions)))
711 (invalidate-stroke stroke))
712 (unless (stroke-dirty stroke)
713 (maybe-clear last-clear-x (x1 stroke-dimensions))
714 (setf last-clear-x (x2 stroke-dimensions)))
715 ;; This clears from end of line to the end of the sheet.
716 finally (maybe-clear last-clear-x (+ last-clear-x view-width))))
717 ;; Now actually draw them in a way that makes sure they all
718 ;; touch the bottom of the line.
719 (loop for stroke-index below (line-stroke-count line)
720 for stroke = (aref (line-strokes line) stroke-index)
721 for stroke-dimensions = (stroke-dimensions stroke)
722 do (draw-stroke pane view stroke (x1 stroke-dimensions) baseline)
723 finally (progn (end-line-cleaning-up view line orig-x-offset cursor-y
724 line-width line-height)
725 (incf (displayed-lines-count view))
726 (return (values pump-state line-height))))))))
727
728 (defun clear-stale-lines (pane view old-width old-height)
729 "Clear from the last displayed line to the end of `pane' and
730 mark undisplayed line objects as dirty. `Old-width'/`old-height'
731 are the old dimensions of the display of `view' in device units."
732 ;; This way, strokes of lines that have at one point been left
733 ;; undisplayed will always be considered modified when they are
734 ;; filled again. The return is for optimisation, we know that an
735 ;; unused stroke can only be followed by other unused strokes.
736 (do-undisplayed-lines (line view)
737 (setf (line-stroke-count line) 0)
738 (do-undisplayed-line-strokes (stroke line)
739 (if (null (stroke-start-offset stroke))
740 (return)
741 (progn (setf (stroke-start-offset stroke) nil)
742 (invalidate-stroke stroke :modified t)))))
743 (with-bounding-rectangle* (x1 y1 x2 y2) view
744 (declare (ignore x2))
745 (when (> old-height (- y2 y1))
746 (clear-rectangle* pane x1 y2 (+ x1 old-width) (+ y1 old-height)))))
747
748 (defun object-drawer ()
749 "Return a closure capable of functioning as a stroke drawer. It
750 expects its stroke to cover a single-object non-character buffer
751 region, which will be presented with its appropriate presentation
752 type (found via `presentation-type-of') to generate output."
753 (let (output-record
754 baseline
755 (widths (make-array 2 :initial-contents (list 0 0)))
756 (parts (list 0 1)))
757 #'(lambda (stream view stroke cursor-x cursor-y
758 default-drawing-fn draw)
759 (declare (ignore default-drawing-fn))
760 (with-accessors ((start-offset stroke-start-offset)
761 (drawing-options stroke-drawing-options)) stroke
762 (let* ((object (buffer-object (buffer view) start-offset)))
763 (when (or (null output-record) (stroke-modified stroke))
764 (setf output-record
765 (with-output-to-output-record (stream)
766 (present object (presentation-type-of object) :stream stream))
767 baseline (clim-extensions:output-record-baseline output-record)))
768 ;; You will not believe this! If `cursor-x' is 0, it seems
769 ;; like the changing position is ignored. So add some
770 ;; minuscule amount to it, and all will be well. 0.1
771 ;; device units shouldn't even be visible.
772 (let ((width (bounding-rectangle-width output-record)))
773 (setf (output-record-position output-record)
774 (values (+ cursor-x 0.1) (- cursor-y baseline)))
775 (when draw
776 (replay output-record stream))
777 (setf (aref widths 1) width)
778 (record-stroke stroke parts widths
779 cursor-x (- cursor-y baseline)
780 (+ width cursor-x) cursor-y
781 draw baseline)))))))
782
783 (defmethod display-drei-view-contents ((pane basic-pane) (view drei-buffer-view))
784 (with-bounding-rectangle* (x1 y1 x2 y2) view
785 (let* ((old-width (- x2 x1))
786 (old-height (- y2 y1))
787 (start-offset (offset (beginning-of-line (top view))))
788 (pump-state (pump-state-for-offset view start-offset))
789 (pane-height (bounding-rectangle-height (or (pane-viewport pane) pane))))
790 ;; For invalidation of the parts of the display that have
791 ;; changed.
792 (synchronize-view view :begin (offset (top view)) :end (max (offset (bot view))
793 (offset (top view))))
794 (setf (displayed-lines-count view) 0
795 (max-line-width view) 0)
796 (multiple-value-bind (cursor-x cursor-y) (stream-cursor-position pane)
797 (with-output-recording-options (pane :record nil :draw t)
798 (loop for line = (line-information view (displayed-lines-count view))
799 do (multiple-value-bind (new-pump-state line-height)
800 (draw-line-strokes pane view pump-state start-offset
801 cursor-x cursor-y old-width)
802 (setf pump-state new-pump-state
803 start-offset (1+ (line-end-offset line)))
804 (incf cursor-y (+ line-height (stream-vertical-spacing pane))))
805 when (or (and (not (extend-pane-bottom view))
806 (>= (y2 (line-dimensions line)) pane-height))
807 (= (line-end-offset line) (size (buffer view))))
808 return (progn
809 (setf (offset (bot view)) (line-end-offset line))
810 (clear-stale-lines pane view old-width old-height))))))))
811
812 ;;; A default redisplay implementation that should work for subclasses
813 ;;; of `drei-buffer-view'. Syntaxes that don't want to implement their
814 ;;; own redisplay behavior can just call these.
815
816 (defstruct (pump-state
817 (:constructor make-pump-state
818 (line-index offset chunk-index)))
819 "A pump state object used by the `drei-buffer-view'. `Line' is
820 the line object `offset' is in, and `line-index' is the index of
821 `line' in the list of lines maintained by the view that created
822 this pump state."
823 line-index offset chunk-index)
824
825 (defun chunk-for-offset (buffer-line offset)
826 "Return the index of the first chunk of `buffer-line' that
827 contains `offset'."
828 (position (- offset (offset (start-mark buffer-line)))
829 (chunks buffer-line) :test #'<= :key #'car))
830
831 (defun buffer-view-pump-state-for-offset (view offset)
832 "Return a pump state usable for pumpting strokes for `view' (a
833 `drei-buffer-view') from `offset'."
834 ;; Perform binary search looking for line starting with `offset'.
835 (synchronize-view view :begin offset)
836 (with-accessors ((lines lines)) view
837 (loop with low-index = 0
838 with high-index = (nb-elements lines)
839 for middle = (floor (+ low-index high-index) 2)
840 for this-line = (element* lines middle)
841 for line-start = (start-mark this-line)
842 do (cond ((offset-in-line-p this-line offset)
843 (loop-finish))
844 ((mark> offset line-start)
845 (setf low-index (1+ middle)))
846 ((mark< offset line-start)
847 (setf high-index middle)))
848 finally (return (make-pump-state
849 middle offset (chunk-for-offset this-line offset))))))
850
851 (defun fetch-chunk (line chunk-index)
852 "Retrieve the `chunk-index'th chunk from `line'. The return
853 value is either an integer, in which case it specifies the
854 end-offset of a string chunk relative to the start of the line,
855 or a function, in which case it is the drawing function for a
856 single-object non-character chunk."
857 (destructuring-bind (relative-chunk-end-offset . objectp)
858 (aref (chunks line) chunk-index)
859 (if objectp (object-drawer) (+ relative-chunk-end-offset
860 (offset (start-mark line))))))
861
862 (defun buffer-view-stroke-pump (view stroke pump-state)
863 "Pump redisplay data into `stroke' based on `pump-state' and
864 the information managed by `view', which must be a
865 `drei-buffer-view'."
866 ;; `Pump-state' will be destructively modified.
867 (prog1 pump-state
868 (with-accessors ((line-index pump-state-line-index)
869 (offset pump-state-offset)
870 (chunk-index pump-state-chunk-index)) pump-state
871 (let* ((chunk (fetch-chunk
872 (element* (lines view) line-index) chunk-index))
873 (drawing-options (if (functionp chunk)
874 (make-drawing-options :function chunk)
875 +default-drawing-options+))
876 (end-offset (if (functionp chunk)
877 (1+ offset)
878 chunk)))
879 (setf (stroke-start-offset stroke) offset
880 (stroke-end-offset stroke) end-offset
881 (stroke-drawing-options stroke) drawing-options)
882 (if (offset-end-of-line-p (buffer view) end-offset)
883 (setf line-index (1+ line-index)
884 chunk-index 0
885 offset (1+ end-offset))
886 (setf chunk-index (1+ chunk-index)
887 offset end-offset))))))
888
889 (defmethod pump-state-for-offset ((view drei-buffer-view) (offset integer))
890 (buffer-view-pump-state-for-offset view offset))
891
892 (defmethod stroke-pump ((view drei-buffer-view) stroke pump-state)
893 (buffer-view-stroke-pump view stroke pump-state))
894
895 ;;; The following is the equivalent of a turbocharger for the
896 ;;; redisplay engine.
897 (defstruct (skipalong-pump-state
898 (:constructor make-skipalong-pump-state (offset)))
899 "A pump state for fast skipalong that doesn't involve
900 the (potentially expensive) actual stroke pump. It transparently
901 turns into a real pump state when it happens across invalid
902 strokes. `Offset' is the offset of the next stroke to be pumped."
903 offset)
904
905 (defmethod stroke-pump :around ((view drei-buffer-view) (stroke displayed-stroke)
906 (pump-state skipalong-pump-state))
907 (with-accessors ((state-offset skipalong-pump-state-offset)) pump-state
908 (if (or (stroke-modified stroke)
909 (/= (stroke-start-offset stroke) state-offset))
910 (stroke-pump view stroke (pump-state-for-offset view state-offset))
911 (progn (setf state-offset
912 (+ (stroke-end-offset stroke)
913 (if (offset-end-of-line-p
914 (buffer view) (stroke-end-offset stroke))
915 1 0)))
916 pump-state))))
917
918 (defmethod stroke-pump :around ((view drei-buffer-view) (stroke displayed-stroke)
919 pump-state)
920 (if (stroke-modified stroke)
921 (call-next-method)
922 (stroke-pump view stroke (make-skipalong-pump-state (stroke-start-offset stroke)))))
923
924 ;;; Cursor handling.
925
926 (defun offset-in-stroke-position (stream view stroke offset)
927 "Calculate the position in device units of `offset' in
928 `stroke', relative to the starting position of `stroke'. `Offset'
929 is an absolute offset into the buffer of `view',"
930 (let ((string (in-place-buffer-substring
931 (buffer view) (cache-string view)
932 (stroke-start-offset stroke) offset)))
933 (loop with pos = (- offset (stroke-start-offset stroke))
934 for width across (stroke-widths stroke)
935 for next upfrom 1
936 for (start end object) in (stroke-parts stroke)
937 when (and object (= pos end))
938 do (return (aref (stroke-widths stroke) next))
939 when (<= start pos end)
940 do (return (+ width
941 (text-size stream string
942 :start start
943 :end pos
944 :text-style (merge-text-styles
945 (face-style
946 (drawing-options-face
947 (stroke-drawing-options stroke)))
948 (medium-merged-text-style (sheet-medium stream)))))))))
949
950 (defgeneric offset-to-screen-position (pane view offset)
951 (:documentation "Returns the position of offset as a screen
952 position. Returns `x', `y', `stroke-height', `object-width' as
953 values if offset is on the screen, NIL if offset is before the
954 beginning of the screen, and T if offset is after the end of the
955 screen. `Object-width' may be an approximation if `offset' is at
956 the end of the buffer."))
957
958 (defmethod offset-to-screen-position ((pane clim-stream-pane) (view drei-view) (offset number))
959 (flet ((worker ()
960 (do-displayed-lines (line view)
961 (when (<= (line-start-offset line) offset (line-end-offset line))
962 (with-accessors ((line-dimensions line-dimensions)) line
963 (do-displayed-line-strokes (stroke line)
964 (with-accessors ((start-offset stroke-start-offset)
965 (end-offset stroke-end-offset)
966 (stroke-dimensions stroke-dimensions)) stroke
967 (cond ((and (= start-offset offset)
968 (/= start-offset end-offset))
969 (return-from worker
970 (values (x1 stroke-dimensions) (y1 stroke-dimensions)
971 (dimensions-height stroke-dimensions)
972 (if (= end-offset (1+ start-offset))
973 (dimensions-width stroke-dimensions)
974 (offset-in-stroke-position pane view stroke (1+ offset))))))
975 ((and (<= start-offset offset)
976 (< offset end-offset))
977 (return-from worker
978 (let* ((relative-x-position (offset-in-stroke-position pane view stroke offset))
979 (absolute-x-position (+ (x1 stroke-dimensions) relative-x-position)))
980 (values absolute-x-position (y1 stroke-dimensions)
981 (dimensions-height stroke-dimensions)
982 (if (= (1+ offset) end-offset)
983 (- (x2 stroke-dimensions) absolute-x-position)
984 (- (offset-in-stroke-position pane view stroke (1+ offset))
985 relative-x-position)))))))))
986 ;; If we reach this point, we are just past the last
987 ;; stroke, so let's extract information from it.
988 (let ((stroke-dimensions (stroke-dimensions (line-last-stroke line))))
989 (return-from
990 worker (values (x2 stroke-dimensions) (y1 stroke-dimensions)
991 (dimensions-height stroke-dimensions)))))))))
992 (with-accessors ((buffer buffer) (top top) (bot bot)) view
993 (let ((default-object-width
994 (text-style-width
995 (medium-merged-text-style (sheet-medium pane)) pane)))
996 (cond
997 ((< offset (offset top)) nil)
998 ((< (offset bot) offset) t)
999 (t
1000 ;; Search through strokes, returning when we find one that
1001 ;; `offset' is in. Strokes with >1 object are assumed to be
1002 ;; strings.
1003 (multiple-value-bind (x y stroke-height object-width) (worker)
1004 (if (and x y stroke-height)
1005 (values x y stroke-height (or object-width default-object-width))
1006 (let* ((first-line (aref (displayed-lines view) 0))
1007 (dimensions (line-dimensions first-line)))
1008 (values (x1 dimensions) (y1 dimensions)
1009 (- (y2 dimensions) (y1 dimensions))
1010 default-object-width))))))))))
1011
1012 (defmethod display-drei-view-cursor :around ((pane extended-output-stream)
1013 (view point-mark-view)
1014 (cursor drei-cursor))
1015 ;; Try to draw the cursor...
1016 (call-next-method)
1017 ;; If it is the point, and there was no space for it...
1018 (when (and (eq (mark cursor) (point view))
1019 (or (> (bounding-rectangle-max-x cursor)
1020 (bounding-rectangle-max-x pane))
1021 (> (if (extend-pane-bottom view)
1022 (bounding-rectangle-max-y cursor)
1023 0)
1024 (bounding-rectangle-max-y pane))))
1025 ;; Embiggen the sheet.
1026 (change-space-requirements pane
1027 :width (max (bounding-rectangle-max-x cursor)
1028 (bounding-rectangle-max-x pane))
1029 :height (max (if (extend-pane-bottom view)
1030 (bounding-rectangle-max-y cursor)
1031 0)
1032 (bounding-rectangle-max-y pane)))
1033 ;; And draw the cursor again.
1034 (call-next-method)))
1035
1036 (defmethod display-drei-view-cursor :around ((stream extended-output-stream)
1037 (view drei-buffer-view)
1038 (cursor drei-cursor))
1039 (clear-output-record cursor)
1040 (when (visible-p cursor)
1041 (prog1 (call-next-method)
1042 (with-bounding-rectangle* (x1 y1 x2 y2) cursor
1043 (do-displayed-lines (line view)
1044 (cond ((> (y1 (line-dimensions line)) y2)
1045 (return))
1046 ((coordinates-intersects-dimensions
1047 (line-dimensions line) x1 y1 x2 y2)
1048 (block stroke-loop
1049 (do-displayed-line-strokes (stroke line)
1050 (cond ((> (x1 (stroke-dimensions stroke)) x2)
1051 (return-from stroke-loop))
1052 ((coordinates-intersects-dimensions
1053 (stroke-dimensions stroke) x1 y1 x2 y2)
1054 (setf (stroke-dirty stroke) t)
1055 (setf (stroke-modified stroke) t))))))))
1056 (with-bounding-rectangle* (vx1 vy1 vx2 vy2) view
1057 (declare (ignore vy1 vx2 vy2))
1058 (setf (max-line-width view)
1059 (max (max-line-width view)
1060 (- x2 vx1))))))))
1061
1062 (defmethod display-drei-view-cursor ((stream extended-output-stream)
1063 (view drei-buffer-view)
1064 (cursor drei-cursor))
1065 (multiple-value-bind (cursor-x cursor-y stroke-height object-width)
1066 (offset-to-screen-position stream view (offset (mark cursor)))
1067 (letf (((stream-current-output-record stream) cursor))
1068 (unless (zerop (* object-width stroke-height))
1069 (draw-rectangle* stream
1070 cursor-x cursor-y
1071 (+ cursor-x object-width) (+ cursor-y stroke-height)
1072 :ink (ink cursor))))))
1073
1074 (defmethod bounding-rectangle* ((view drei-buffer-view))
1075 "Return the bounding rectangle of the visual appearance of
1076 `view' as four values, just as `bounding-rectangle*'. Will return
1077 0, 0, 0, 0 when `view' has not been redisplayed."
1078 (if (zerop (displayed-lines-count view))
1079 (values 0 0 0 0)
1080 (let ((first-line (aref (displayed-lines view) 0))
1081 (last-line (last-displayed-line view)))
1082 (values (x1 (line-dimensions first-line))
1083 (y1 (line-dimensions first-line))
1084 (+ (x1 (line-dimensions first-line)) (max-line-width view))
1085 (y2 (line-dimensions last-line))))))
1086
1087 (defmethod bounding-rectangle-width ((view drei-buffer-view))
1088 (multiple-value-bind (x1 y1 x2)
1089 (bounding-rectangle* view)
1090 (declare (ignore y1))
1091 (- x2 x1)))
1092
1093 (defun drei-bounding-rectangle* (drei-instance)
1094 "Return the bounding rectangle of the visual appearance of
1095 `drei-instance' as four values, just as `bounding-rectangle*'."
1096 (bounding-rectangle* (view drei-instance)))
1097
1098 (defun drei-bounding-rectangle-width (drei-instance)
1099 "Return the width of the bounding rectangle of `drei-instance',
1100 calculated by `drei-bounding-rectangle*'."
1101 (multiple-value-bind (x1 y1 x2)
1102 (drei-bounding-rectangle* drei-instance)
1103 (declare (ignore y1))
1104 (- x2 x1)))
1105
1106 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1107 ;;;
1108 ;;; Drei area redisplay.
1109
1110 ;; XXX: Full redraw for every replay, should probably use the `region'
1111 ;; parameter to only invalidate some strokes.
1112 (defmethod replay-output-record ((drei drei-area) (stream extended-output-stream) &optional
1113 (x-offset 0) (y-offset 0) (region +everywhere+))
1114 (declare (ignore x-offset y-offset region))
1115 (letf (((stream-cursor-position stream) (output-record-start-cursor-position drei)))
1116 (invalidate-all-strokes (view drei))
1117 (display-drei-view-contents stream (view drei))))
1118
1119 (defmethod replay-output-record ((cursor drei-cursor) stream &optional
1120 (x-offset 0) (y-offset 0) (region +everywhere+))
1121 (declare (ignore x-offset y-offset region))
1122 (with-output-recording-options (stream :record t :draw t)
1123 (display-drei-view-cursor stream (view cursor) cursor)))
1124
1125 (defun display-drei-area (drei)
1126 (with-accessors ((stream editor-pane) (view view)) drei
1127 (with-bounding-rectangle* (old-x1 old-y1 old-x2 old-y2) drei
1128 (replay drei stream)
1129 (with-bounding-rectangle* (new-x1 new-y1 new-x2 new-y2) drei
1130 (unless (or (and (= new-x1 old-x1) (= new-y1 old-y2)
1131 (= new-x2 old-x2) (= new-y2 old-y2))
1132 (null (output-record-parent drei)))
1133 (recompute-extent-for-changed-child (output-record-parent drei) drei
1134 old-x1 old-y1 old-x2 old-y2))))
1135 (when (point-cursor drei)
1136 (with-bounding-rectangle* (x1 y1 x2 y2) (point-cursor drei)
1137 (when (pane-viewport stream)
1138 (let* ((viewport (pane-viewport stream))
1139 (viewport-height (bounding-rectangle-height viewport))
1140 (viewport-width (bounding-rectangle-width viewport))
1141 (viewport-region (pane-viewport-region stream)))
1142 ;; Scroll if point went outside the visible area.
1143 (when (and (active drei)
1144 (pane-viewport stream)
1145 (not (and (region-contains-position-p viewport-region x2 y2)
1146 (region-contains-position-p viewport-region x1 y1))))
1147 (scroll-extent stream
1148 (max 0 (- x2 viewport-width))
1149 (max 0 (- y2 viewport-height))))))))))
1150
1151 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1152 ;;;
1153 ;;; Drei pane redisplay.
1154
1155 (defgeneric handle-redisplay (pane view region)
1156 (:documentation "Handle redisplay of `view' upon `pane' (which
1157 is a Drei pane) in the given region. Methods defined on this
1158 function should mark their redisplay information as dirty based
1159 on `region' and call the default method, which will in turn call
1160 `display-drei' on `pane'.")
1161 (:method ((pane drei-pane) (view drei-view) (region region))
1162 (display-drei pane)))
1163
1164 (defmethod handle-repaint ((pane drei-pane) region)
1165 (handle-redisplay pane (view pane) region))
1166
1167 (defmethod handle-redisplay ((pane drei-pane) (view drei-buffer-view) (region region))
1168 (invalidate-all-strokes (view pane) :cleared t)
1169 (call-next-method))
1170
1171 (defun reposition-pane (drei-pane)
1172 "Try to put point close to the middle of the pane by moving top
1173 half a pane-size up."
1174 (let* ((view (view drei-pane))
1175 (nb-lines-in-pane (number-of-lines-in-region (top view) (bot view))))
1176 (with-accessors ((top top) (point point)) view
1177 (setf (offset top) (offset point))
1178 (beginning-of-line top)
1179 (loop do (beginning-of-line top)
1180 repeat (floor nb-lines-in-pane 2)
1181 until (beginning-of-buffer-p top)
1182 do (decf (offset top))
1183 (beginning-of-line top))
1184 (invalidate-all-strokes view :modified t))))
1185
1186 (defun adjust-pane (drei-pane)
1187 "Reposition the pane if point is outside the region delimited
1188 by the top/bot marks of its view. Returns true if adjustment was
1189 needed."
1190 (when (typep (view drei-pane) 'point-mark-view)
1191 (with-accessors ((buffer buffer) (top top) (bot bot)
1192 (point point)) (view drei-pane)
1193 (when (or (mark< point top)
1194 (mark> point bot))
1195 (reposition-pane drei-pane)
1196 t))))
1197
1198 (defmethod page-down (pane (view drei-buffer-view))
1199 (with-accessors ((top top) (bot bot)) view
1200 (when (mark> (size (buffer bot)) bot)
1201 (setf (offset top) (offset bot))
1202 (beginning-of-line top)
1203 (setf (offset (point view)) (offset top))
1204 (invalidate-all-strokes view :modified t))))
1205
1206 (defmethod page-up (pane (view drei-buffer-view))
1207 (with-accessors ((top top) (bot bot)) view
1208 (when (> (offset top) 0)
1209 (setf (offset (point view)) (offset top))
1210 (backward-object (point view))
1211 (beginning-of-line (point view)))))
1212
1213 (defgeneric fix-pane-viewport (pane view)
1214 (:documentation "Fix the size and scrolling of `pane', which
1215 has `view'."))
1216
1217 (defmethod fix-pane-viewport ((pane drei-pane) (view drei-view))
1218 (let* ((output-width (drei-bounding-rectangle-width pane))
1219 (viewport (pane-viewport pane))
1220 (viewport-width (and viewport (bounding-rectangle-width viewport)))
1221 (pane-width (bounding-rectangle-width pane)))
1222 ;; If the width of the output is greater than the width of the
1223 ;; sheet, make the sheet wider. If the sheet is wider than the
1224 ;; viewport, but doesn't really need to be, make it thinner.
1225 (when (and viewport
1226 (> pane-width viewport-width)
1227 (>= viewport-width output-width))
1228 (change-space-requirements pane :width output-width))))
1229
1230 (defmethod fix-pane-viewport :after ((pane drei-pane) (view point-mark-view))
1231 (when (and (pane-viewport pane) (active pane))
1232 (with-bounding-rectangle* (x1 y1 x2 y2) (point-cursor pane)
1233 (declare (ignore y1))
1234 (multiple-value-bind (x-position y-position) (transform-position (sheet-transformation pane) 0 0)
1235 (let ((viewport-width (bounding-rectangle-width (or (pane-viewport pane) pane)))
1236 (viewport-height (bounding-rectangle-height (or (pane-viewport pane) pane))))
1237 (cond ((> x2 (+ (abs x-position) viewport-width))
1238 (scroll-extent pane (round (- x2 viewport-width)) 0))
1239 ((> (abs x-position) x2)
1240 (scroll-extent pane (if (> viewport-width x1)
1241 0
1242 (round x1))
1243 0)))
1244 (when (and (> y2 (+ y-position viewport-height))
1245 (not (end-of-buffer-p (bot view))))
1246 (full-redisplay pane)
1247 ;; We start all over!
1248 (display-drei-pane (pane-frame pane) pane)))))))
1249
1250 (defmethod pane-needs-redisplay :around ((pane drei-pane))
1251 (values (call-next-method) nil))
1252
1253 (defgeneric fully-redisplay-pane (pane view)
1254 (:documentation "Fully redisplay `pane' showing `view', finally
1255 setting the `full-redisplay-p' flag to false.")
1256 (:method :after (pane (view drei-view))
1257 (setf (full-redisplay-p view) nil)))
1258
1259 (defmethod fully-redisplay-pane ((drei-pane drei-pane)
1260 (view point-mark-view))
1261 (reposition-pane drei-pane))
1262
1263 (defmethod fully-redisplay-pane :after ((drei-pane drei-pane)
1264 (view drei-buffer-view))
1265 (invalidate-all-strokes view))
1266
1267 (defun display-drei-pane (frame drei-pane)
1268 "Display `pane'. If `pane' has focus, `current-p' should be
1269 non-NIL."
1270 (let ((view (view drei-pane)))
1271 (with-accessors ((buffer buffer)) view
1272 (when (typep view 'point-mark-view)
1273 (when (full-redisplay-p view)
1274 (fully-redisplay-pane drei-pane view)))
1275 (setf (stream-cursor-position drei-pane) (values 0 0))
1276 (display-drei-view-contents drei-pane view)
1277 (if (adjust-pane drei-pane)
1278 (display-drei-pane frame drei-pane)
1279 ;; Point must be on top of all other cursors.
1280 (dolist (cursor (cursors drei-pane)
1281 (fix-pane-viewport drei-pane (view drei-pane)))
1282 (replay cursor drei-pane))))))
1283
1284 (defgeneric full-redisplay (pane)
1285 (:documentation "Queue a full redisplay for `pane'."))
1286
1287 (defmethod full-redisplay ((pane drei-pane))
1288 (setf (full-redisplay-p (view pane)) t))

  ViewVC Help
Powered by ViewVC 1.1.5